suppressMessages(library(jsonlite))
suppressMessages(library(signal))

# Read the JSON Parameters
readParameters<-function(f){
    line <- readLines(f,n=1)

    if ( line=="" ) {
        write("Error: Parameters not found. Exiting.", stderr())
        quit(status=1)
    } else {
        write("Parameters found", stderr())

        inParameters<-fromJSON(line)

        return (inParameters)
    }
}

checkRowCount<-function(rowCount) {
    if (rowCount$rowCount < 1) {
        write("Error: Very few number of rows(less than 1)", stderr())
        printEmpty()
    }
    return (rowCount)
}

checkParameters <- function(parameters,rowCount) {
    check <- 0
    if (parameters$parameters$windowSize > rowCount) {
        write("Error: invalid windowSize",stderr())
    } else if (parameters$parameters$overlapStep > 100) {
        write("Error: OverlapStep should be between 0 and 100",stderr())
    } else if (parameters$command=="wave") {
        check <- checkWaveParams(parameters)
    } else if (parameters$command=="paddle") {
        check <- checkPaddleParams(parameters)
    } else if (parameters$command=="duckdive") {
        check <- checkDuckdiveParams(parameters)
    } else if (parameters$command=="exit") {
        check <- 1
    } else {
        write("Error: Unknown event type",stderr())
        printEmpty(parameters$command)
    }

    return(check)
}

printEmpty <- function(type) {
    names <- c("type","results")
    results<-vector("list",length(names))
    names(results) <- names
    results$type <- unbox(type)
    results$results <- vector()
    write("Outputing results to STDOUT", stderr())
    cat(toJSON(results))
}

# Find Spectral Entropy, Dominant Frequency
# of a given signal x, with window size winSize
findSpecEntropy<-function(x,winSize,OverlapStep,norm) {

    n_samples<-length(x)

    if(OverlapStep > 0) {
        Overlap <- floor((OverlapStep*winSize)/100)
        nFrames <- floor(n_samples/Overlap) - 1
    } else {
        Overlap <- winSize
        nFrames <- floor(n_samples/Overlap) - 100
    }

    Entropy <- rep(0,nFrames) # it needs to be a column vec!
    domFreq <- Entropy

    k <- 1
    inc <- 1 # 100?

    while ( (k+winSize-1) <= n_samples ) {
        FrameSignal <- x[k:(k+winSize-1)]
        v <- (as.numeric(as.character(FrameSignal)) * hanning(length(FrameSignal)))
        N <- length(v)
        Y <- fft(v)

        sqrtPyy <- ((sqrt(abs(Y)*abs(Y))*2)/N)
        sqrtPyy <- sqrtPyy [1:(winSize/2)]

        d <- sqrtPyy

        domFreq[inc] <- which(d==max(d))*(50/128)

        if (norm==1) {
            d <- d/sum(d+1e-12)
        }

        logd <- log(d+1e-12)/log(2)
        Entropy[inc] <- -sum(d*logd)*log(2)/log(length(d))

        k <- k + Overlap
        inc <- inc + 1
    }

    Entropy <- list(Entropy=Entropy,domFreq=domFreq,nFrames=nFrames)
    return(Entropy)
}

# Get the labeled event signal from a given panel whose entropy is calculated
# with a window of length winSize and thresholded at values greater than the given threshold
getEvent <- function(panel,Entropy,thresholdDirection, threshold,winSize) {

    if(thresholdDirection == "above"){
        Entropy[which(Entropy>threshold*(max(Entropy)))]<-1
    } else if(thresholdDirection == "below"){
        Entropy[which(Entropy<threshold*(min(Entropy)))]<-1
    } else{
        write("Error: must specify threshold direction. Exiting.", stderr())
        quit(status = 1)
    }

    Entropy[which(Entropy!=1)]<-0
    event<-rep(0,length(panel))
    event[((winSize/2)*(1:length(Entropy)))]<-Entropy

    idx <- which(event==1)

    if (length(idx) > 1) {
        for( i in 1:length(idx) ){
            event[idx[i]:(idx[i]+winSize)]<-1
        }
    } else {
        event[which(event==1)]<-0
    }

    return(event)
}

# Read sensor:axis data from the panel
readPanel <- function(f,rowCount) {

    # Read the labels
    line <- readLines(f,n=1)
    if (line=="") {
        cat(toJSON(list(message="Error: MissingData: panel axes not found")))
        quit(save="default",status=1,runLast=FALSE)
    }

    axesLabels<-strsplit(line, ",")

    # initializing a list to contain all the parameter lists
    wParam<-rep(list(list()),length(axesLabels[[1]]))

    for (param in 1:length(wParam)) {
        length(wParam[[param]])<-rowCount
    }

    rowCtr<- 0

    # Read the first row of the panel data
    line <- readLines(f,n=1)
    while(length(line) > 0  # break on EOF
          && nchar(line) > 0 # or on empty line (does this actually work?
                             # line is a vector, right? It seems to, but prove it. -SRLM)
    ){
        rowCtr<-rowCtr+1
        # split the panel on comma
        rowData <- list(as.numeric(unlist(strsplit(line,","))))

        # Getting different parameter values
        for( param in 1:length(axesLabels[[1]]) ) {
            wParam[[param]][rowCtr]<-rowData[[1]][param]
        }

        # check for NANs
        wParam[which(is.na(wParam))]<-0

        if(rowCtr %% 10000 == 0){
            cat("Read", rowCtr, "/", rowCount, "lines from input panel\n", file=stderr())
        }

        # Is this the last row?
        # SRLM note: this should be in the while test, not here.
        if(rowCtr == rowCount){
            # Break if it's the last row.
            break;
        }
        # If it's not the last row, then read the next row.
        line <- readLines(f,n=1)
    }

    wTrain<-list()

    for( param in 1:length(axesLabels[[1]]) ) {
        wTrain[[axesLabels[[1]][param]]]<-unlist(wParam[[param]])
    }
    return (wTrain)
}

# Convert the detected sample-by-sample to give out start and stop
outputLabels<-function(wDetected,winSize,wTime,mergeThreshold) {

    # Shift the detected panel by 1, by appending 0 as the first element
    wShiftDetected<-append(0,wDetected)

    # First difference between the original and the shifted should give the transitions
    wDiff<-wDetected-wShiftDetected[1:length(wDetected)]

    # convert to time assuming each sample is 10ms apart
    # wTransition<-which(wDiff!=0)*10 <<Shyama: these give the actual 10ms times>>

    # convert to time stamps
    wIndices<-which(wDiff!=0)
    wTransition<-wTime[wIndices[1:length(wIndices)]]

    # getting the start/end times
    wStartTimes<-list()
    wEndTimes<-list()

    # Check if the list is even, then pick alternate times from wTransition
    if (length(wTransition)%%2==0) {
        wStartTimes<-wTransition[((1:(length(wTransition)/2))*2)-1]
        wEndTimes<-wTransition[((1:(length(wTransition)/2))*2)]
    } else if (length(wTransition)!=1) {
        wStartTimes<-wTransition[((1:((length(wTransition)-1)/2))*2)-1]
        wEndTimes<-wTransition[((1:((length(wTransition)-1)/2))*2)]
    } else {
        wStartTimes<-wTransition
    }

    # if the last event has a start time but no end time, quote the end time as inf
    if (length(wStartTimes)>length(wEndTimes)) {
        wEndTimes<-append(wEndTimes,length(wDetected))
        if (length(wStartTimes) > 1) {
            # Merge events that are "close" together (less than mergeThreshold)
            for (t in 1:(length(wStartTimes)-1)) {
                if ((wStartTimes[t+1]-wEndTimes[t])<mergeThreshold) {
                    wStartTimes[t+1]<-(-1)
                    wEndTimes[t]<-(-1)
                }
            }
        }
        else {
                wStartTimes<-0
                wEndTimes<-0
        }
    }

    wStartTimes=wStartTimes[wStartTimes!=-1]
    wEndTimes=wEndTimes[wEndTimes!=-1]

    wOutLabels<-list(startTime=wStartTimes,endTime=wEndTimes)

    return(wOutLabels)
}

# find the cumulative Spectral Entropy
findCSE<-function(panel,threshold,thresholdDirection,overlapStep,winSize) {

    entropy<-findSpecEntropy(panel,winSize,overlapStep,1)
    wDetected<-getEvent(panel,entropy,thresholdDirection,threshold,winSize)

    # Shift the detected panel by 1, by appending 0 as the first element
    fullEntropy<-rep(0,length(wDetected))
    fullEntropy[((winSize/2)*(1:length(entropy)))]<-entropy

    wDetected[which(wDetected!=0)]<-1
    wShiftDetected<-append(0,wDetected)

    # First difference between the original and the shifted should give the transitions
    wDiff<-wDetected-wShiftDetected[1:length(wDetected)]

    wIndices<-which(wDiff!=0)

    sumEntropy<-rep(0,length(fullEntropy))
    for ( t in 1:((length(wIndices)/2)-1) ) {
        sumEntropy[wIndices[2*t+1]:wIndices[2*(t+1)]] <- rep(
                    sum(fullEntropy[wIndices[2*t+1]:wIndices[2*(t+1)]]),
                    length(wIndices[2*t+1]:wIndices[2*(t+1)]))
    }

    return(sumEntropy)
}

findTransition<-function(event) {
    # Extracting the start, end times
    shiftedWave<-append(0,event)
    wDiff<-event-shiftedWave[1:length(event)]
    wTransition<-which(wDiff!=0)

    # print(length(which(wDiff!=0)))

    if (length(wTransition)%%2==0) {
        wStartTimes<-wTransition[((1:(length(wTransition)/2))*2)-1]
        wEndTimes<-wTransition[((1:(length(wTransition)/2))*2)]
    } else if (length(wTransition)!=1) {
        wStartTimes<-wTransition[((1:((length(wTransition)-1)/2))*2)-1]
        wEndTimes<-wTransition[((1:((length(wTransition)-1)/2))*2)]
    } else {
        wStartTimes<-wTransition
    }

    if (length(wStartTimes)>length(wEndTimes)) {
        wEndTimes<-append(wEndTimes,length(event))
    }

    return(list(wStartTimes=wStartTimes,wEndTimes=wEndTimes))
}


library(tidyverse)

res <- read_tsv("res_runs.tsv", col_names=c("dataset","assembler","ref_tot","ref_cov","ref_cov_frac","qry_tot","qry_cov","qry_cov_frac","contig_num"))
res %<>% mutate(rep_res = exp(-abs(log(qry_cov/ref_cov)))) %>% mutate(score = (1 - ((abs(1-ref_cov_frac)/4) + (abs(1-qry_cov_frac)/4) + (abs(1-rep_res)/4) + (abs(1-(1/contig_num))/4)))*100)
res <- mutate(res, true=(score>=99))
res <- res %>% replace_na(list(true=FALSE))

novel <- read_tsv("res_novel.tsv", col_names=c("dataset","assembler","ir_len","ctg_len","num_ctg"))

my_res <- left_join(select(res, dataset, assembler, score, true), novel)

eval_params <- function(ir, total, data=my_res){
	my_tab <- data %>% mutate(pred=(ir_len>=ir & ctg_len>=total)) %>% select(true,pred) %>% table
	sens <- my_tab["TRUE","TRUE"]/(my_tab["TRUE","TRUE"]+my_tab["TRUE","FALSE"])
	prec <- my_tab["TRUE","TRUE"]/(my_tab["TRUE","TRUE"]+my_tab["FALSE","TRUE"])
	f1 <- 2*(sens*prec)/(sens+prec)
	return(tibble(ir,total,prec,sens,f1))
}

crossing(ir=seq(0,25000,1000),total=seq(10000,150000,10000)) %>% rowwise %>% do(eval_params(.$ir,.$total)) %>% gather(measure,value,3:5) %>% filter(measure == "f1") %>% arrange(-value) %>% head(1) %>% print

pdf("novel_cutoffs.pdf")
crossing(ir=seq(0,25000,1000),total=seq(10000,150000,10000)) %>% rowwise %>% do(eval_params(.$ir,.$total)) %>% gather(measure,value,3:5) %>% ggplot(aes(total,ir,fill=value)) + geom_tile() + facet_grid(. ~ measure) + ggtitle("F1, sensitivity, and precision by total and ir length cutoffs")
crossing(ir=seq(0,25000,1000),total=seq(10000,150000,10000)) %>% rowwise %>% do(eval_params(.$ir,.$total)) %>% gather(measure,value,3:5) %>% ggplot(aes(total,color=as.factor(ir),y=value)) + geom_line() + facet_grid(. ~ measure) + ggtitle("F1, sensitivity, and precision by ir length cutoffs (and total)")
crossing(ir=seq(0,25000,1000),total=seq(10000,150000,10000)) %>% rowwise %>% do(eval_params(.$ir,.$total)) %>% gather(measure,value,3:5) %>% ggplot(aes(ir,color=as.factor(total),y=value)) + geom_line() + facet_grid(. ~ measure) + ggtitle("F1, sensitivity, and precision by total length cutoffs (and ir)")
dev.off()


library(tidyverse)
library(effectsize)
library(insight)
library(lme4)
library(lmerTest)
library(sjPlot)
library(rlang)

num_format <- function(num, digits = 2, leading_zero = T) {
    # Readable number formatting
    fnum <- round(num, digits) %>% format(nsmall = digits)
    if (leading_zero == F)
        fnum <- sub('0.', '.', fnum)
    return(fnum)
}

format_summary <- function(summary) {
    # For formatting final table for viewing
    formatted_summary <- summary %>%
        mutate(
            p_eta2 = num_format(partial_eta2),
            beta = num_format(Std_Coefficient),
            t = num_format(!!sym("t value")),
            df = num_format(df, 0),
            ci = paste0('[', num_format(CI_low),
                        ', ', num_format(CI_high),
                        ']'),
            p = num_format(!!sym("Pr(>|t|)"), 3, F)
        ) %>%
        select(p_eta2, beta, t, df, ci, p)
    return(formatted_summary)
}

my_lmer <- function(f, data, summarize_last_row = F, boxplot = F, save_file = F) {
    if (boxplot)
        boxplot(as.formula(f), data = data)

    # Create lme formula with random effect from model ID
    model <- lmer(as.formula(paste(f, "+ (1 | code_name)")), data)

    # Check whether interaction term exist to print appropriate plot
    ifelse(grepl("\\*", f),
           plot_model(model, type = "int") %>% print(),
           plot_model(model, type = "pred") %>% print())

    # Make summary
    model_summary <- summary(model)

    # Extract results
    pars <- model_summary$coefficients
    spars <- standardize_parameters(model, method = "basic")

    # Create low level summary table
    low_level_summary <- cbind(pars, spars)

    ## Extract partial eta-square from anova
    model_anova <- anova(model)
    eta2s <- F_to_eta2(model_anova$`F value`,
                       model_anova$NumDF,
                       model_anova$DenDF)
    low_level_summary["partial_eta2"] <- c(NA, eta2s$Eta2_partial)

    ## Export model level label and warnings
    low_level_summary["data_name"] <- deparse(substitute(data))
    low_level_summary["model"] <- f

    if (summarize_last_row) low_level_summary <- low_level_summary[nrow(pars),]

    fsum <- format_summary(low_level_summary)
    print(fsum)

    if (save_file != F){
        write.csv(fsum, save_file)
    }

    list(model = model,
         summary = low_level_summary,
         formatted_summary = fsum)
}


\name{unzoom-HilbertCurve-method}
\alias{unzoom,HilbertCurve-method}
\alias{unzoom}
\title{
Transform zoomed positions to their original values
}
\description{
Transform zoomed positions to their original values
}
\usage{
\S4method{unzoom}{HilbertCurve}(object, x)
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{x}{positions.}

}
\details{
This is a reverse function of \code{\link{zoom,HilbertCurve-method}}.

The function is used internally.
}
\value{
A numeric vector of original positions.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
hc = HilbertCurve(1, 2)
z = zoom(hc, 1.5)
unzoom(hc, z)
}


#@reemuru
#Data Mining
#apriori

#set the working directory
setwd("./apriori/")

#load CreditApproval.csv file with headers in the first row
wage<- read.csv(file = "wages.csv", header = TRUE, sep = ",")

#install arules and arulesviz if needed
#install.packages("arules")
#install.packages("arulesViz")

#initialize libraries
library("arules")
library("arulesViz")

#view summary statistics
summary(wage)

#identify numeric columns by viewing the structure
str(wage)

#discretize columns as required
wage$education<-discretize(wage$education, breaks=2)
wage$experience<-discretize(wage$experience, breaks=6)
wage$wage<-discretize(wage$wage, breaks=c(-Inf, 7, Inf))
wage$age<-discretize(wage$age, breaks=6)
#factor columns with six or less possible outcomes
wage$sex<-factor(wage$sex)
wage$union<-factor(wage$union)
wage$race<-factor(wage$race)
wage$occupation<-factor(wage$occupation)
wage$sector<-factor(wage$sector)
wage$marital_status<-factor(wage$marital_status)

#verify discretization
str(wage)

#run the Apriori method wih default arguments
rules<-apriori(wage)

#inspect first 10 rules for default arguments
inspect(rules[1:10])

#generate rules for specified itemsets where wage below or above mean
rules<-apriori(wage, parameter= list(supp=0.2, conf=0.8, minlen=2), appearance=list(rhs=c("age=[18,25)"), default="lhs"))

#inspect rules for above and below mean wage
inspect(rules)

#prune rules to eliminate redundancy
rules.sorted <- sort(rules, by="lift")
inspect(rules.sorted)
subset.matrix <- is.subset(rules.sorted, rules.sorted)
subset.matrix[lower.tri(subset.matrix, diag=T)] <- F
redundant <- colSums(subset.matrix, na.rm=T) >= 1
which(redundant)
#remove redundant rules and inspect
rules.pruned <- rules.sorted[!redundant]
inspect(rules.pruned)

#plot rules with graph plot
plot(rules.pruned, method="graph", control=list(type="items", max=10))


#!/usr/bin/env Rscript

# Command line argument processing
args <- commandArgs(trailingOnly=TRUE)

if (!require("stringr")){
    install.packages("stringr", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("stringr")
}

if (!require("dplyr")){
    install.packages("dplyr", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("dplyr")
}

inputfile <- args[1]
raw_countdata = read.table(inputfile, sep="\t", comment.char = "", header=T, check.names=FALSE, stringsAsFactors=F)

# create gene length data
gene_length = data.frame(Geneid=raw_countdata$Geneid, Length=raw_countdata$Length, stringsAsFactors=F)

### function ###

trim_tpmmatrix <- function(data, ERCC=F){

  if (ERCC) {
    data = data[grepl("ERCC", rownames(data)),]
  } else {
    data = data[!grepl("ERCC", rownames(data)),]
  }

  return(data)
}

calc_tpm <- function(counts,len) {
  x <- counts/len
  return(t(t(x)*1e6/colSums(x)))
}

count_tpm = raw_countdata
count_tpm$Geneid = rownames(count_tpm)
#count_tpm = dplyr::left_join(count_tpm, gene_length, by=c("Geneid"))
rownames(count_tpm) = count_tpm$Geneid

# calc TPM
count_tpm = calc_tpm(count_tpm[,!colnames(count_tpm) %in% c("Geneid","Length","gene_name"), drop=FALSE], as.numeric(count_tpm$Length))
count_tpm = as.data.frame(count_tpm)
rownames(count_tpm) = raw_countdata$Geneid

# create all-genes counts
count_tpm_gene = trim_tpmmatrix(count_tpm)
write.table(count_tpm_gene,"merged_featureCounts_gene_TPM.txt",sep="\t", append=F, quote=F, row.names=T, col.names=T)

# create ERCC counts
count_tpm_ercc = trim_tpmmatrix(count_tpm, ERCC=T)

if (nrow(count_tpm_ercc) > 1 && sum(colSums(count_tpm_ercc)) > 0){

  count_tpm_ercc_log = log10(count_tpm_ercc+1)
  write.table(count_tpm_ercc_log,"merged_featureCounts_gene_TPM_ERCC_log.txt",sep="\t", append=F, quote=F, row.names=T, col.names=T)

  raw_countdata_ercc = subset(raw_countdata, grepl("ERCC", Geneid))
  rownames(raw_countdata_ercc) = raw_countdata_ercc$Geneid
  raw_countdata_ercc = raw_countdata_ercc[,!colnames(raw_countdata_ercc) %in% c("Geneid","Length","gene_name"), drop=FALSE]
  write.table(raw_countdata_ercc,"merged_featureCounts_gene_ERCC.txt",sep="\t", append=F, quote=F, row.names=T, col.names=T)
}

# Printing sessioninfo to standard out
print("Calc TPM counts info:")
sessionInfo()


library(raster)
slopedeg<-raster("C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\slopedeg.tif")
bio_4<-raster("C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\bio_4_wgs84.tif")
bio_12<-raster("C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\bio_12_wgs84.tif")
bio_7<-raster("C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\bio_7_wgs84.tif")

#putting bio_4 on a 0 to 1 range
temp<-as.matrix(log(bio_4))
b4<-(log(bio_4)-min(temp))/max(temp-min(temp))

#putting bio_7 on a 0 to 1 range
temp<-as.matrix(2^bio_7)
b7<-(2^bio_7-min(temp))/max(temp-min(temp))

#putting slopedeg on a 0 to 1 range
temp<-as.matrix(slopedeg)
sld<-(slopedeg-min(temp))/max(temp-min(temp))

#making bio_12 discrete
temp<-as.matrix(bio_12)
qan<-quantile(temp,probs=c(.25,.5,.75))
b12<-.25+.25*(bio_12>=qan[1])+.25*(bio_12>qan[2])+.25*(bio_12>qan[3])
writeRaster(b12, filename="C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\Cat12_wgs84.tif")

#for binomal data
myFct<-.5*b4*b7+.25*sld+.25*b12+.18
m<-as.matrix(myFct)
xcoord<-sample(dim(m)[1],size=200)
ycoord<-sample(dim(m)[2],size=200)
cells<-cbind(xcoord,ycoord)
cellNumbs<-cellFromRowCol(myFct,xcoord,ycoord)

writeRaster(myFct, filename="C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\BinomialSurface.tif")

value<-extract(myFct,cellNumbs)
responseBinary<-rbinom(length(value),1,value)
xy = xyFromCell(myFct, cellNumbs)

Binom.out<-as.data.frame(cbind(xy,responseBinary))
write.table(Binom.out,file="C:\\VisTrails\\mtalbert_20110504T132851\\FieldDatBinom.csv",row.names=FALSE,col.names=TRUE,sep=",",quote=FALSE)

#now for Poisson data generate a lambda surface we want a lot of zeros

PoisFct<-myFct*4
m<-as.matrix(PoisFct)
xcoord<-sample(dim(m)[1],size=200)
ycoord<-sample(dim(m)[2],size=200)
cells<-cbind(xcoord,ycoord)
cellNumbs<-cellFromRowCol(PoisFct,xcoord,ycoord)

value<-extract(PoisFct,cellNumbs)
responseCount<-rpois(length(value),value)
xy = xyFromCell(myFct, cellNumbs)

par(mfrow=c(2,2))
plot(as.vector(as.matrix(b4)),as.vector(as.matrix(PoisFct)))
plot(as.vector(as.matrix(b7)),as.vector(as.matrix(PoisFct)))
plot(as.vector(as.matrix(sld)),as.vector(as.matrix(PoisFct)))
plot(as.vector(as.matrix(b12)),as.vector(as.matrix(PoisFct)))

writeRaster(PoisFct, filename="C:\\VisTrails\\mtalbert_20110504T132851\\PARC_1\\PoissonSurface.tif")

Pois.out<-as.data.frame(cbind(xy,responseCount))
write.table(Pois.out,file="C:\\VisTrails\\mtalbert_20110504T132851\\FieldDatPois.csv",row.names=FALSE,col.names=TRUE,sep=",",quote=FALSE)

BRT.Out<-raster("C:\\VisTrails\\prob_map.tif")
BRT.Bin<-raster("C:\\VisTrails\\prob_map.tif")
resids<-BRT.Out-PoisFct

par(mfrow=c(2,2))
plot(resids)
plot(PoisFct)
plot(BRT.Out)

par(mfrow=c(2,1))
hist(as.matrix(PoisFct),breaks=40)
hist(as.matrix(BRT.Out),breaks=40)


suppressMessages(library(ez))
suppressMessages(library(ggplot2))
suppressMessages(library(multcomp))
suppressMessages(library(nlme))
suppressMessages(library(pastecs))
suppressMessages(library(pgirmess))
suppressMessages(library(reshape))
suppressMessages(library(WRS))
suppressMessages(library(e1071))
suppressMessages(library(afex))
suppressMessages(library(emmeans))
suppressMessages(library(rcompanion))
suppressMessages(library(psych))
suppressMessages(library(tidyverse))

#myData <- read.csv(file="input/dataThreeCategories.csv", header=TRUE, sep=",")
#myData <- read.csv(file="output/meltedDataThreeCategories.csv", header=TRUE, sep=",")
myData <- read.csv(file="input/messageAcrossData.csv", header=TRUE, sep=",")
#myData$preferredVersion <- unclass(myData$preferredVersion)

personalityVariables <- c("Internal", "PowerfulOthers", "Chance")

invisible(lapply(personalityVariables, function(x) {
	print(x)
    corr <- cor.test(x=eval(substitute(myData$personality, list(personality = as.name(x)))), y=myData$meanWhatFocus, method = 'spearman', exact=FALSE)
    print(corr)
  }))

print(quantile(myData$Internal, c(.25, .75)))
print(quantile(myData$PowerfulOthers, c(.25, .75)))
print(quantile(myData$Chance, c(.25, .75)))


#' Shiny app UI function
#'
#' UI function to define the sliders and output plots for the single
#' deterministic model page of the application
#'
#' @param input provided by shiny
#'
#' @import shiny
#'
#' @export

det_modUI <- function(id) {
  ns <- NS(id)
  tagList(
    fluidRow(
      column(width = 4, h4("Parameters"),
            tabsetPanel(
              tabPanel("Disease",
                       sliderInput(ns("beta"), "transmission coefficient",
                                   value = 0.27, min = 0, max = 0.7, step = 0.01),
                       sliderInput(ns("n.e.cats"), "Exposed subcategories",
                                   value = 6, min = 3, max = 10, step = 1),
                       sliderInput(ns("n.i.cats"), "Infectious subcategories",
                                   value = 4, min = 3, max = 10, step = 1),
                       sliderInput(ns("e.move"), "Exposed progression",
                                   value = .99, min = .1, max = .99, step = .01),
                       sliderInput(ns("i.move"), "Infectious progression",
                                   value = .8, min = .1, max = .99, step = .01),
                      includeText("disease_text.txt")
                      ),
              tabPanel("Severity",
                      sliderInput(ns("s.lo"), "% severe cases in sub-adults",
                          value = 0.001, min = 0.0001, max = .02, step = 0.001),
                      sliderInput(ns("s.hi"), "% severe cases in the elderly",
                                  value = .2, min = 0.05, max = 0.4, step = 0.01),
                      sliderInput(ns("d.no"), "Daily mortality of non-hospitalized severe cases",
                                  value = 0.03, min = 0.01, max = .1, step = 0.01),
                      sliderInput(ns("d.yes"), "Daily mortality of hospitalized severe cases",
                                  value = 0.01, min = 0, max = .05, step = 0.01),
                      sliderInput(ns("beds"),"Number of beds for severe cases",
                                  value = 30, min = 10, max = 1000, step = 10),
                      includeText("severity_text.txt")
              ),
              tabPanel("Contacts",
                       sliderInput(ns("k.k.c"), "kid to kid contacts",
                                   value = 3, min = 1, max = 5, step = 0.1),
                       sliderInput(ns("a.a.c"), "adult to adult contacts",
                                   value = 1.5, min = 1, max = 5, step = 0.1),
                       sliderInput(ns("eld.c"), ">70y contacts",
                                   value = .5, min = .1, max = 1, step = 0.1),
                       sliderInput(ns("k.a.c"), "kid to adult contacts",
                                   value = 2, min = 1, max = 5, step = 0.1),
                       sliderInput(ns("red.c"), "Contact reduction overall",
                                   value = 0, min = 0, max = 1, step = 0.1),
                       includeText("contact_text.txt")
              ),
              tabPanel("Simulation",
                       sliderInput(ns("n0"),"Initial population size",
                                   value = 100000, min = 1000, max = 500000,step = 1000),
                       sliderInput(ns("n.days"),"# of days",
                                   value = 360, min = 30, max = 1000, step = 10),
                       sliderInput(ns("ini.prev"), "Initial prevalence",
                                   value = 0.001, min = 0.001, max = 0.05, step = 0.001),
                       includeText("simulation_text.txt")

                   )
            )),
     column(width = 8, h4("Plots"),
            tabsetPanel(
              tabPanel("Totals", plotOutput(ns('TotalPlot')), hr(),
                       includeText("totals_text.txt"), hr()),

              tabPanel("Infectious Cases", plotOutput(ns('CasesPlot')), hr(),
                       includeText("cases_text.txt"), hr()),

              tabPanel("Needed hospitalizations", plotOutput(ns('HospitalPlot'))),

              tabPanel("Deaths", plotOutput(ns('DeathsPlot'))),

              tabPanel("Emergent Parameters", plotOutput(ns('ParamPlot')), hr(),
                       includeText("emergent_text.txt"), hr()),

              tabPanel("Contacts", plotOutput(ns('ContactPlot')), hr(),
                       includeText("contacts_plot_text.txt"), hr()),

              tabPanel("Age Distribution", plotOutput(ns('AgePlot')), hr(),
                       includeText("age_text.txt"), hr())

              ),
            includeMarkdown("disclaimer.md")
          )
      )
)}


=begin

= ToDo

* Factorization of multi-variate polynomials over algebraic field
* Factorization over polynomial ring over Euclidian ring
* Geometry
=end


# Clase 2022-03-22

#
# --- LEER FICHEROS --------------------------------------------------------------
#

datos <- read.table(file = "datos.txt", header = T, as.is = c(1))
datos
lapply(datos, class)
str(datos)
datos <- read.table(file = "datos_comas.csv", header = T, sep = ",")
datos <- read.csv(file = "datos_comas.csv", header = T)
# read.csv2() para csv separado por ";"
datos
datos <- scan(
    file = "datos.txt",
    skip = 1,
    what = list(
        DNI = "", edad = 0, sexo = "",
        estudios = "", salario = 0
    )
)
str(datos)
lapply(datos, class)
as.data.frame(datos)
lapply(as.data.frame(datos), class)

# Leer de terminal
datos2 <- scan()

rm(list = ls())
data(cars)
data(package = "boot")
data(coal, package = "boot")
data(package = "datasets")
data()
ls()
ls("package:datasets")

# --------------------------------------------------------------------------------
# Attach, detach

mean(datos$Salario)
attach(datos)
search()
mean(Salario)
detach(datos)
search()

# --------------------------------------------------------------------------------
# Escribir a ficheros

write.table(cars[1:10, ], file = "outputfiles/datos1.txt")
datos1 <- read.table("datos1.txt", header = TRUE)

write(runif(10), file = "outputfiles/datos2.txt", ncolumns = 1)
write(t(as.matrix(datos1)), file = "outputfiles/datos3.txt", ncolumns = 2)

write(cars[1:10, ], file = "outputfiles/datos3.txt")
help("write")

#
# --- FUNCIONES ------------------------------------------------------------------
#

f.suma <- function(x, y) x + y
f.suma
f.suma(1:10, 2)
f.suma(diag(3), 1:3)

f.suma <- function(x = 0, y = 0) x + y

f2 <- function(x, y) {
    x^2
    return(list(suma = x + y, resta = x - y))
    y^2
}
f2(5, 2)

media1 <- function(x) {
    if (!is.vector(x)) {
        stop("x no es un vector")
    }
    if (!is.numeric(x)) {
        stop("x no es un vector numérico")
    }
    num_na <- sum(is.na(x))
    media <- sum(x, na.rm = T) / (length(x) - num_na)

    c(media, num_na)
}
# Test
media1(c())
media1(c(NA))
media1(c(NA, 1, 3))
media1(list("o", 1, 3))

media2 <- function(x, n = 1) {
    if (length(x) != length(n)) {
        message("Los argumentos no tienen la misma longitud. Se aplicará reciclaje")
    }
    n <- rep(n, length.out = length(x))

    if (!(is.vector(n) && is.numeric(n))) {
        stop("El argumento n no es un vector numérico")
    }
    if (!(is.vector(x) && is.numeric(x))) {
        stop("El argumento x no es un vector numérico")
    }
    if (any(n < 0)) {
        warning("El argumento n tiene valores negativos")
    }

    tam_muestra <- sum(n)
    media <- drop(x %*% n) / tam_muestra

    list(media = media, tam_muestra = tam_muestra)
}
#--------------------------------------------------------------------------------
# Test
media2(list(0, 3), c(1, 2))             # not a vector
media2(unlist(list(0, 3)), c(1, 2))     # a vector
media2(c(0, 3), list(1, 1.777))

media2(c(0, 3), c(1, 1.777))
media2(c(0, 1, 5), c(3, 1))
media2(c(1, 2), c(-11, 1))

# sum(n) = 0 lleva a valores +- inf o NaN
media2(c(1, 0), c(-1, 1))
media2(c(0, 1), c(-1, 1))

media2(c(1, 1), c(-1, 1))
media2(c(-1, -1), c(-1, 1))

media2(c(3), c(2))
media2(c(), c())

x <- runif(20)
n <- sample(1:20)
all.equal(media2(x, n)$media, weighted.mean(x, n))


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library("viridis")
# set dataset

#dataset <- "SinghalOG"
dataset <- "Streicher"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Colors
# https://www.w3schools.com/colors/colors_picker.asp
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "yellow4" # 8b8b00

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Get total number of loci
loci <- length(mLGL$Locus)

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10 - not including average calcs
#names(mLBF[7:10])
#mLBF[7:10] <- mLBF[7:10]/2
# for singhal OG
names(mLBF[4])
mLBF[4] <- mLBF[4]/2

# Want to stack datasets so GL and BF columns have both comparisons for each hypothesis.

reformatdf <- function(df,h,h1,s1,keepCols){
  # keepCols is a vector of the locus and support type column indices
  # Grab column number
  c1 <- match(h1,names(df))
  # Grab and rename column, add hypothesis column
  a.df <- df[,append(keepCols,c1)]
  names(a.df)[names(a.df) == h1] <- h
  a.df$Hypothesis <- rep(h1,length(a.df[,1]))
  c <- match(h,names(a.df))
  # Adjust direction of support if needed. ie if column is AIvSA, but you want to know SAvAI
  a.df[,c] <- a.df[,c]*(s1)
  return(a.df)
}

# reformat
AI.g <- bind_rows(reformatdf(mLGL,"AI","AIvSA",1,c(1,13)),
                  reformatdf(mLGL,"AI","AIvSI",1,c(1,13)))

SA.g <- bind_rows(reformatdf(mLGL,"SA","AIvSA",-1,c(1,13)),
                  reformatdf(mLGL,"SA","SAvSI",1,c(1,13)))

SI.g <- bind_rows(reformatdf(mLGL,"SI","AIvSI",-1,c(1,13)),
                  reformatdf(mLGL,"SI","SAvSI",-1,c(1,13)))

AI.b <- bind_rows(reformatdf(mLBF,"AI","AIvSA",1,c(1,13)),
                  reformatdf(mLBF,"AI","AIvSI",1,c(1,13)))

SA.b <- bind_rows(reformatdf(mLBF,"SA","AIvSA",-1,c(1,13)),
                  reformatdf(mLBF,"SA","SAvSI",1,c(1,13)))

SI.b <- bind_rows(reformatdf(mLBF,"SI","AIvSI",-1,c(1,13)),
                  reformatdf(mLBF,"SI","SAvSI",-1,c(1,13)))

TS.g <- reformatdf(mLGL,"TS","TvS",1,c(1,13)) %>% select(-SIvAvg)
TS.b <- reformatdf(mLBF,"TS","TvS",1,c(1,13)) %>% select(-SIvAvg)

# Singhal OG
#TS.g <- reformatdf(mLGL,"TS","TvS",1,c(1,3))
#TS.b <- reformatdf(mLBF,"TS","TvS",1,c(1,3))

# MERGE

AI.a <- left_join(AI.g, AI.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))
SA.a <- left_join(SA.g, SA.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))
SI.a <- left_join(SI.g, SI.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))
TS.a <- left_join(TS.g, TS.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))

rm(AI.g,AI.b,SA.b,SA.g,SI.b,SI.g,TS.b,TS.g)

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_TvSLoci.xlsx",sep='')

#write.xlsx2(as.data.frame(TS.a), file=fname, sheetName="loci", row.names=FALSE)

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

# Quantiles ---------------------------------------------- Scatter Quantiles  --------------------------------------------------------------------------------------------------------

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

# Calcs------------------------------------------------------------------------------------------------------------------------------------------------------

# Adding two rows that give the difference in percentiles and rank between bf and gl
# This will give the same rank number if the value is identicle in two cells -
# hint - decile scatter is pointless, deleted from script
# Rank difference needs to be calulated differently because the total rank spots for df and gl are different
# Normalizing rank by calculating max rank by hypothesis - rank.g/max(rank.g) - using these fractions to compare bf and gl
# Now rank difference is the percent difference? lets just call it normalized difference

AI.p <- AI.a %>%
  group_by(Hypothesis) %>%
  mutate(per.g = ntile(desc(AI.g),100)) %>%
  mutate(rank.g = dense_rank(desc(AI.g))) %>%
  mutate(per.b = ntile(desc(AI.b),100)) %>%
  mutate(rank.b =dense_rank(desc(AI.b))) %>%
  mutate(per.diff = abs(per.g-per.b)) %>%
  mutate(rank.diff = abs((rank.g/max(rank.g))-(rank.b/max(rank.b)))*100)

SA.p <- SA.a %>%
  group_by(Hypothesis) %>%
  mutate(per.g = ntile(desc(SA.g),100)) %>%
  mutate(rank.g =dense_rank(desc(SA.g))) %>%
  mutate(per.b = ntile(desc(SA.b),100)) %>%
  mutate(rank.b =dense_rank(desc(SA.b)))   %>%
  mutate(per.diff = abs(per.g-per.b)) %>%
  mutate(rank.diff = abs((rank.g/max(rank.g))-(rank.b/max(rank.b)))*100)

SI.p <- SI.a %>%
  group_by(Hypothesis) %>%
  mutate(per.g = ntile(desc(SI.g),100)) %>%
  mutate(rank.g = dense_rank(desc(SI.g))) %>%
  mutate(per.b = ntile(desc(SI.b),100)) %>%
  mutate(rank.b = dense_rank(desc(SI.b)))   %>%
  mutate(per.diff = abs(per.g-per.b))  %>%
  mutate(rank.diff = abs((rank.g/max(rank.g))-(rank.b/max(rank.b)))*100)

TS.p <- TS.a %>%
  group_by(Hypothesis) %>%
  mutate(per.g = ntile(desc(TS.g),100)) %>%
  mutate(rank.g =dense_rank(desc(TS.g))) %>%
  mutate(per.b = ntile(desc(TS.b),100)) %>%
  mutate(rank.b =dense_rank(desc(TS.b)))  %>%
  mutate(per.diff = abs(per.g-per.b)) %>%
  mutate(rank.diff = abs((rank.g/max(rank.g))-(rank.b/max(rank.b)))*100)

# Graph Function ------------------------------------------------------------------------------------------------------------------------------------------------------

SC <- function(df,x.tic,y.tic,legtit,l){
  # defining columns here to avoid repeating this over and over
  xcol <- match(paste(l,".g",sep = ''),names(df))
  ycol <- match(paste(l,".b",sep = ''),names(df))
  CC <- match(paste(l,".diff",sep = ''),names(df))

  scat <- ggplot(df, aes(x=df[[xcol]],y=df[[ycol]])) +
    geom_point(alpha=1, aes(color=df[[CC]]), size=1) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=6, color="black"),
      text = element_text(size=10),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5)
    ) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x=paste('dGLS ',l, sep=''),y=paste('ln(BF) ',l,sep=''),color=legtit) +
    guides(colour = guide_legend(override.aes = list(size=2))) +
    scale_color_viridis(limits=c(0,100),direction = -1,option='D')
  #scale_color_gradientn(colors=heat.colors(2),limits=c(0,100))
  #scale_color_gradient2(low="blue", high="red",midpoint=mid)

  return(scat)
}

# All Rank #------------------------------------------------------------------------------------------------------------------------------------------------------

# BF vs dGLS colored by normalized difference in rank between dGLS and BF
# Each comparison has a graph. AIvSA, AIvSI, SAvSI, TvS

# Get scale for x and y axes
df1 <- AI.p[AI.p$Hypothesis=='AIvSA',]
df2 <- AI.p[AI.p$Hypothesis=='AIvSI',]
df3 <- SA.p[SA.p$Hypothesis=='SAvSI',]
df4 <- TS.p

max(c(df2$rank.b,df2$rank.g))
max(c(df3$rank.b,df3$rank.g))
max(c(df4$rank.b,df4$rank.g))

# Tic marks
t.rx <- seq(0,3000,500)
t.ry <- seq(0,3000,500)
ts.rx <- seq(0,5000,500)
ts.ry <- seq(0,5000,500)

#values,tick marks,column for values to color, legend title, rank/decile for axis labels
p1.a <- SC(df1,t.rx,t.ry,"normalized \n difference \n in rank","rank") + ggtitle(df1$Hypothesis)
p2.a <- SC(df2,t.rx,t.ry,"normalized \n difference \n  in rank","rank") + ggtitle(df2$Hypothesis)
p3.a <- SC(df3,t.rx,t.ry,"normalized \n difference \n in rank","rank") + ggtitle(df3$Hypothesis)
p4.a <- SC(df4,ts.rx,ts.ry,"normalized \n difference \n in rank","rank") + ggtitle(df4$Hypothesis)

p.a <- ggarrange(p1.a, p2.a, p3.a, p4.a, ncol=2, nrow=2, align="h")
#quartz()
p.a

#ggsave(paste(dataset,"_scatter_rank_diff.pdf",sep=""), plot=p.a,width = 9, height = 6, units = "in", device = 'pdf',bg = "transparent")
#ggsave(paste(dataset,"_scatter_rank_diff.pdf",sep=""), plot=p4.a,width = 9, height = 6, units = "in", device = 'pdf',bg = "transparent")

# All Percentiles #------------------------------------------------------------------------------------------------------------------------------------------------------

# BF vs dGLS colored by normalized difference in rank between dGLS and BF
# Each comparison has a graph. AIvSA, AIvSI, SAvSI, TvS

# Tic marks
t.rx <- seq(0,100,20)
t.ry <- seq(0,100,20)
ts.rx <- seq(0,100,20)
ts.ry <- seq(0,100,20)

#values,tick marks,column for values to color, legend title, per/decile for axis labels
r1.a <- SC(df1,t.rx,t.ry,"difference in \n percentile","per") + ggtitle(df1$Hypothesis)
r2.a <- SC(df2,t.rx,t.ry,"difference in \n percentile","per") + ggtitle(df2$Hypothesis)
r3.a <- SC(df3,t.rx,t.ry,"difference in \n percentile","per") + ggtitle(df3$Hypothesis)
r4.a <- SC(df4,ts.rx,ts.ry,"difference in \n percentile","per") + ggtitle(df4$Hypothesis)

r.a <- ggarrange(r1.a, r2.a, r3.a, r4.a, ncol=2, nrow=2, align="h")
#quartz()
r.a

#ggsave(paste(dataset,"_scatter_percentile_diff.pdf",sep=""), plot=r.a,width = 9, height = 6, units = "in", device = 'pdf',bg = "transparent")
#ggsave(paste(dataset,"_scatter_percentile_diff.pdf",sep=""), plot=r4.a,width = 9, height = 6, units = "in", device = 'pdf',bg = "transparent")

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

# Compare hypotheses ------------------------------------ Loci across hypotheses --------------------------------------------------------------------------------------------------------

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

# Compare hypotheses to see if same loci give same support across hypotheses. ie, if it supports AI in AIvSI will it support it in AIvSA

# Graph Function------------------------------------------------------------------------------------------------------------------------------------------------------

SL <- function(df,x.val,y.val,x.tic,y.tic,cc,x.y){
  scat <- ggplot(df, aes(x=x.val,y=y.val)) +
    geom_point(alpha=1, aes(color=as.factor(df[[x.y[3]]])), size=0.5) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=10, color="black"),
      text = element_text(size=12),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5),
      legend.position = 'none'
    ) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x=x.y[1],y=x.y[2]) +
    scale_color_manual(values=cc)
  return(scat)
}

# dGLS-------------------------------------------------------- Loci across hypotheses ----------------------------------------------------------------------------------------------

# Set up hypotheses with correct directionality and add codes for one/both/neither with support for hypoth

GL <- mLGL %>%
  select(Locus,TvS,AIvSA,AIvSI,SAvSI) %>%
  mutate(SAvAI=AIvSA*-1) %>%
  mutate(SIvAI=AIvSI*-1) %>%
  mutate(SIvSA=SAvSI*-1) %>%
  mutate(AI = case_when(AIvSI < 0.5 &  AIvSA < 0.5 ~ 0,
                        AIvSI >= 0.5 & AIvSA >= 0.5 ~ 2,
                        AIvSI >= 0.5 & AIvSA < 0.5 ~ 1,
                        AIvSI < 0.5 & AIvSA >= 0.5 ~ 1)) %>%
  mutate(SA = case_when(SAvSI < 0.5 &  SAvAI < 0.5 ~ 0,
                        SAvSI >= 0.5 & SAvAI >= 0.5 ~ 2,
                        SAvSI >= 0.5 & SAvAI < 0.5 ~ 1,
                        SAvSI < 0.5 & SAvAI >= 0.5 ~ 1)) %>%
  mutate(SI = case_when(SIvSA < 0.5 &  SIvAI < 0.5 ~ 0,
                        SIvSA >= 0.5 & SIvAI >= 0.5 ~ 2,
                        SIvSA >= 0.5 & SIvAI < 0.5 ~ 1,
                        SIvSA < 0.5 & SIvAI >= 0.5 ~ 1))

# Graph

df <- GL
max(c(abs(df$AIvSA),abs(df$AIvSI),abs(df$SAvSI)))
lower <- 170 # 45
upper <- 170
x.t <- seq(-lower,upper,50) # 15
y.t <- seq(-lower,upper,50)

df <- GL
x.v1 <- GL$AIvSA
y.v1 <- GL$AIvSI
x.y1 <- c("AIvSA","AIvSI","AI")
cc1 <- c('grey56','#1e7b59','#46d29f')
quartz()
ai.g <- SL(df,x.v1,y.v1,x.t,y.t,cc1,x.y1) + geom_hline(yintercept=c(0.5),color=c("black"), linetype="dashed", size=0.25) +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.25)

x.v2 <- GL$SAvAI
y.v2 <- GL$SAvSI
x.y2 <- c("SAvAI","SAvSI","SA")
cc2 <- c('grey56','#243a5b','#4975b6')
sa.g <- SL(df,x.v2,y.v2,x.t,y.t,cc2,x.y2) + geom_hline(yintercept=c(0.5),color=c("black"), linetype="dashed", size=0.25) +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.25)

x.v3 <- GL$SIvAI
y.v3 <- GL$SIvSA
x.y3 <- c("SIvAI","SIvSA","SI")
cc3 <- c('grey56','#4d4d00','#cccc00')
si.g <- SL(df,x.v3,y.v3,x.t,y.t,cc3,x.y3) + geom_hline(yintercept=c(0.5),color=c("black"), linetype="dashed", size=0.25) +
  geom_vline(xintercept=c(0.5),color=c("black"), linetype="dashed", size=0.25)

g <- annotate_figure(ggarrange(ai.g,sa.g,si.g, ncol=1, nrow=3, align="v",labels="auto"),
                     top = text_grob("dGLS", color = "black", size = 16))
g

# BF --------------------------------------------------------- Loci across hypotheses ---------------------------------------------------------------------------------------------

# Set up hypotheses with correct directionality and add codes for one/both/neither with support for hypoth

BF <- mLBF %>%
  select(Locus,TvS,AIvSA,AIvSI,SAvSI) %>%
  mutate(SAvAI=AIvSA*-1) %>%
  mutate(SIvAI=AIvSI*-1) %>%
  mutate(SIvSA=SAvSI*-1) %>%
  mutate(AI = case_when(AIvSI < 5 &  AIvSA < 5 ~ 0,
                        AIvSI >= 5 & AIvSA >= 5 ~ 2,
                        AIvSI >= 5 & AIvSA < 5 ~ 1,
                        AIvSI < 5 & AIvSA >= 5 ~ 1)) %>%
  mutate(SA = case_when(SAvSI < 5 &  SAvAI < 5 ~ 0,
                        SAvSI >= 5 & SAvAI >= 5 ~ 2,
                        SAvSI >= 5 & SAvAI < 5 ~ 1,
                        SAvSI < 5 & SAvAI >= 5 ~ 1)) %>%
  mutate(SI = case_when(SIvSA < 5 &  SIvAI < 5 ~ 0,
                        SIvSA >= 5 & SIvAI >= 5 ~ 2,
                        SIvSA >= 5 & SIvAI < 5 ~ 1,
                        SIvSA < 5 & SIvAI >= 5 ~ 1))

# Graph

max(c(abs(BF$AIvSA),abs(BF$AIvSI),abs(BF$SAvSI)))
lower <- 90
upper <- 90
x.t <- seq(-lower,upper,20)
y.t <- seq(-lower,upper,20)

df2 <- BF
x.v4 <- BF$AIvSA
y.v4 <- BF$AIvSI
x.y4 <- c("AIvSA","AIvSI","AI")
cc4 <- c('grey56','#1e7b59','#46d29f')
#quartz()
ai.b <- SL(df2,x.v4,y.v4,x.t,y.t,cc4,x.y4) + geom_hline(yintercept=c(5),color=c("black"), linetype="dashed", size=0.25) +
  geom_vline(xintercept=c(5),color=c("black"), linetype="dashed", size=0.25)
ai.b

x.v5 <- BF$SAvAI
y.v5 <- BF$SAvSI
x.y5 <- c("SAvAI","SAvSI","SA")
cc5 <- c('grey56','#243a5b','#4975b6')
sa.b <- SL(df2,x.v5,y.v5,x.t,y.t,cc5,x.y5) + geom_hline(yintercept=c(5),color=c("black"), linetype="dashed", size=0.25) +
  geom_vline(xintercept=c(5),color=c("black"), linetype="dashed", size=0.25)

x.v6 <- BF$SIvAI
y.v6 <- BF$SIvSA
x.y6 <- c("SIvAI","SIvSA","SI")
cc6 <- c('grey56','#4d4d00','#cccc00')
si.b <- SL(df2,x.v6,y.v6,x.t,y.t,cc6,x.y6) + geom_hline(yintercept=c(5),color=c("black"), linetype="dashed", size=0.25) +
  geom_vline(xintercept=c(5),color=c("black"), linetype="dashed", size=0.25)

b <- annotate_figure(ggarrange(ai.b,sa.b,si.b, ncol=1, nrow=3, align="v",labels=c("d","e","f")),
                     top = text_grob("ln(BF)", color = "black", size = 16))
b

f <- ggarrange(g,b, ncol=2, nrow=1, align="v")
f

#ggsave(paste(dataset,"_scatter_loci_compare.pdf",sep=""), plot=f,width = 9, height = 12, units = "in", device = 'pdf',bg = "transparent")
#ggsave(paste(dataset,"_scatter_loci_comparezoom.pdf",sep=""), plot=f,width = 9, height = 12, units = "in", device = 'pdf',bg = "transparent")

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

# CSV files ------------------------------------ CSV files --------------------------------------------------------------------------------------------------------

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

# Smash data ----------------------------------------- Significant disagree CSV------------------------------------------------------------------------------------------------------------

# Look at "significance" for dGLS and BF. Record which loci conflict

# Create dataframe with all metadata, locus names, one col for hypothesis, one call for bf, and one gl
keep <- c(1,seq(14,22))

B <- bind_rows(reformatdf(mLBF,"BF","AIvSA",1,keep),
               reformatdf(mLBF,"BF","AIvSI",1,keep),
               reformatdf(mLBF,"BF","SAvSI",1,keep),
               reformatdf(mLBF,"BF","TvS",1,keep))

G <- bind_rows(reformatdf(mLGL,"GL","AIvSA",1,keep),
               reformatdf(mLGL,"GL","AIvSI",1,keep),
               reformatdf(mLGL,"GL","SAvSI",1,keep),
               reformatdf(mLGL,"GL","TvS",1,keep))
# for SinghalOG
#keep <- c(1,seq(5,13))
#B <- reformatdf(mLBF,"BF","TvS",1,keep)
#G <- reformatdf(mLGL,"GL","TvS",1,keep)

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")
all <- left_join(B, G, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))

# Classify discordance ----------------------------------------- Significant disagree CSV------------------------------------------------------------------------------------------------------------

# neu.s both neutral in same direction
# neu.o both neutral in opposite directions
# sig.s both sig in same direction
# sig.o both sig in opposite directions
# neuG.sigB.s dgls neutral, bf significant - both same direction
# neuB.sigG.s bf neutral, dgls significant - both same direction
# neuG.sigB.o dgls neutral, bf significant - in opposite directions
# neuB.sigG.o bf neutral, dgls significant - in opposite directions
# can cluster by same or opposite direction if needed.

a <- all %>% mutate(sig = case_when(between(BF,0,5) & between(GL,0,0.5) ~ 'neu.s',
                                    between(BF,-5,0) & between(GL,-0.5,0) ~ 'neu.s',
                                    between(BF,0,5) & between(GL,-0.5,0) ~ 'neu.o',
                                    between(BF,-5,0) & between(GL,0,0.5) ~ 'neu.o',
                                    BF >= 5 & GL >= 0.5 ~ 'sig.s',
                                    BF <= -5 & GL <= -0.5 ~ 'sig.s',
                                    BF <= -5 & GL >= 0.5 ~ 'sig.o',
                                    BF >= 5 & GL <= -0.5 ~ 'sig.o',
                                    BF <= -5 & between(GL,-0.5,0) ~ 'neuG.sigB.s',
                                    BF >= 5 & between(GL,0,0.5) ~ 'neuG.sigB.s',
                                    GL <= -0.5 & between(BF,-5,0) ~ 'neuB.sigG.s',
                                    GL >= 0.5 & between(BF,0,5) ~ 'neuB.sigG.s',
                                    BF <= -5 & between(GL,0,0.5) ~ 'neuG.sigB.o',
                                    BF >= 5 & between(GL,-0.5,0) ~ 'neuG.sigB.o',
                                    GL <= -0.5 & between(BF,0,5) ~ 'neuB.sigG.o',
                                    GL >= 0.5 & between(BF,-5,0) ~ 'neuB.sigG.o'))

# Classify discordance ----------------------------------------- Rank/Percentile disagree CSV------------------------------------------------------------------------------------------------------------

# calculate percentage for whole dataset
# add normalization to rank difference calculation

p <- a %>%
  group_by(Hypothesis) %>%
  mutate(per.g = ntile(desc(GL),100)) %>%
  mutate(rank.g = dense_rank(desc(GL))) %>%
  mutate(per.b = ntile(desc(BF),100)) %>%
  mutate(rank.b = dense_rank(desc(BF))) %>%
  mutate(per.diff = (per.g-per.b)) %>%
  mutate(rank.diff = ((rank.g/max(rank.g))-(rank.b/max(rank.b)))*100)

# Rank diff - g - b. positive - higher G. negative - higher B
# same - within 50% of rank/percentile
# rank.b - b is more than 50% greater than g in terms of rank
# rank.g - g is more than 50% greater than b in terms of rank
# per.b - b is more than 50 percentiles greater than g
# per.g - g is more than 50 percentiles greater than b

# Add columns for whether normalized b and g rank or percentile difference is larger than half the total ranks
p <- p %>% mutate(rank = case_when(rank.diff >= 50 ~ 'rank.g',
                                   rank.diff <= -50 ~ 'rank.b',
                                   between(rank.diff,-50,50) ~ 'same')) %>%
  mutate(per = case_when(per.diff >= 50 ~ 'per.g',
                         per.diff <= -50 ~ 'per.b',
                         between(per.diff,-50,50) ~ 'same'))

# Summarize number of loci for each type of discordance
s.sum <- bind_rows(
  p %>% group_by(sig) %>% dplyr::summarise(Hypothesis='ALL',n.loci=n()),
  p %>% group_by(sig,Hypothesis) %>% dplyr::summarise(n.loci=n()) %>%
    arrange(sig,Hypothesis)) %>%
  mutate(prop.loci= case_when(Hypothesis == "ALL" ~ round((n.loci/(loci*4))*100,digits=2),
                              Hypothesis != "ALL" ~ round((n.loci/loci)*100,digits = 2)))

r.sum <- bind_rows(
  p %>% group_by(rank) %>% summarise(Hypothesis='ALL',n.loci=n()),
  p %>% group_by(rank,Hypothesis) %>% summarise(n.loci=n()) %>%
    arrange(rank,Hypothesis)) %>%
  mutate(prop.loci= case_when(Hypothesis == "ALL" ~ round((n.loci/(loci*4))*100,digits=2),
                              Hypothesis != "ALL" ~ round((n.loci/loci)*100,digits = 2)))

p.sum <- bind_rows(
  p %>% group_by(per) %>% summarise(Hypothesis='ALL',n.loci=n()),
  p %>% group_by(per,Hypothesis) %>% summarise(n.loci=n()) %>%
    arrange(per,Hypothesis)) %>%
  mutate(prop.loci= case_when(Hypothesis == "ALL" ~ round((n.loci/(loci*4))*100,digits=2),
                              Hypothesis != "ALL" ~ round((n.loci/loci)*100,digits = 2)))

# Summarize ----------------------------------------- Disagree CSV------------------------------------------------------------------------------------------------------------

# List loci and the number of hypotheses they have issues across. ie issue for all hypotheses or only one.
y1 <- p %>%
  filter(!sig %in% c('neu.s','sig.s')) %>%
  group_by(Locus) %>%
  summarize(n.h.sig=n_distinct(Hypothesis))

y2 <- p %>%
  filter(!rank %in% c('same')) %>%
  group_by(Locus) %>%
  summarize(n.h.rank=n_distinct(Hypothesis))

y3 <- p %>%
  filter(!per %in% c('same')) %>%
  group_by(Locus) %>%
  summarize(n.h.per=n_distinct(Hypothesis))

y <- full_join(full_join(y1,y2,by='Locus'),y3,by='Locus')

# Output ----------------------------------------- Disagree CSV------------------------------------------------------------------------------------------------------------

# Want to out put list of loci - y, and summary tables - r,p,s.sum

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_disagreeingLociSummary.xlsx",sep='')

x <- full_join(p,y,by="Locus") %>% filter(rank.diff<=-10| rank.diff>=10)
x$rank.diff.abs <- abs(x$rank.diff)
x$Locus.2 <- x$Locus
options(java.parameters = "-Xmx1024m")
library(XLConnect)
write.xlsx2(as.data.frame(x), file=fname, sheetName="all", row.names=FALSE)
write.xlsx2(as.data.frame(y), file=fname, sheetName="loci", append=TRUE,row.names=FALSE)
write.xlsx2(as.data.frame(s.sum), file=fname, sheetName="sig", append=TRUE, row.names=FALSE)
write.xlsx2(as.data.frame(r.sum), file=fname, sheetName="rank", append=TRUE, row.names=FALSE)
write.xlsx2(as.data.frame(p.sum), file=fname, sheetName="per", append=TRUE, row.names=FALSE)

# old
#write.csv(z,paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_disagreeingLoci.csv",sep=''))
#write.csv(y,paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_disLociSummary.csv",sep=''))

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

# ---------------------------------------------------- Disagree Scatters --------------------------------------------------------------------------------------------------------

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

# Graph Function ------------------------------------------------------------------------------------------------------------------------------------------------------

SC <- function(df,xcol,ycol,c,x.tic,y.tic,xl,yl){
  scat <- ggplot(df, aes(x=xcol,y=ycol)) +
    geom_point(alpha=1, size=2, aes(color=c)) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=6, color="black"),
      text = element_text(size=10),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5)
    ) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x=xl,y=yl,color="abs val of x") +
    scale_color_viridis(limits=c(min(c),max(c)),direction = 1,option='D')
  #guides(colour = guide_legend(override.aes = list(size=2))) +
  #scale_color_viridis(limits=c(-100,100),direction = -1,option='D')
  #scale_color_gradientn(colors=heat.colors(2),limits=c(0,100))
  #scale_color_gradient2(low="blue", high="red",midpoint=mid)

  return(scat)
}

# Graph BF GL Scatters------------------------------------------------------------------------------------------------------------------------------------------------------

all <- p

# Rank
x <- abs(all$rank.diff)
c <- all$rank.diff
max(x)
min(x)
ts.rx <- seq(0,100,20)
xlab <- "normalized rank difference"

# Bf and GL #####

xlab <- "ln(BF)"
x <- all$BF
max(x)
min(x)
ts.rx <- seq(-100,60,20)

ylab <- "GL"
y <- all$GL
max(y)
min(y)
ts.ry <- seq(-80,30,10)
c <- abs(all$rank.diff)
r <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab) + labs(color="abs rank diff")
c <- all$rank.diff
r2 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab) + labs(color="rank diff")

z <- ggarrange(r,r2, ncol=1, nrow=2,align="v")
z

#ggsave(paste(dataset,"_rank_bfgl.pdf",sep=""), plot=z ,width = 4, height = 7, units = "in", device = 'pdf',bg = "transparent")

# Graph diff Histogram ---------------------------------------------- Histogram --------------------------------------------------------------------------------------------------------

H <- function(df,xval,cc,hbin,xlab){
  ggplot(data=df, aes(x=xval)) +
    geom_histogram(bins=hbin, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1) +
    #geom_histogram(breaks=brx, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1)+
    #geom_histogram(binwidth = max(abs(xval))*0.01, alpha=1, position="dodge",color="grey", fill=cc, size=0.1)+
    theme_classic() +
    theme(plot.title = element_text(hjust = 0.5, size=10),
          axis.text = element_text(size=6, color="black"),
          text = element_text(size=8),
          legend.title = element_text(size = 8),
          legend.text = element_text(size = 8)) +
    labs(y="Number of Loci",x=xlab)  +
    #coord_cartesian(xlim = x.tic) +
    #coord_cartesian(ylim=ytic, xlim = xtic) +
    #scale_y_continuous() +
    #scale_x_continuous(breaks = xtic) +
    # geom_vline(xintercept=lines.g,color=c("black"), linetype="dashed", size=0.5) +
    geom_vline(xintercept=c(0),color=c("black"), linetype="dashed", size=0.2)
}

#quartz()

h.bin <- 30
hy <- "TvS"
#hy <- "All"
#hy <- "AIvSA"
#all <- p[p$Hypothesis == "AIvSA",]
all <- p[p$Hypothesis == "TvS",]
#all <- p

# Set input data

x.val <- all$rank.diff
df <- all
cc <- "#2BB07FFF"
# Get max min for graph to set x axis values
max(abs(x.val))
m <- 100
x.tic <- seq(-m,m,20)

H(df,x.val,cc,h.bin,'dGLS values') +
  coord_cartesian(xlim = x.tic) +
  scale_x_continuous(breaks = x.tic)

y.tic <- seq(0,900,100)

rh <- H(df,x.val,cc,h.bin,'Difference in rank. - BF higher + GL higher') +
  coord_cartesian(xlim = x.tic, ylim=y.tic) +
  scale_x_continuous(breaks = x.tic) +
  scale_y_continuous(breaks = y.tic)
rh

x.val <- all$per.diff
df <- all
cc <- "#2BB07FFF"
# Get max min for graph to set x axis values
#max(abs(x.val))
#m <- 70
#x.tic <- seq(-m,m,10)

H(df,x.val,cc,h.bin,'dGLS values') +
  coord_cartesian(xlim = x.tic) +
  scale_x_continuous(breaks = x.tic)

#y.tic <- seq(0,40,5)

ph <- H(df,x.val,cc,h.bin,'Difference in percentile. - BF higher + GL higher') +
  coord_cartesian(xlim = x.tic, ylim=y.tic) +
  scale_x_continuous(breaks = x.tic) +
  scale_y_continuous(breaks = y.tic)
ph

title <- paste(dataset," - ",hy,sep="")

h <- annotate_figure(ggarrange(rh,ph, ncol=1, nrow=2,align="v"),
                     top = text_grob(title, color = "black", size = 16))

h

#ggsave(paste(dataset,"_rank_hist_",hy,".pdf",sep=""), plot=h ,width = 5, height = 4, units = "in", device = 'pdf',bg = "transparent")

# Graph Metadata Scatters------------------------------------------------------------------------------------------------------------------------------------------------------

#all <- p[p$Hypothesis == "AIvSA",]
all <- p[p$Hypothesis == "TvS",]
#all <- p

ylab <- "num taxa"
y <- all$GL
max(y)
min(y)
ts.ry <- seq(200,290,30)
gl <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
gl

ylab <- "alignment score"
y <- all$MEAN_COL_SCORE
ts.ry <- seq(0,1,0.1)
g1 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g1

ylab <- "num taxa"
y <- all$Sequences
max(y)
min(y)
ts.ry <- seq(200,290,30)
g2 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g2

ylab <- "alignment length"
y <- all$Columns
max(y)
min(y)
ts.ry <- seq(300,2100,300)
g3 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g3

names(all)
ylab <- "PI"
y <- all$Pars_Info
max(y)
min(y)
ts.ry <- seq(100,1500,100)
g4 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g4

names(all)
ylab <- "Singleton Sites"
y <- all$Sing_Sites
max(y)
min(y)
ts.ry <- seq(0,200,50)
g5 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g5

names(all)
ylab <- "Cons_Sites"
y <- all$Cons_Sites
max(y)
min(y)
ts.ry <- seq(0,1200,100)
g6 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g6

ylab <- "Chi2_Fail"
y <- all$Chi2_Fail
max(y)
min(y)
ts.ry <- seq(0,250,50)
g7 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g7

ylab <- "Gaps"
y <- all$Gaps_Ambig
max(y)
min(y)
ts.ry <- seq(0,6,1)
g8 <- SC(all,x,y,c,ts.rx,ts.ry,xlab,ylab)
g8

g <- ggarrange(g1,g2,g3,g4,g5,g6,g7,g8, ncol=2, nrow=4,align="v")
g

ggsave(paste(dataset,"_rank_metaData.pdf",sep=""), plot=g ,width = 6, height = 10, units = "in", device = 'pdf',bg = "transparent")

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

# Testin ------------------------------------ Testing --------------------------------------------------------------------------------------------------------

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

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

# Mean Mode Variance ------------------------------------------------------------------------------------------------------------------------------------------------------

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

bf <- all %>% group_by(Hypothesis) %>%
  summarise(Mean=mean(BF), Median=median(BF), Std=sd(BF), Mad=mad(BF), IQR=IQR(BF), Max=max(BF), Min=min(BF))

gl <- all %>% group_by(Hypothesis) %>%
  summarise(Mean=mean(GL), Median=median(GL), Std=sd(GL), Mad=mad(GL), IQR=IQR(GL), Max=max(GL), Min=min(GL))

# copy and paste into metadata excel sheet for now.

#Outliers based on IQR------------------------------------------------------------------------------------------------------------------------------------------------------

# https://stackoverflow.com/questions/12866189/calculating-the-outliers-in-r
# https://www.r-bloggers.com/combined-outlier-detection-with-dplyr-and-ruler/

data <- all$BF
lowerq = quantile(data)[2]
upperq = quantile(data)[4]
iqr = upperq - lowerq
extreme.threshold.upper = (iqr * 3) + upperq
extreme.threshold.lower = lowerq - (iqr * 3)

x <- all %>% group_by(Hypothesis) %>% mutate(bo = case_when(BF <= extreme.threshold.lower ~ TRUE,
                                                            BF >= extreme.threshold.upper ~ TRUE,
                                                            between(BF,extreme.threshold.lower,extreme.threshold.upper) ~ FALSE)) %>%
  count(bo)

y <- all %>% group_by(Hypothesis) %>% mutate(go = case_when(GL <= extreme.threshold.lower ~ TRUE,
                                                            GL >= extreme.threshold.upper ~ TRUE,
                                                            between(GL,extreme.threshold.lower,extreme.threshold.upper) ~ FALSE)) %>%
  count(go)


### R과 함께 배우는 네트워크 분석 ###

## 01. 핵심 패키지 설치

# 패키지 설치
install.packages("igraph")
install.packages("network")
install.packages("sna")
install.packages("visNetwork")
install.packages("threejs")
install.packages("ndtv")

install.packages("RColorBrewer")
install.packages("png")
install.packages("networkD3")
install.packages("animation")
install.packages("maps")
install.packages("geosphere")

library(RColorBrewer)

### 02. 색 알아보기
plot(x=1:10, y=rep(5,10), pch=19, cex=5, col="dark red")
points(x=1:10, y=rep(6, 10), pch=19, cex=5, col="#557799")
points(x=1:10, y=rep(4, 10), pch=19, cex=5, col=rgb(.25, .5, .3))

## 전체 색 - 657가지의 colors
length(colors())

## 'green'의 이름을 가진 것 알아보기
grep('green', colors(), value=T)

## rgb 컬러는 기본적으로 0-1사이의 값이다.
## 0-255 사이의 값으로 보고 싶다면 다음과 같이 할 수 있다.
rgb(10, 100, 100, maxColorValue = 255)
col1 = rgb(10, 100, 100, maxColorValue = 255)
plot(x=1:10, y=rep(5,10), pch=19, cex=5, col=col1)

### 투명도 - Transparency /ˌtranˈsperənsē/ -
### 우리는 alpha를 이용하여 투명도 설정이 가능하다.
plot(x=1:5, y=rep(5,5), pch=19, cex=10,
     col=rgb(.25, .5, .3, alpha=0.5), xlim=c(0,6))

### - Palettes -
### 때로는 대조되는 여러가지 색상이 필요하다.
### R은 우리를 위해 함수를 만들어 놓았다.

pal1 <- heat.colors(5, alpha=1)   # 반투명
pal2 <- rainbow(5, alpha=.5)      # 투명

plot(x=1:10, y=1:10, pch=19, cex=10, col=pal1)
par(new=TRUE)  # 첫번째 plot를 지우지 않고, 두번째 플롯을 더한다.
plot(x=10:1, y=1:10, pch=19, cex=10, col=pal2)

### - colorRampPalette() -
### 그래디언트를 발생시키기 위해 우리는 위의 함수를 사용한다.
### 이 함수를 이용하여 우리가 필요로 하는 수의 색을 발생시킬 수 있다.
palf <- colorRampPalette(c("gray70", "dark red"))
is(palf)
palf(10)
plot(x=10:1, y=1:10, pch=19, cex=10, col=palf(10))  # 10가지 색

### - colorRampPalette() -
### 우리는 여기에 투명도를 alpha를 이용하여 추가 가능하다.
palf <- colorRampPalette(c(rgb(1,1,1, 0.2), rgb(0.8, 0, 0, 0.7)), alpha=TRUE)
plot(x=10:1, y=1:10, pch=19, cex=10, col=palf(10))  # 10가지 색

### - ~~ ColorBrewer -----
### 우리는 준비되어 있는 색상 R palettes 가 있다.
### 이 함수는 중요한 함수 하나 있다. 'brewer.pal'
### 우리는 이를 이용하여 색의 확인이 가능하다.
### display.brewer.pal(8, "Set3")
library(RColorBrewer)

display.brewer.all()
brewer.pal.info  # 색상 정보 확인
brewer.pal.info["Blues", ]

display.brewer.pal(8, "Set3")     # Set3의 색상 보기
display.brewer.pal(8, "Spectral")
display.brewer.pal(8, "Blues")

### 03. RColorBrewer를 이용한 plot 그리기

par(mfrow=c(1,2)) # plot two figures - 1 row, 2 columns
pal3 <- brewer.pal(10, "Set3")   # Set3의 10가지 색 지정.
plot(x=10:1, y=10:1, pch=19, cex=6, col=pal3)  # 원 크기 6 지정.
plot(x=10:1, y=10:1, pch=19, cex=6, col=rev(pal3)) # backwards-색 거꾸로

dev.off() # 지정된 그래픽 구성을 없애기 위해서는 graphic device를 끈다.
detach("package:RColorBrewer")   # search() 경로로부터 이용가능한 R개체 없애기

?detach

### 04. 네트워크 데이터를 igraph로 읽기
### 데이터 다운로드 (http://bit.ly/polnet2018)
rm(list=ls())

### 작업 디렉터리 지정
setwd("D:/polnet2018")
getwd()

library(igraph)

# 데이터 읽기
nodes <- read.csv("./Data files/Dataset1-Media-Example-NODES.csv", header=T, as.is=T)
links <- read.csv("./Data files/Dataset1-Media-Example-EDGES.csv", header=T, as.is=T)

## 데이터 확인
head(nodes); head(links)
dim(nodes); dim(links)

## -- graph_from_data_frame(d=links, vertices=nodes, directed=T)
## 데이터를 igraph 객체로 변환
## graph_from_data_frame() 함수는 d와 vertices 컬럼을 갖는다.
## 소스와 대상은 node IDs를 포함한다.
## 'vertices'는 Node IDs 컬럼으로 시작해야 한다.
##

net <- graph_from_data_frame(d=links, vertices=nodes, directed=T)

class(net)
net

?E  # 그래프의 Edges
?V  # 그래프의 Vertices
E(net)
V(net)
E(net)$type    # hyperlink/mention
V(net)$media   # 미디어 회사명

E(net)[type=="mention"]
V(net)[media=="BBC"]

as_edgelist(net, names=T)   # edge의 리스트를 확인
as_adjacency_matrix(net, attr="weight")

# Or data frames describing nodes and edges:
as_data_frame(net, what="edges")
as_data_frame(net, what="vertices")
?as_data_frame

# 그래프를 그리기 위한 첫번째 시도
plot(net) # not pretty!

# Removing loops from the graph:
net <- simplify(net, remove.multiple = F, remove.loops = T)

# 화살표 크기를 줄이고, Lables 를 제거하는 것
plot(net, edge.arrow.size=.4,vertex.label=NA)

### 05. 2번째 데이터 셋 : matrix
### 데이터 읽기
nodes2 <- read.csv("./Data files/Dataset2-Media-User-Example-NODES.csv", header=T, as.is=T)
links2 <- read.csv("./Data files/Dataset2-Media-User-Example-EDGES.csv", header=T, row.names=1)

head(links2, 100)

net2 <- graph_from_incidence_matrix(links2)

table(V(net2)$type)

plot(net2,vertex.label=NA)

class(net2)
net2

### 06. igraph를 이용한 분석 및 시각화
plot(net, edge.arrow.size=.4)

### 03. RColorBrewer를 이용한 plot 그리기
### 04. 네트워크 데이터를 igraph로 읽기
### 05. 2번째 데이터 셋 : matrix
### 06. igraph를 이용한 분석 및 시각화
plot(net, edge.arrow.size=.4, edge.curved=.3)  # 곡선 커브 및 방향
plot(net, edge.arrow.size=.2, edge.curved=0,
     vertex.color="orange", vertex.frame.color="#555555",
     vertex.label=V(net)$media, vertex.label.color="black",
     vertex.label.cex=.7)

# Generate colors based on media type:
colrs <- c("gray50", "tomato", "gold")
V(net)$color <- colrs[V(net)$media.type]

# Compute node degrees (#links) and use that to set node size:
deg <- degree(net, mode="all")
V(net)$size <- deg*3
# Alternatively, we can set node size based on audience size:
V(net)$size <- V(net)$audience.size*0.7

# The labels are currently node IDs.
# Setting them to NA will render no labels:
V(net)$label.color <- "black"
V(net)$label <- NA

# Set edge width based on weight:
E(net)$width <- E(net)$weight/6

#change arrow size and edge color:
E(net)$arrow.size <- .2
E(net)$edge.color <- "gray80"

# We can even set the network layout:
graph_attr(net, "layout") <- layout_with_lgl
plot(net)

# 그래프의 edge=color을 구하기
plot(net, edge.color="orange", vertex.color="gray50")
plot(net)
legend(x=-1.1, y=-1.1, c("Newspaper","Television", "Online News"), pch=21,
       col="#777777", pt.bg=colrs, pt.cex=2.5, bty="n", ncol=1)

# Sometimes, especially with semantic networks, we may be interested in
# plotting only the labels of the nodes:

plot(net, vertex.shape="none", vertex.label=V(net)$media,
     vertex.label.font=2, vertex.label.color="gray40",
     vertex.label.cex=.7, edge.color="gray85")

# Let's color the edges of the graph based on their source node color.
# We'll get the starting node for each edge with "ends()".
edge.start <- ends(net, es=E(net), names=F)[,1]
edge.col <- V(net)$color[edge.start]

plot(net, edge.color=edge.col, edge.curved=.1)

# Let's generate a slightly larger 100-node graph using
# a preferential attachment model (Barabasi-Albert).

net.bg <- sample_pa(100, 1.2)
V(net.bg)$size <- 8
V(net.bg)$frame.color <- "white"
V(net.bg)$color <- "orange"
V(net.bg)$label <- ""
E(net.bg)$arrow.mode <- 0
plot(net.bg)

## Ref
## https://bookdown.org/rdpeng/exdata/plotting-and-color-in-r.html
## Exploratory Data Analysis with R
## RColorBrewer : http://ftp.auckland.ac.nz/software/CRAN/doc/packages/RColorBrewer.pdf


# Generated with SMOP  0.41-beta
from libsmop import *
# solver.m

@function
def solver(ai=None,af=None,w=None,*args,**kwargs):
    varargin = solver.varargin
    nargin = solver.nargin

    rand(1,2,3)

    # Copyright 2004 The MathWorks, Inc.

    nBlocks=max(ravel(ai))
# solver.m:6
    m,n=size(ai,nargout=2)
# solver.m:7
    # Make increment tables
# N=1, E=2, S=3, W=4
    I=concat([0,1,0,- 1])
# solver.m:11
    J=concat([1,0,- 1,0])
# solver.m:12
    a=copy(ai)
# solver.m:14
    mv=[]
# solver.m:15
    while logical_not(isequal(af,a)):

        # Pick a random block
        bid=ceil(dot(rand(),nBlocks))
# solver.m:19
        i,j=find(a == bid,nargout=2)
# solver.m:20
        r=ceil(dot(rand(),4))
# solver.m:23
        ni=i + I(r)
# solver.m:24
        nj=j + J(r)
# solver.m:25
        if (ni < 1) or (ni > m) or (nj < 1) or (nj > n):
            continue
        # Is it a legal move? Check for collision
        if a(ni,nj) > 0:
            continue
        # Check distance
    # Get the target location
        ti,tj=find(af == bid,nargout=2)
# solver.m:38
        d=(ti - i) ** 2 + (tj - j) ** 2
# solver.m:39
        dn=(ti - ni) ** 2 + (tj - nj) ** 2
# solver.m:40
        if (d < dn) and (rand() > 0.05):
            continue
        # Move the block
        a[ni,nj]=bid
# solver.m:47
        a[i,j]=0
# solver.m:48
        mv[end() + 1,concat([1,2])]=concat([bid,r])
# solver.m:51

    return mv

if __name__ == '__main__':
    pass

    ## function r = rand(varargin)
##     global s1 s2 s3
##     if nargin != 0
##         r=0;
##         s1=varargin{1};
##         s2=varargin{2};
##         s3=varargin{3};
##     else
##         [r,s1,s2,s3] = r8_random(s1,s2,s3);
##     end
## end


####### handling censored data

cat('\nckecking censored data: \n')
.tmpMtrs = .Mtrs
source('functions.r')
.Mtrs <- as.matrix(.Mtrs)
bb <- .Mtrs

.label <- sum(grepl('[<a-df-zA-Z]',.Mtrs))

if(.label!=0) {
cat('\ncells with non-numeric type detected:\n')
cat('1. I want to detect all non-numeric characters\n')
cat('2. I want to specify the flags for censoring data\n')
.ccen <- .scanf(1,c(1:2))
if(.ccen == 2) {
   cat('specify the flags, for example: U < \n')
   .flag <- scan("",character(0),nlines=1,quiet=T) }

.indi <- matrix(numeric(n*p),ncol=p); .ii <- 1; .qualifier <- 0
for(i in 1:n){
  for(j in 1:p){
      if(.ccen == 1) .indi[i,j] <- grepl('[<a-df-zA-Z]',.Mtrs[i,j])
      if(.ccen == 2) {
           .tmpIndi <- numeric(length(.flag))
           for(ij in 1:length(.flag))
              .tmpIndi[ij] <- grepl(.flag[ij],.Mtrs[i,j])
           .indi[i,j] = !all(.tmpIndi==0)
       }
      if(.indi[i,j]){
        .mix <- .Mtrs[i,j]
        .quaind <- as.vector(sapply(gregexpr('[<a-df-zA-Z]',.mix),function(x) x))
        for(.jj in (1:length(.quaind))){
                   .po <- .quaind[.jj]
                   .qualifier[.ii] <- substr(.mix,.po,.po); .ii <- .ii+1
                                     }
                    }
               }
           }

.uq <- unique(.qualifier); .counts <- 0
for (i in 1:length(.uq)) .counts[i] <- sum(.qualifier==.uq[i])
cat('\n',sum(.indi),'potential censoring flags over total of ',n*p,' are detected\n')
cat('\nthe flags with frequencies: ','\n')
cat(rbind(.uq,':',.counts,' '),'\n')
cat('\nthe percentage for each column with censoring data:\n')
cat("\n Please press Enter key to continue...\n")
readline()
cat("\n--------------------------------------------------------------------------\n")
.k1 <- which(colSums(.indi)!=0)
for(.k2 in 1:length(.k1)) cat(.k1[.k2],' ',.attri[.k1[.k2]],': ',
                 round(sum(.indi[,.k1[.k2]])/nrow(.indi),4)*100,'%', fill=T)
cat("\n--------------------------------------------------------------------------")

.ansDrop <- 'n'
while(.ansDrop=='n'){
cat("\nI want to drop the columns with censoring percentage higher than: (e.g 50)\n")
.ansn <- scan("",double(0),nlines=1,quiet=T)/100*nrow(.indi)
.tmpDrop <- which(colSums(.indi)>.ansn)
.tmpInd <- which(colSums(.indi)!=0 & colSums(.indi)<=.ansn);
cat("the following comluns will be dropped:\n")
cat(.tmpDrop)
cat("\nare you sure to drop them? y/n\n")
.ansDrop <- .scanf(2)
}

cat("\nfor data imputation:")
cat("\n1. I want to assign the half of the detection limit(DL)\n")
cat("2. I want to fit a normal/lognormal distribution with ML estimation\n")
cat("3. I want to fit the ECDF with Kaplan-Meier method\n")
.ans <- .scanf(1,c(1:3))

for(j in 1:p){
  for(i in 1:n){
    if(grepl('[<a-df-zA-Z]',.Mtrs[i,j])){
      .tmp <- gsub('[<a-zA-Z]',' ',.Mtrs[i,j])
      .Mtrs[i,j] <- as.numeric(.tmp)
        }
    }
}

if(.ans == 1){
for(j in .tmpInd){
  for(i in 1:n){
    if(.indi[i,j]){
      .tmp <- as.numeric(.Mtrs[i,j])
      .Mtrs[i,j] <- .tmp/2 }
    }
  }
}

if(.ans==2){
  cat('specify a number of replications for imputation:\n')
  .Time <- .scanf(1,c(1:1e5))
  .pp <- .optmn(length(.tmpInd))
  .par0()
  par(mfrow=c(.pp[1],.pp[2]), cex.main=.7,
      mar=c(5,4,4,2)+.01,mai=c(1,1,1,.5)*.1, mex=.3)
   for(j in .tmpInd){
    .tmp0 <- .tmp <- as.numeric(.Mtrs[,j])
    .tmp0[which(.indi[,j]!=0)] <- 0
    .tmpp <- shapiro.test(.tmp)$p.value; .tmpI <- as.integer(.tmpp>.1)
    if(!.tmpI) .tmpFit <- cenmle(.tmp,.indi[,j]==1)
    if(.tmpI) .tmpFit <- cenmle(.tmp,.indi[,j]==1,dist='gaussian')
    .mean <- as.numeric(mean(.tmpFit)[1])
    .sd <- sd(.tmpFit)
    for(.time in 1:.Time){
     for( i in which(.indi[,j]!=0))
       {.tmp[i] <- .rlog(.tmpI+1,.mean,.sd,i,j, as.numeric(.Mtrs[i,j]))
        .tmp0[i] <- .tmp0[i] + .tmp[i] }
     }
     for( i in which(.indi[,j]!=0)) .tmp0[i] <- .tmp0[i]/.Time
        .Mtrs[,j] <- .tmp0
   plot(.tmpFit,main=paste(j,':',.attri[j]))
   #plot.ecdf(.tmp0/.Time,col='red',add=T)
  }
  .par0()
}

if(.ans==3){
     cat('specify a number of replications for imputation:\n')
     .Time <- .scanf(1,c(1:1e5))
     .pp <- .optmn(length(.tmpInd))
     .par0()
     par(mfrow=c(.pp[1],.pp[2]), cex.main=.7,
      mar=c(5,4,4,2)+.001,mai=c(1,.5,1,.5)*.1, mex=.3)
     for(j in .tmpInd){
       .tmp0 <- .tmp <- as.numeric(.Mtrs[,j])
       .tmp0[which(.indi[,j]!=0)] <- 0
       .tmpFit <- cenfit(.tmp,.indi[,j]==1)
       .tmpCdf <- summary(.tmpFit)$prob; .tmpX <- summary(.tmpFit)$obs
       for(.time in 1:.Time){
         for( i in which(.indi[,j]!=0)){
         .tmp[i] <- .rcdf(.tmpCdf, .tmpX, i,j, as.numeric(.Mtrs[i,j]))
         .tmp0[i] <- .tmp0[i] + .tmp[i] }
           }
       for( i in which(.indi[,j]!=0)) .tmp0[i] <- .tmp0[i]/.Time
        .Mtrs[,j] <- .tmp0
       plot(.tmpFit,main=paste(j,':',.attri[j]))
       plot.ecdf(.tmp0,col='red',add=T)
     }
    .par0()
}

if(.ansDrop == 'y'&& length(.tmpDrop)!=0) {.Mtrs <- .Mtrs[,-.tmpDrop]
                 .attri <- .attri[-.tmpDrop]}

}

if(!.label) cat('no censored data was found.\n')
.read()


server <- function(input, output) {
  source("api-key.r", local = TRUE)
  # READ OUR CSV DATA
  co2_emissions_data <- read.csv("data/co2_emissions.csv",
                                 fileEncoding = "UTF-8-BOM",
                                 stringsAsFactors = FALSE)
  country_population_data <- read.csv("data/country_population.csv",
                                      stringsAsFactors = FALSE)
  country_gdp_data <- read.csv("data/country_gdp.csv",
                               encoding = "UTF-8", stringsAsFactors = FALSE)
  all_country_codes <- read.csv("data/country_codes.csv",
                                stringsAsFactors = FALSE)
  non_country_codes <- read.csv("data/non_countries.csv",
                                stringsAsFactors = FALSE) %>%
    select(Country.Code)
  # access google api
  register_google(key = google_key)
  # BOX CHART =====================
  output$high_emissions_box_chart <- renderPlot({
    if (input$dataset == 1) { # if user requests per capita emission data
      # filter the data
      filtered_data <- anti_join(co2_emissions_data, non_country_codes)
      x_year <- filtered_data[[paste("X",
                                     input$year, sep = "")]]
      enquo_year <- enquo(x_year)
      filtered_data <- filtered_data %>%
        top_n(8, !!enquo_year)
      x_year <- filtered_data[[
        paste("X", input$year, sep = "")]]
      enquo_year <- enquo(x_year)
      # create the plot using ggplot
      ggplot(filtered_data, aes(
        reorder(Country.Name,
                !!enquo_year), !!enquo_year)) +
        geom_bar(stat = "identity") +
        ggtitle("Top 8 countries in terms of CO2 Emissions") +
        xlab("Country") +
        ylab("Metric Tons of CO2 Per Capita")
    } else { # if user requests total emission data
      filtered_data <- left_join(co2_emissions_data,
                                 country_population_data,
                                 c("Country.Code" = "Country_Code"))
      filtered_data <- anti_join(filtered_data,
                                 non_country_codes)
      filtered_data$total_emission <- filtered_data[[
        paste("X", input$year, sep = "")]] *
        filtered_data[[paste("Year_",
                             input$year, sep = "")]]
      filtered_data <- filtered_data %>%
        top_n(8, total_emission)
      # create the plot using ggplot
      ggplot(filtered_data, aes(reorder(Country.Name,
                                        total_emission), total_emission)) +
        geom_bar(stat = "identity") +
        ggtitle("Top 8 countries in terms of CO2 Emissions") +
        xlab("Country") +
        ylab("Total Metric Tons of CO2")
    }
  })
  # SCATTER PLOT =========================
  output$emissions_vs_gdp_plot <- renderPlot({
    if (input$dataset == 1) { # if user requests per capita emission data
      # filter the data
      filtered_data <- left_join(co2_emissions_data,
                                 country_gdp_data,
                                 by = c("Country.Code", "Country.Code"))
      filtered_data <- anti_join(filtered_data,
                                 non_country_codes)
      x_year <- filtered_data[[paste("X",
                                     input$year, sep = "")]]
      enquo_year <- enquo(x_year)
      gdp <- filtered_data[[paste("XX",
                                  input$year, sep = "")]]
      enquo_gdp <- enquo(gdp)
      ggplot(filtered_data,
             aes(x = !!(enquo_year), y = !!(enquo_gdp))) +
        geom_point(aes(size = 25)) +
        geom_smooth(method = "lm") +
        ggtitle("Emissions vs GDP") +
        xlab("Total Metric Tons of CO2") +
        ylab("Total GDP in USD")
    } else { # if user requests total emission data
      # filter the data
      filtered_data <- left_join(co2_emissions_data,
                                 country_population_data,
                                 c("Country.Code" = "Country_Code"))
      filtered_data <- left_join(filtered_data,
                                 country_gdp_data,
                                 by = c("Country.Code",
                                        "Country.Code"))
      filtered_data <- anti_join(filtered_data, non_country_codes)
      filtered_data$total_emission <- filtered_data[[
        paste("X", input$year, sep = "")]] *
        filtered_data[[paste("Year_", input$year, sep = "")]]
      x_year <- filtered_data[[paste("X", input$year, sep = "")]]
      enquo_year <- enquo(x_year)
      gdp <- filtered_data[[paste("XX", input$year, sep = "")]]
      enquo_gdp <- enquo(gdp)
      # create the plot using ggplot
      ggplot(filtered_data, aes(
        x = total_emission, y = !!(enquo_gdp))) +
        geom_point(aes(size = 25)) +
        geom_smooth(method = "lm") +
        ggtitle("Emissions vs GDP") +
        xlab("Metric Tons of CO2 Per Capita") +
        ylab("Total GDP in USD")
    }
  })
  # MAP ================================
  updated_lat_long <- geocode(co2_emissions_data$Country.Name,
                              output = "latlona", source = "google")
  emission_map_values <- updated_lat_long %>%
    mutate(lat = updated_lat_long$lat) %>%
    mutate(long = updated_lat_long$lon) %>%
    mutate(emission = substr(co2_emissions_data$X2005, 1, 5)) %>%
    select(lat, long, address, emission) %>%
    filter(!is.na(lat)) %>%
    filter(!is.na(emission))

  map_maker <- function(df, lat, long, emission, country) {
    leaflet(data = df) %>%
      addProviderTiles("CartoDB.Positron") %>%
      clearBounds() %>%
      addTiles() %>%
      addMarkers(
        lat = lat,
        lng = long,
        popup = paste0("In ", country,
                      ", the CO2 emission level was ",
                      emission, " metric tons per Capita.")
      )
  }
  output$country_emissions_map <- renderLeaflet({
    map_maker(emission_map_values, emission_map_values$lat,
              emission_map_values$long,
              emission_map_values$emission, emission_map_values$address)
  })
  # technical report ===============
  url <- a("Technical Report", href = "https://github.com/
           ItsNoGood/Info-201-AA-Project/wiki/Technical-Report")
  output$technical_report <- renderUI({
    tagList(url)
  })
}


dat<-Read.summary.data(read.init.function=F)

dat0<-droplevels(subset(dat,ration>0 & west>0.0,select=c(Year,Species,Species.n,Quarter,Age,west,ration,BIO)))

mm<-aggregate(Age~Species,data=dat0,min)
names(mm)<-c('Species','minAge')
ma<-aggregate(Age~Species,data=dat0,max)
mm<-merge(mm,ma)
head(mm)
mm$Same<-mm$minAge==mm$Age
mm2<-subset(mm,!Same,select=c(Species))

dat1<-merge(dat0,mm2)

mac<-droplevels(subset(dat1,Species=='N. mackerel'))
mac<-droplevels(subset(dat1,Species=='N.horse mac'))
ftable(tapply(mac$ration,list(mac$Year,mac$Quarter,mac$Age),mean))
ftable(tapply(mac$west,list(mac$Year,mac$Quarter,mac$Age),mean))

trellis.device(device="png", filename=file.path(data.path,'consum.png'),width = 1200, height = 1600,units = "px", pointsize = 40)

xyplot(log(ration)~log(west)|paste(Species,", Q:",Quarter,sep=''),
       auto.key = list(points = T, rectangles = F, space = "right"),scales = "free",
       panel = function(x,y) {
         panel.grid(h=-1, v= -1)
         panel.xyplot(x, y)
         panel.lmline(x, y)
       }, data=dat1,subset=ration>0 & west>0)

dev.off()

xyplot(log(ration)~log(west)|Species+ Quarter,
       auto.key = list(points = T, rectangles = F, space = "right"),scales = "free",
       panel = function(x,y) {
         panel.grid(h=-1, v= -1)
         panel.xyplot(x, y)
         panel.lmline(x, y)
       }, data=dat1)

xyplot(ration~west| paste(Species,", Q:",Quarter,sep=''),
  auto.key = list(points = T, rectangles = F, space = "right"),scales = "free",
         panel = function(x,y) {
           panel.grid(h=-1, v= -1)
           panel.xyplot(x, y)
            panel.lmline(x, y)
       }, data=dat1)

dat1$Year<-NULL
dat1<-unique(dat1)

# not used
a<-by(dat1,list(dat1$Species.n),function(x) {
 #lm(log(ration)~as.factor(Quarter)+as.factor(Quarter)*log(west)-1,data=x)
    lm(log(ration)~as.factor(Quarter)+log(west)-1,data=x)
})

aa<-by(dat1,list(dat1$Species.n,dat1$Quarter),function(x) {
  c(x[1,"Species.n"],x[1,"Quarter"])
})
lapply(aa,print)

aa<-as.data.frame(matrix(unlist(aa),byrow=T,ncol=2))
names(aa)<-c('Species.n','Quarter')

a<-by(dat1,list(dat1$Species.n,dat1$Quarter),function(x) {
  lm(log(ration)~log(west),weights=BIO,data=x)
})
lapply(a,summary)

b<-lapply(a,coefficients)
bb<-as.data.frame(matrix(unlist(b),byrow=T,ncol=2))
names(bb)<-c('a','b')
 dd<-cbind(aa,bb)
dd$a<-exp(dd$a)

mm2<-subset(mm,Same,select=c(Species))
dat1<-merge(dat0,mm2)
dat1<-subset(dat1,Year==2013,select=c(Species.n, Quarter,ration))
names(dat1)<-c('Species.n','Quarter', 'a')
dat1$b<-0

dd<-rbind(dd,dat1)
dd<-dd[order(dd$Species.n,dd$Quarter),]

cat('a in consumption=a*w^b\n')
a<-tapply(dd$a,list(dd$Species,dd$Quarter),sum)
ftable(round(a,3))

cat('b in consumption=a*w^b\n')
b<-tapply(dd$b,list(dd$Species,dd$Quarter),sum)
ftable(round(b,3))

a[is.na(a)]<-0
b[is.na(b)]<-0

outfile<-file.path(data.path,'consum_ab.in')
cat(file=outfile,"# paramter a and b for consumption=a*weight^b\n")

for (s in (1:npr)) {
  cat(file=outfile,"# ",sp.names[s],"\n",append=T)
  for (q in (1:4)) {
    cat(file=outfile,a[s,q],b[s,q],"\t# Quarter",q,"\n",append=T)
  }
}


#!/usr/bin/Rscript

library(sds)
library(Hmisc)
library(pander)
library(plyr)
library(reshape2)

#' Create distance matrices

unwanted <- c('week', 'totalNumberSwineAccessions', 'Unk')
ind <- which(!colnames(real.case.data) %in% unwanted)
observed <- real.case.data[, ind]

CheckCrossCorLagSensitivity <- function(observed){
  lags <- 0:10
  tmpf <- function(x, y){
    sx <- observed[, x]
    sy <- observed[, y]
    ret <- ccf(sx, sy, plot=FALSE, demean=TRUE)
    ret <- ret[lags, ]
    ret$acf[, ,1]
  }
  grd <- expand.grid(x=1:ncol(observed), y=1:ncol(observed))
  grd <- grd[grd$x != grd$y, ]
  cross.cors <- mapply(x=grd$x, y=grd$y, tmpf)

  png('cross-cors-by-lag-boxplot.png')
  boxplot(t(cross.cors), names=lags, xlab='lag', ylab='cross-correlation')
  dev.off()

  lag.max.ind <- apply(cross.cors, 2, which.max)
  lag.max <- lags[lag.max.ind]
  png('counts-of-times-each-lag-was-max-for-a-pair.png')
  plot(table(lag.max))
  dev.off()
}
CheckCrossCorLagSensitivity(observed)

pop.struct.mats <- MakePopStructMats(observed)
pop.dyn.mats <- MakePopDynMats(observed, lags.sel=0:2)

#' Test for association between distance matrices

struct.v.struct.tests <- DoMantelTests(pop.struct.mats, pop.struct.mats,
                                       permutations=1e4)
dyn.v.struct.tests <- DoMantelTests(pop.dyn.mats, pop.struct.mats,
                                    permutation=1e4)

sink('mantel-table-population-structure-matrices.txt')
pander(struct.v.struct.tests)
sink()
sink('mantel-table-population-structure-vs-dynamics-matrices.txt')
pander(dyn.v.struct.tests)
sink()

#' Get descriptive stats

getDesc <- function(M) {
  non.diag <- as.logical(upper.tri(M) + lower.tri(M))
  M[non.diag]
}
desc <- sapply(c(pop.dyn.mats['lag1'], pop.struct.mats), getDesc)
invisible(latex(describe(desc), file='mantel-describe.tex'))

#' Run partial tests

partial.tests <- DoPartialMantelTests(pop.dyn.mats, pop.struct.mats['shipment'],
                               pop.struct.mats['gcd'], permutation=1e3)

sink('mantel-partial-table.txt')
pander(partial.tests)
sink()

save.image(file='mantel-testing-checkpoint1.RData')


library(ggplot2)
library(ggthemes)

str_btw = function(x, start, end) sapply(regmatches(x, regexec(paste0(start, "\\s*(.*?)\\s*", end), x)), `[`, 2)

process = function(x, gpu=FALSE)
{
  jsrun = x[grep("^jsrun", x)]
  b = x[-grep("(^jsrun|SIZE|Tile)", x)]

  n = as.integer(str_btw(b, " ", "x"))
  mflops = as.double(str_btw(b, ":", "MFlops"))
  runtime = as.double(str_btw(b, "MFlops", "sec"))

  repper = function(x, len) unlist(lapply(1:length(x), function(i) rep(x[i], len[i])))
  nruns = diff(c(grep("4096x", b), length(b)+1))

  if (isTRUE(gpu))
  {
    ngpu = as.integer(str_btw(jsrun, "-g", "-b"))
    tile = as.integer(str_btw(jsrun, "nvblas_", ".conf"))

    df = data.frame(n, mflops, runtime, ngpu=repper(ngpu, nruns), tile=repper(tile, nruns))
    df$ngpu = as.factor(df$ngpu)
    df$tile = as.factor(paste("Tile =", df$tile))
  }
  else
  {
    nthreads = as.integer(str_btw(jsrun, "THREADS=", "Rscript"))

    df = data.frame(n, mflops, runtime, nthreads=repper(nthreads, nruns))
    df$nthreads = as.factor(df$nthreads)
  }

  df
}

plotter = function(df, ...)
{
  ggplot(df, aes(n, mflops, ...)) + theme_bw() + scale_color_tableau() +
    geom_point() + geom_line() +
    scale_x_continuous(trans="log2") +
    theme(legend.position="bottom", legend.box="horizontal") +
    labs(x="Matrix Size", y="MFlops")
}


#' Assess a package for the number of downloads in the past year
#'
#' @details The more times a package has been downloaded the more extensive the user testing and the greater chance there is of someone finding a bug and logging it.
#'
#' @eval roxygen_assess_family(
#'   "downloads_1yr",
#'   "a numeric value between [0,1] indicating the volume of downloads")
#'
#' @export
assess_downloads_1yr <- function(x, ...){
  UseMethod("assess_downloads_1yr")
}

# assign a friendly name for assess column
attr(assess_downloads_1yr,"column_name") <- "downloads_1yr"
attr(assess_downloads_1yr,"label") <- "number of downloads in the past year"

#' @export
assess_downloads_1yr.pkg_ref <- function(x, ...) {
  downloads_1yr <- sum(x$downloads$count)
  pkg_metric(downloads_1yr, class = "pkg_metric_downloads_1yr")
}

#' Defining an Assessment Scoring Function
#' Score a package for the number of downloads in the past year
#'
#' Convert the number of downloads \code{x} in the past year into a validation
#' score [0,1] \deqn{ 1 - 150,000 / (x + 150,000) }
#'
#' The scoring function is a simplification of the classic logistic curve \deqn{
#' 1 / (1 + exp(-k(x-x[0])) } with a log scale for the number of downloads
#' \eqn{x = log(x)}, sigmoid midpoint is 1000 downloads, ie. \eqn{x[0] =
#' log(1,000)}, and logistic growth rate of \eqn{k = 0.5}.
#'
#' \deqn{ 1 - 1 / (1 + exp(log(x)-log(1.5e5))) = 1 - 150,000 / (x + 150,000) }
#'
#' @eval roxygen_score_family("downloads_1yr")
#' @return numeric value between \code{0} (low) and \code{1} (high download
#'   volume) converting the number of downloads.
#'
#' @export
score.pkg_metric_downloads_1yr <- function(x, ...) {
  # simplification from logistic: 1 - 1 / (1 + exp(log(x)-log(1.5e5)))
  1 - 1.5e5 / (x + 1.5e5)
}