source("../compile_datasets/code/gaf_tools.r")
library("data.table")

arab_gaf = read_gaf("gaf/TAIR10.gaf")
non_hc_ev = c("IEA","ND","NAS")
ont_counts = merge(arab_gaf[,list(all=.N),by=(aspect)], arab_gaf[!evidence_code %in% non_hc_ev,list(hc=.N),by=(aspect)])
write.table(ont_counts,"tables/ont_counts.csv",sep = "\t",row.names = F,quote = F)

arab_gaf

ev_desc = fread("../ev_desc.txt",stringsAsFactors = T)
type_order = c("Experimental","Computational","Curator","Author","Automatic")

ev_desc$type = factor(ev_desc$type, levels=type_order)
ev_code_count = merge(ev_desc,arab_gaf[,list(annot_count=.N,gene_count=length(unique(db_object_id))),by=(evidence_code)],by.x = "ev_code",by.y = "evidence_code")

ev_code_count$type = factor(ev_code_count$type,levels = type_order)
ev_code_count = ev_code_count[order(annot_count,decreasing = T)][order(type)]

write.table(ev_code_count,"tables/ev-code-counts.csv",sep = "\t",row.names = F,quote = F)

length(unique(arab_gaf[!evidence_code %in% non_hc_ev]$db_object_id))


#===================================================================================================

# intersect (Supplementary Figure 6e)

#===================================================================================================
#methylation array data loading
oe_data <- read.table("Methyl850_OE_sel_processed_Mval.txt")    #M-value matrix of GATA6 overexpression
hep7_data <- read.table("Methyl850_HEP_sel_processed_Mval.txt")    #M-value matrix of hepatocyte differentiation time-course

#common probes
oe_data <- oe_data[rownames(oe_data) %in% rownames(hep7_data),]
hep7_data <- hep7_data[rownames(hep7_data) %in% rownames(oe_data),]

#all probes
all_probe_posi <- na.omit(probeID2position(rownames(oe_data)))
all_probe_gr <- GRanges(seqnames = all_probe_posi[, 1],
                        ranges = IRanges(start = all_probe_posi[, 2],
                                         end = all_probe_posi[, 2] + 1),
                        strand = "*",
                        name = rownames(all_probe_posi))
all_probe_gr <- all_probe_gr + 200

#demethylated probes in OE
oe_demet_id <- DmpId(selDataMatrix = oe_data, ControlColnum = 1, TreatmentColnum = 2)
oe_posi <- probeID2position(oe_demet_id)
oe_gr <- GRanges(seqnames = oe_posi[,1],
                        ranges = IRanges(start = oe_posi[,2],
                                         end = oe_posi[,2] + 1),
                        strand = "*",
                        name = rownames(oe_posi))
oe_gr <- oe_gr + 200

#demethylated probes at day 7 comp to day 0
hep7_demet_id <- DmpId(selDataMatrix = hep7_data, ControlColnum = 1, TreatmentColnum = 2)
hep7_posi <- probeID2position(hep7_demet_id)
hep7_gr <- GRanges(seqnames = hep7_posi[,1],
                        ranges = IRanges(start = hep7_posi[,2],
                                         end = hep7_posi[,2] + 1),
                        strand = "*",
                        name = rownames(hep7_posi))
hep7_gr <- hep7_gr + 200

#overlaped demethylated probes
intersect_posi <- probeID2position(oe_demet_id[oe_demet_id %in% hep7_demet_id])
intersect_gr <- GRanges(seqnames = intersect_posi[,1],
                        ranges = IRanges(start = intersect_posi[,2],
                                         end = intersect_posi[,2] + 1),
                        strand = "*",
                        name = rownames(intersect_posi))
intersect_gr <- intersect_gr + 200

#GATA6 ChIP
gata6_gr <- bed2granges("GATA6_72h_peaks.narrowPeak")

#-------------------------------------------------
#venn's diagrams
#-------------------------------------------------
#compute overlaps
(n.oe <- length(oe_gr))
(n.hep7 <- length(hep7_gr))
(n.GATA6 <- length(gata6_gr))
(nOE_hep7 <- length(intersect_gr))
(nhep7_GATA6 <- length(findOverlaps(gata6_gr, hep7_gr)))
(nGATA6_OE <- length(findOverlaps(gata6_gr, oe_gr)))
(n.all <- length(findOverlaps(gata6_gr, intersect_gr)))

#OE vs GATA6
v <- venneuler(c(OE = n.oe, GATA6 = n.GATA6, "GATA6&OE" = nGATA6_OE))
pdf(paste0(out_dir, "OE_GATA6_intersect.pdf"))
plot(v, main = "Overlaps of demethylated regions", col = c("deeppink4", "azure4"))
dev.off()

#DE vs GATA6
v <- venneuler(c(DE = n.hep7, GATA6 = n.GATA6, "DE&GATA6" = nhep7_GATA6))
pdf(paste0(out_dir, "DE_GATA6_intersect.pdf"))
plot(v, main = "Overlaps of demethylated regions", col = c("blue", "green"))
dev.off()

#DE_GATA6 vs OE
v <- venneuler(c(DE_GATA6 = nhep7_GATA6, OE = n.oe, "DE_GATA6&OE" = n.all))
pdf(paste0(out_dir, "DEGATA6_OE_intersect.pdf"))
plot(v, main = "Overlaps of demethylated regions", col = c("seagreen", "royalblue3"))
dev.off()

#Three intersects
v <- venneuler(c(OE = n.oe, DE = n.hep7, GATA6 = n.GATA6, "OE&DE" = nOE_hep7, "DE&GATA6" = nhep7_GATA6, "GATA6&OE" = nGATA6_OE, "OE&DE&GATA6" = n.all))
pdf(paste0(out_dir, "OE_DE_GATA6_intersect.pdf"))
plot(v, main = "Overlaps of demethylated regions", col = c("blue", "green", "orange"))
dev.off()

#-------------------------------------------------
#bed files
#-------------------------------------------------
all_gr <- intersect_gr[subjectHits(findOverlaps(gata6_gr, intersect_gr))]
export.bed(all_gr, con=paste0(data_dir, 'all_intersects.bed'))

#annotation
anno <- read.csv("./data/MethylationEPIC_v-1-0_B4.csv", skip = 7, header=TRUE)
all_anno <- anno[anno[,1] %in% all_gr$name, c(1,11,12,13,15, 16, 17,18, 19,20,21, 22)]
write.table(all_anno, file = paste0(out_dir, "all_intersect_anno.txt"), quote = FALSE, sep = "\t", row.names = FALSE)

#-------------------------------------------------
#permutation test
#-------------------------------------------------
pt1 <- permTest(A = hep7_gr,
    B = gata6_gr,
    universe = all_probe_gr,
    randomize.function = resampleRegions,
    evaluate.function = numOverlaps,
    ntimes = 1000,
    verbose = TRUE)
pt1

GATA6_DE_intersect_gr <-hep7_gr[subjectHits(findOverlaps(gata6_gr, hep7_gr))]
pt2 <- permTest(A = GATA6_DE_intersect_gr,
    B = oe_gr,
    universe = all_probe_gr,
    randomize.function = resampleRegions,
    evaluate.function = numOverlaps,
    ntimes = 1000,
    verbose = TRUE)
pt2


#####################################################################################################
#################### Aim: estimate prevalence of health states from SILC
#####################################################################################################
rm(list=ls())
dev.off()

library(eurostat)
library(MASS)
library(sjmisc)
library(tidyr)
library(dplyr)
data.dir <- "C:\\Users\\Magdalena\\demography\\happyindex\\data\\SILC"
setwd(data.dir)

mydata<- read.table(file="silc2018new.csv", sep=",", header=TRUE)

cname <- c( "Austria", "Belgium", "Bulgaria", "Switzerland", "Cyprus", "Czechia", "Denmark", "Estonia", "Greece",
             "Spain", "Finland", "France", "Croatia","Hungary","Ireland","Italy", "Lithuania", "Luxembourg", "Latvia", "Netherlands","Norway", "Poland",
             "Portugal", "Romania", "Serbia",  "Sweden", "Slovenia", "Slovakia", "United Kingdom")

#countriesnames <- read.table(file="countriesnames.csv", sep=",")

###help variable for large age-groups
agegr <- rep(0, nrow=nrow(mydata))
mydata <- cbind(mydata,agegr)
ages <- c(15,30,40,seq(50,80,5))

for (i in 1:length(ages)){
  mydata$agegr[mydata$age>=ages[i]] <- ages[i]
}

#########recode as in the weights
mydata$chronic[mydata$chronic==2] <- 0
mydata$country <- as.factor(as.numeric(as.character(mydata$country)))
mydata$GALI2 <- revalue(as.factor(mydata$GALI), c("1"="3", "3"="1"))
mydata$GALI2 <- as.factor(as.numeric(as.character(mydata$GALI2)))

#################################################################################################################
#######chronic
#################################################################################################################
chronic <- tapply(X=mydata$weight, INDEX=list(chronic=mydata$chronic, agegr=mydata$agegr,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)
chronic[is.na(chronic)] <- 0
pop<- chronic[1,,,]+chronic[2,,,]

#correct ages 15, 16 as half 17
chronic17 <- tapply(X=mydata$weight, INDEX=list(chronic=mydata$chronic, agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum,na.rm=TRUE)[,1,,]
chronic17[is.na(chronic17)] <- 0
pop17 <- tapply(X=mydata$weight, INDEX=list(agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[1,,]

chronic[2,1,,] <- chronic[2,1,,]+chronic17[2,,]
chronic[1,1,,] <- chronic[1,1,,]-chronic17[2,,]+2*pop17
pop[1,,] <- pop[1,,] + 2*pop17
#####
chronicperc <- array(0, dim=dim(chronic), dimnames=dimnames(chronic))
for (i in 1:2){
  chronicperc[i,,,] <- chronic[i,,,]/pop
}
chronicperc[is.na(chronicperc)] <- 0

chronicprev <- as.data.frame.table(chronicperc)
write.table(chronicprev, file="chronicprev.csv", sep=",")

###########################################################################################
#GALI
###########################################################################################
GALI <- tapply(X=mydata$weight, INDEX=list(GALI=mydata$GALI2, agegr=mydata$agegr,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)
GALI[is.na(GALI)]<- 0
pop <- GALI[1,,,]+GALI[2,,,]+GALI[3,,,]

#correct ages 15, 16 as half 17
GALI17 <- tapply(X=mydata$weight, INDEX=list(GALI=mydata$GALI2, agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[,1,,]
GALI17[is.na(GALI17)] <- 0
pop17 <- tapply(X=mydata$weight, INDEX=list(agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[1,,]

GALI[2,1,,] <- GALI[2,1,,]+GALI17[2,,]
GALI[3,1,,] <- GALI[3,1,,]+GALI17[3,,]
GALI[1,1,,] <- GALI[1,1,,]-GALI17[2,,]-GALI17[3,,]+ 2*pop17

pop[1,,] <- pop[1,,] + 2*pop17
#####
GALIperc <- array(0, dim=dim(GALI), dimnames=dimnames(GALI))
for (i in 1:3){
  GALIperc[i,,,] <- GALI[i,,,]/pop
}

GALIperc[is.na(GALIperc)] <- 0

GALIprev <- as.data.frame.table(GALIperc)
write.table(GALIprev, file="GALIprev.csv", sep=",")

##############################################################################################################
#SR
##############################################################################################################

SR <- tapply(X=mydata$weight, INDEX=list(SR=mydata$selfrated, agegr=mydata$agegr,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)
SR[is.na(SR)] <- 0
pop<- SR[1,,,]+SR[2,,,]+SR[3,,,]+SR[4,,,]+SR[5,,,]

#correct ages 15, 16 as half 17
SR17 <- tapply(X=mydata$weight, INDEX=list(SR=mydata$selfrated, agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[,1,,]
SR17[is.na(SR17)] <- 0
pop17 <- tapply(X=mydata$weight, INDEX=list(agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[1,,]

SR[2:5,1,,] <- SR[2:5,1,,]+SR17[2:5,,]
SR[1,1,,] <- SR[1,1,,]-SR17[2,,]-SR17[3,,]-SR17[4,,]-SR17[5,,]+2*pop17
pop[1,,] <- pop[1,,] + 2*pop17
#####
SRperc <- array(0, dim=dim(SR), dimnames=dimnames(SR))
for (i in 1:5){
  SRperc[i,,,] <- SR[i,,,]/pop
}
SRperc[is.na(SRperc)] <- 0

SRprev <- as.data.frame.table(SRperc)
write.table(SRprev, file="SRprev.csv", sep=",")

#####################################################################################################################
#multi
####################################################################################################################
mydata$multi <- as.numeric(paste(mydata$chronic, mydata$GALI2, mydata$selfrated, sep=""))

multi <- tapply(X=mydata$weight, INDEX=list(multi=mydata$multi, agegr=mydata$agegr,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)
pop <- tapply(X=mydata$weight, INDEX=list(agegr=mydata$agegr,country=mydata$country, sex=mydata$sex), na.rm=TRUE, FUN=sum)

#correct ages 15, 16 as half 17
multi17 <- tapply(X=mydata$weight, INDEX=list(multi=mydata$multi, agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[,1,,]
multi17[is.na(multi17)] <- 0
pop17 <- tapply(X=mydata$weight, INDEX=list(agegr=mydata$age,country=mydata$country, sex=mydata$sex), FUN=sum, na.rm=TRUE)[1,,]

multi[2:27,1,,] <- multi[2:27,1,,]+multi17[2:27,,]
multi[1,1,,] <- multi[1,1,,]-colSums(multi17[2:27,,])+2*pop17

pop[1,,] <- pop[1,,] + 2*pop17
#####
multiperc <- array(0, dim=dim(multi), dimnames=dimnames(multi))
for (i in 1:30){
  multiperc[i,,,] <- multi[i,,,]/pop
}
multiperc[is.na(multiperc)] <- 0

multiprev <- as.data.frame.table(multiperc)
write.table(multiprev, file="multiprev.csv", sep=",")


#' Data Overview for WRTDS
#'
#' Gives a summary of data to be used for WRTDS analysis
#'
#' @param Daily dataframe
#' @param Sample dataframe
#' @keywords data import USGS WRTDS
#' @export
#' @seealso \code{\link{mergeReport}}
#' @examples
#' eList <- Choptank_eList
#' exDaily <- getDaily(eList)
#' exSample <- getSample(eList)
#' dataOverview(Daily = exDaily, Sample = exSample)
dataOverview <- function(Daily, Sample ){

  numDays<-length(Daily$Date)
  numSamples<-length(Sample$Date)
  numYears<-round(numDays/365.25,digits=0)
  cat("\n Discharge Record is",numDays,"days long, which is",numYears,"years")
  cat("\n First day of the discharge record is", as.character(Daily$Date[1]),"and last day is",as.character(Daily$Date[numDays]))
  cat("\n The water quality record has",numSamples,"samples")
  cat("\n The first sample is from", as.character(Sample$Date[1]),"and the last sample is from",as.character(Sample$Date[numSamples]))
  if(Sample$Date[1]<Daily$Date[1]) cat("\n WE HAVE A PROBLEM first sample is from before the first daily discharge")
  if(Sample$Date[numSamples]>Daily$Date[numDays]) cat("\n WE HAVE A PROBLEM last sample is from after the last daily discharge")
  Qmin<-signif(min(Daily$Q),digits=3)
  Qmean<-signif(mean(Daily$Q),digits=3)
  Qmax<-signif(max(Daily$Q),digits=3)
  Cmin<-signif(min(Sample$ConcHigh),digits=2)
  Cmean<-signif(mean(Sample$ConcHigh),digits=2)
  Cmax<-signif(max(Sample$ConcHigh),digits=2)
  cat("\n Discharge: Minimum, mean and maximum",Qmin,Qmean,Qmax)
  cat("\n Concentration: Minimum, mean and maximum",Cmin,Cmean,Cmax)
  pct<-sum(Sample$Uncen)
  pct<-((numSamples-pct)/numSamples)*100
  cat("\n Percentage of the sample values that are censored is",signif(pct,digits=2),"%")
}


#!/usr/bin/R

# Performs likelihood-ratio test on PAML output,
  # comparing branch and null models

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

tests           <- read.table("results/likelihoods.txt")
colnames(tests) <- c("id", "model", "lnl", "np")

# ---------------------------------------------------------------------------- #
# Divide each model into seqparate columns
null_tests   <- tests[tests$model == "null", ]
branch_tests <- tests[tests$model == "branch", ]

stopifnot(null_tests$id == branch_tests$id)

colnames(null_tests)   <- paste(colnames(null_tests), "null", sep = "_")
colnames(branch_tests) <- paste(colnames(branch_tests), "branch", sep = "_")

tests <- cbind(null_tests, branch_tests)

# ---------------------------------------------------------------------------- #
# Test parameter
tests$D <- 2 * (tests$lnl_branch - tests$lnl_null)
# stopifnot(tests$D > 0)

# Degrees of freedom
tests$df <- tests$np_branch - tests$np_null
stopifnot(tests$df > 0)

# ---------------------------------------------------------------------------- #
# P-value
tests$p.val <- pchisq(tests$D, tests$df, lower.tail=FALSE)

# ---------------------------------------------------------------------------- #
# False Discovery Rate correction for mutiple testing
library(qvalue)
qobj <- qvalue(p = tests$p.val)

tests$q.val <- qobj$qvalues

# Plots
pdf("results/FDR.pdf")
hist(qobj)
plot(qobj)
dev.off()

# ---------------------------------------------------------------------------- #
# Parse column names to print
tests <- tests[, !colnames(tests) %in% c("id_branch", "model_null", "model_branch")]

colnames(tests)[1] <- "orthogroup"

# ---------------------------------------------------------------------------- #
# Write out
write.csv(tests, file = "results/log_ratio_test.csv", row.names=FALSE, quote=FALSE)

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


## This script was used to generate smoking and cellular composition covariates from the DNA methylation data
## Filepaths and sample IDs have been removed for security reasons, therfore it serves as a guide to the analysis

library(minfi)
library(wateRmelon)
library(FlowSorted.Blood.450k)

library(genefilter)
library("IlluminaHumanMethylation450kanno.ilmn12.hg19")

sampleSheet<-read.csv("SampleSheets/minerva_20160216.csv", stringsAsFactors = FALSE, skip = 8)
sampleSheet<-cbind(paste(sampleSheet$Sentrix_ID, sampleSheet$Sentrix_Position, sep = "_"), sampleSheet)
colnames(sampleSheet)[1]<-"Basename"
idatPath<-paste("idats/", sampleSheet$Sentrix_ID, "/", sampleSheet$Sentrix_ID, "_", sampleSheet$Sentrix_Position, sep ="")
RGSet <- read.450k(idatPath, extended = FALSE)

counts<-estimateCellCounts(RGSet, compositeCellType = "Blood",
                                cellTypes = c("CD8T","CD4T", "NK","Bcell","Mono","Gran"),
                                returnAll = FALSE, meanPlot = FALSE, verbose=TRUE)

write.csv(counts, "Analysis/HousemanEstimatedCellCounts.csv")

## calculate smoking scores

setwd("")
load("QCed_Data.rda")

cpgs <- c("cg09469355",   "cg08884752", 	"cg12547807", 	"cg04885881", 	"cg21393163", 	"cg21913886", 	"cg19713429", 	"cg27537125", 	"cg15542713", 	"cg24049493", 	"cg23090529", 	"cg21140898", 	"cg19406367", 	"cg25189904", 	"cg09662411", 	"cg18146737", 	"cg12876356", 	"cg18316974", 	"cg09935388", 	"cg11231349", 	"cg08709672", 	"cg20295214", 	"cg03547355", 	"cg17819085", 	"cg23079012", 	"cg06635952", 	"cg26271591", 	"cg23667432", 	"cg03188382", 	"cg19713851", 	"cg27241845", 	"cg03329539", 	"cg06644428", 	"cg05951221", 	"cg21566642", 	"cg01940273", 	"cg13193840", 	"cg17024919", 	"cg15693572", 	"cg23480021", 	"cg03274391", 	"cg00501876", 	"cg18642234", 	"cg15417641", 	"cg00336149", 	"cg21188533", 	"cg19859270", 	"cg02657160", 	"cg25197194", 	"cg08202836", 	"cg21121843", 	"cg19719391", 	"cg24556382", 	"cg11554391", 	"cg17924476", 	"cg08606254", 	"cg12806681", 	"cg03991871", 	"cg23916896", 	"cg11902777", 	"cg01899089", 	"cg05575921", 	"cg26703534", 	"cg01097768", 	"cg14817490", 	"cg25648203", 	"cg21161138", 	"cg03604011", 	"cg24090911", 	"cg13039251", 	"cg05673882", 	"cg26908328", 	"cg16786458", 	"cg14580211", 	"cg12513616", 	"cg01882991", 	"cg06126421", 	"cg14753356", 	"cg24859433", 	"cg15342087", 	"cg17619755", 	"cg10807309", 	"cg15474579", 	"cg00931843", 	"cg00921574", 	"cg19717773", 	"cg02451831", 	"cg08972170", 	"cg19089201", 	"cg22132788", 	"cg04180046", 	"cg12803068", 	"cg07826859", 	"cg03440944", 	"cg21322436", 	"cg25949550", 	"cg11207515", 	"cg17372101", 	"cg12276019", 	"cg24540678", 	"cg13518625", 	"cg19589396", 	"cg25305703", 	"cg12075928", 	"cg26361535", 	"cg13787850", 	"cg01692968", 	"cg13910681", 	"cg22539182", 	"cg25953130", 	"cg27312979", 	"cg25421530", 	"cg01744331", 	"cg07123182", 	"cg16556677", 	"cg26963277", 	"cg04039799", 	"cg09197783", 	"cg16611234", 	"cg19254163", 	"cg21611682", 	"cg14624207", 	"cg01901332", 	"cg11660018", 	"cg23771366", 	"cg03234777", 	"cg26282236", 	"cg02583484", 	"cg04158018", 	"cg23681440", 	"cg23126342", 	"cg25491122", 	"cg06885459", 	"cg17487894", 	"cg01731783", 	"cg22851561", 	"cg24996979", 	"cg10919522", 	"cg13976502", 	"cg13038618", 	"cg05875421", 	"cg05284742", 	"cg06819357", 	"cg26242531", 	"cg11730703", 	"cg01208318", 	"cg15022400", 	"cg03489965", 	"cg18335991", 	"cg00310412", 	"cg11152412", 	"cg23161492", 	"cg05194346", 	"cg01207684", 	"cg09099830", 	"cg03155159", 	"cg00911794", 	"cg23621097", 	"cg09858022", 	"cg19572487", 	"cg04956244", 	"cg16255816", 	"cg03373393", 	"cg25809905", 	"cg21280392", 	"cg07465627", 	"cg02186444", 	"cg07251887", 	"cg06459104", 	"cg00073090", 	"cg15187398", 	"cg07381806", 	"cg00835193", 	"cg03636183", 	"cg15159987", 	"cg23973524", 	"cg11902728", 	"cg22649124", 	"cg11701312", 	"cg16201146", 	"cg07339236", 	"cg00871610", 	"cg06595162", 	"cg23110422", 	"cg22635096", 	"cg02532700", 	"cg01127300")

reference_never_median_beta_discovery<- c(0.3299,  0.6803,  0.1885,	0.3115,	0.0445,	0.8917,	0.0987,	0.0877,	0.4002,	0.1219,	0.2061,	0.3534,	0.8147,	0.2740,	0.4805,	0.9565,	0.5475,	0.9544,	0.5765,	0.8372,	0.6776,	0.8467,	0.6024,	0.7041,	0.9594,	0.1388,	0.2569,	0.3401,	0.2432,	0.4950,	0.4617,	0.1598,	0.2142,	0.2199,	0.5658,	0.3437,	0.1525,	0.1708,	0.2942,	0.4259,	0.3190,	0.3692,	0.2316,	0.6818,	0.2530,	0.5724,	0.9560,	0.9255,	0.4321,	0.8802,	0.1334,	0.5305,	0.7934,	0.0911,	0.2628,	0.9490,	0.9537,	0.9469,	0.1286,	0.0379,	0.2486,	0.8841,	0.6269,	0.7457,	0.1350,	0.8642,	0.6998,	0.0759,	0.8246,	0.7536,	0.1515,	0.0824,	0.1744,	0.6909,	0.2101,	0.6357,	0.7724,	0.2383,	0.9322,	0.9371,	0.6519,	0.1534,	0.3563,	0.2963,	0.1005,	0.7015,	0.8243,	0.5272,	0.9094,	0.8599,	0.2316,	0.7382,	0.5836,	0.7533,	0.2855,	0.0852,	0.2725,	0.3192,	0.1235,	0.0855,	0.0565,	0.7511,	0.7103,	0.4672,	0.7593,	0.2680,	0.1619,	0.0782,	0.1902,	0.4928,	0.5558,	0.8762,	0.9380,	0.9527,	0.8507,	0.9013,	0.1954,	0.7554,	0.1449,	0.5778,	0.5276,	0.4747,	0.6741,	0.2926,	0.1993,	0.0561,	0.5699,	0.1476,	0.1587,	0.2499,	0.5136,	0.9053,	0.3917,	0.4107,	0.6572,	0.4718,	0.0802,	0.1323,	0.2701,	0.4082,	0.0755,	0.7424,	0.6637,	0.2288,	0.7804,	0.2836,	0.0804,	0.2217,	0.6581,	0.2994,	0.0522,	0.1212,	0.3928,	0.7670,	0.5947,	0.3190,	0.2870,	0.2768,	0.3923,	0.4477,	0.5979,	0.1406,	0.0849,	0.5129,	0.2667,	0.1802,	0.5410,	0.3329,	0.2918,	0.1727,	0.2507,	0.4132,	0.8822,	0.4930,	0.6339,	0.3062,	0.3524,	0.1161,	0.3002,	0.6390,	0.0828,	0.5267,	0.8358,	0.9005,	0.2511,	0.0924,	0.4576
)
reference_never_median_beta_replication<- c(0.3021,  0.5889,	0.1623,	0.2899,	0.0572,	0.8314,	0.0961,	0.0840,	0.3784,	0.1112,	0.1670,	0.3454,	0.6663,	0.2856,	0.5557,	0.9374,	0.7010,	0.9496,	0.4757,	0.8281,	0.6442,	0.7816,	0.5325,	0.6214,	0.9578,	0.1239,	0.2535,	0.3272,	0.2194,	0.4462,	0.4457,	0.1558,	0.1147,	0.1757,	0.5511,	0.2941,	0.1388,	0.1593,	0.3159,	0.4266,	0.2872,	0.4298,	0.2206,	0.6019,	0.2315,	0.5309,	0.9502,	0.9111,	0.4084,	0.8700,	0.1209,	0.4848,	0.7247,	0.0765,	0.2556,	0.9440,	0.9459,	0.9175,	0.1158,	0.0410,	0.2381,	0.9028,	0.6180,	0.6593,	0.1327,	0.8473,	0.7304,	0.0681,	0.7998,	0.7054,	0.1427,	0.0783,	0.1752,	0.6447,	0.1823,	0.6087,	0.6919,	0.2451,	0.8774,	0.9067,	0.6169,	0.1440,	0.2999,	0.3293,	0.0767,	0.6278,	0.7564,	0.4908,	0.8742,	0.8727,	0.1987,	0.7014,	0.5631,	0.6934,	0.2849,	0.0840,	0.2166,	0.3247,	0.0974,	0.0856,	0.0567,	0.6884,	0.6679,	0.4791,	0.7442,	0.2767,	0.1370,	0.0737,	0.1757,	0.4823,	0.5413,	0.8117,	0.9294,	0.9479,	0.8239,	0.9110,	0.1845,	0.6918,	0.1228,	0.5264,	0.4844,	0.4327,	0.6406,	0.2608,	0.1859,	0.0626,	0.4957,	0.1380,	0.1395,	0.2537,	0.4865,	0.8605,	0.3839,	0.3790,	0.6395,	0.4375,	0.0813,	0.1256,	0.3003,	0.4037,	0.0665,	0.6985,	0.5934,	0.2211,	0.8144,	0.2246,	0.0842,	0.2349,	0.5936,	0.2711,	0.0633,	0.1142,	0.4374,	0.7476,	0.6128,	0.3001,	0.2034,	0.1906,	0.3709,	0.4502,	0.5706,	0.1392,	0.0763,	0.5170,	0.2527,	0.1617,	0.5200,	0.3216,	0.2842,	0.1440,	0.2113,	0.3898,	0.8938,	0.5152,	0.6090,	0.2886,	0.3680,	0.1012,	0.2918,	0.5935,	0.0707,	0.4496,	0.7731,	0.8547,	0.2046,	0.1014,	0.4485
)

Illig_data<- as.data.frame(cbind(reference_never_median_beta_discovery,reference_never_median_beta_replication ))
Illig_data<- cbind(cpgs, Illig_data)
Illig_data$cpgs<- as.character(Illig_data$cpgs)

rm(reference_never_median_beta_discovery, reference_never_median_beta_replication)

#get average of reference data
Illig_data$reference_never_median_beta_all <- (Illig_data$reference_never_median_beta_discovery + Illig_data$reference_never_median_beta_replication)/2

discovery_effect<- c(-1.7622,   -4.0125,   -2.1385,   -7.4143, 	-0.69344, 	-3.3794, 	-0.44637, 	-1.21415, 	9.5242, 	4.0531, 	-2.2774, 	-3.2754, 	3.1142, 	-8.1918, 	-3.73, 	-1.5456, 	-8.47810000000001, 	-1.863, 	-15.309, 	-1.92, 	-2.5825, 	-2.9844, 	-2.75799999999999, 	-2.301, 	-1.1011, 	1.9969, 	-5.5731, 	-1.5705, 	-1.1947, 	-6.4717, 	-8.7388, 	-2.392, 	-7.0508, 	-5.2066, 	-16.6965, 	-7.888, 	-2.4077, 	-3.094, 	10.8674, 	18.6272, 	18.0645, 	-4.4316, 	-1.6179, 	7.91590000000001, 	6.4587, 	10.1755, 	-1.30749999999999, 	-1.4812, 	4.6228, 	1.5089, 	-2.0675, 	4.1802, 	-4.2454, 	-1.03248, 	5.8036, 	0.703299999999996, 	-2.4357, 	-5.73399999999999, 	-2.1082, 	-1.11996, 	-2.8583, 	-24.3991, 	-6.169, 	-2.40199999999999, 	-3.81225, 	-7.9626, 	-10.4479, 	3.39587, 	-4.0817, 	7.1504, 	-2.6538, 	-0.59522, 	2.1641, 	-3.90900000000001, 	-0.873000000000002, 	-1.39859999999999, 	-17.0529, 	-5.3664, 	-4.02899999999999, 	-3.35719999999999, 	4.05019999999999, 	1.8323, 	-3.232, 	6.3705, 	-0.450550000000001, 	-4.0493, 	-2.30229999999999, 	5.32899999999999, 	1.8564, 	6.6794, 	2.1692, 	14.9598, 	-5.1247, 	-2.42479999999999, 	-4.7443, 	-1.37529, 	8.2753, 	7.2277, 	-0.7689, 	-0.677029999999999, 	-0.49416, 	-3.86030000000001, 	-6.04889999999999, 	-7.8, 	-5.53600000000001, 	-3.0977, 	-1.4187, 	-0.414310000000001, 	1.4125, 	-4.6863, 	5.02359999999999, 	1.5969, 	-1.2068, 	-0.912999999999997, 	-3.8405, 	-2.8628, 	-1.6233, 	-3.04289999999999, 	-1.2548, 	-3.8772, 	-5.2424, 	-5.1484, 	-5.066, 	-3.8747, 	-2.2552, 	-0.69317, 	2.457, 	-2.0898, 	-1.2475, 	-1.3088, 	9.11000000000001, 	2.361, 	4.8836, 	2.80069999999999, 	-2.0523, 	-6.0595, 	-0.558449999999999, 	-0.8884, 	-1.0101, 	-4.4855, 	-0.52389, 	-3.7647, 	5.6982, 	4.0245, 	2.06419999999999, 	-7.7353, 	-0.732820000000001, 	2.6597, 	-3.9404, 	-1.9653, 	-0.304740000000001, 	-1.5956, 	9.9753, 	-1.8306, 	-1.72129999999999, 	-1.1892, 	4.6004, 	3.4679, 	1.2032, 	-10.0183, 	2.4992, 	-0.572700000000001, 	-0.34346, 	6.5291, 	2.3682, 	-1.3756, 	3.82, 	-5.1337, 	-5.4507, 	-0.262799999999999, 	-2.7521, 	-5.1181, 	-8.22849999999999, 	-14.7441, 	-3.53380000000001, 	4.2136, 	5.756, 	-0.710699999999999, 	-1.4144, 	-3.5737, 	-1.10312, 	-4.3308, 	-2.7056, 	-3.6816, 	3.3599, 	-1.15296, 	-3.8336
)
replication_effect<- c(-1.6099,   -2.81979999999999, 	-1.4614, 	-6.7149, 	-0.68405, 	-3.5057, 	-0.49342, 	-0.73492, 	9.9507, 	3.8345, 	-1.6371, 	-2.6235, 	4.5365, 	-7.3991, 	-9.49309999999999, 	-2.8745, 	-22.6313, 	-1.7279, 	-16.4712, 	-3.3428, 	-2.44439999999999, 	-4.36479999999999, 	-2.2104, 	-1.98120000000001, 	-0.96440000000001, 	1.3837, 	-4.7982, 	-1.4564, 	-1.1502, 	-4.4502, 	-8.3635, 	-2.5729, 	-3.75382, 	-4.528, 	-15.5755, 	-7.5282, 	-1.9091, 	-2.468, 	6.9033, 	15.7704, 	11.9284, 	-3.1183, 	-1.1142, 	5.2791, 	3.7103, 	5.55690000000001, 	-1.9446, 	-1.3694, 	4.8759, 	1.853, 	-1.3157, 	3.1426, 	-4.8709, 	-0.687099999999999, 	3.2526, 	0.693599999999994, 	-2.4193, 	-7.87749999999999, 	-1.94492, 	-0.94659, 	-2.2615, 	-23.2905, 	-5.765, 	-1.8888, 	-3.1682, 	-7.5465, 	-10.6031, 	1.93057, 	-4.2098, 	4.6683, 	-1.9902, 	-0.64671, 	1.5695, 	-4.612, 	-1.1957, 	-1.49279999999999, 	-17.8887, 	-6.4106, 	-4.92020000000001, 	-5.4226, 	2.62009999999999, 	2.0099, 	-2.1431, 	5.6581, 	-0.516119999999999, 	-4.11849999999999, 	-3.1008, 	4.94830000000001, 	2.87189999999999, 	5.02010000000001, 	2.095, 	15.1232, 	-3.7787, 	-1.42009999999999, 	-4.4589, 	-0.952359999999999, 	5.2891, 	4.09409999999999, 	-0.82503, 	-0.512169999999999, 	-0.70137, 	-1.83040000000001, 	-6.1682, 	-4.9707, 	-6.3504, 	-3.8308, 	-1.2104, 	-0.39709, 	0.9348, 	-5.413, 	3.85970000000001, 	2.7823, 	-1.3473, 	-0.812899999999994, 	-3.2855, 	-1.93449999999999, 	-0.744800000000001, 	-2.5682, 	-0.9808, 	-2.9197, 	-5.3765, 	-3.591, 	-4.335, 	-2.9625, 	-1.7865, 	-0.56123, 	3.6488, 	-1.7723, 	-1.2063, 	-2.6755, 	7.5574, 	2.4624, 	3.0119, 	2.6292, 	-1.6429, 	-3.596, 	-0.480170000000001, 	-0.610400000000001, 	-0.9629, 	-5.3384, 	-0.44131, 	-4.32, 	2.283, 	3.284, 	1.2263, 	-6.2008, 	-0.69752, 	2.4604, 	-2.9988, 	-2.6213, 	-0.33866, 	-1.52214, 	4.8933, 	-3.4185, 	-2.56569999999999, 	-2.719, 	1.9861, 	1.8342, 	1.042, 	-7.8054, 	1.5855, 	-0.899900000000001, 	-0.40104, 	3.8698, 	1.1379, 	-1.4603, 	3.008, 	-2.9392, 	-4.6963, 	-0.903500000000002, 	-1.765, 	-4.2724, 	-11.6612, 	-17.6258, 	-2.2744, 	2.1603, 	1.389, 	-0.54374, 	-1.1572, 	-3.54829999999999, 	-0.828230000000001, 	-3.8931, 	-2.288, 	-3.60010000000001, 	2.6395, 	-0.936690000000001, 	-3.8713
)
#take average
all_effect <- (discovery_effect + replication_effect)/2

Illig_data<- cbind(Illig_data, discovery_effect)
Illig_data<- cbind(Illig_data, replication_effect)
Illig_data<- cbind(Illig_data, all_effect)

rm(discovery_effect, replication_effect, all_effect)

### to keep consistent with elliott et al paper use the 183 cpg sites they used i.e remove "cg03188382" "cg12513616" "cg16611234" "cg22649124"
Illig_data <- Illig_data[-match(c("cg03188382","cg12513616","cg16611234","cg22649124"), Illig_data$cpgs),]

#Find average effect for all CpG sites combined
Illig_data$abs_all_effect <- abs(Illig_data$all_effect)
overall_average_effect <- mean(Illig_data$abs_all_effect)

#Generate weights and merge with Illig_data
#weights= per CpG site effect size / average effect size for all CpGs measured
weights<- Illig_data$abs_all_effect/overall_average_effect

Illig_data$weights <- weights

rm(overall_average_effect, weights)

Illig_data_up <- subset(Illig_data, Illig_data$all_effect >=0)
Illig_data_down <- subset(Illig_data, Illig_data$all_effect <0)

select <- rownames(betas) %in% Illig_data_down$cpgs
A_down <- subset(betas, select =="TRUE")
select <- rownames(betas) %in% Illig_data_up$cpgs
A_up <- subset(betas, select =="TRUE")

rm(select)

Illig_data_up<- Illig_data_up[order(Illig_data_up$cpgs),]
Illig_data_down<- Illig_data_down[order(Illig_data_down$cpgs),]

A_up <- A_up[order(rownames(A_up)),]
A_down <- A_down[order(rownames(A_down)),]

matrix_up_A<- matrix(nrow=nrow(Illig_data_up), ncol=ncol(A_up))
for (i in 1:ncol(A_up)){
  matrix_up_A[,i]<- (A_up[,i])-(Illig_data_up$reference_never_median_beta_all)}
colnames(matrix_up_A)<- colnames(A_up)
rownames(matrix_up_A)<- Illig_data_up$cpgs

scores_up_A<- as.numeric(rep(NA,ncol(A_up)))
for (i in 1:ncol(A_up)){
  scores_up_A[i]<-sum(matrix_up_A[,i]*Illig_data_up$weights)}

rm(Illig_data_up, A_up, matrix_up_A)

matrix_down_A<- matrix(nrow=nrow(Illig_data_down), ncol=ncol(A_down))
for (i in 1:ncol(A_down)){
  matrix_down_A[,i]<- (Illig_data_down$reference_never_median_beta_all)-(A_down[,i])}
colnames(matrix_down_A)<- colnames(A_down)
rownames(matrix_down_A)<- Illig_data_down$cpgs

scores_down_A<- as.numeric(rep(NA,ncol(A_down)))
for (i in 1:ncol(A_down)){
  scores_down_A[i]<-sum(matrix_down_A[,i]*Illig_data_down$weights)}

rm(Illig_data_down, A_down, matrix_down_A,E_down, matrix_down_E,F_down, matrix_down_F,H_down, matrix_down_H,Blood_down, matrix_down_Blood)

scores_combined_A <- scores_up_A + scores_down_A

sampleSheet<-cbind(sampleSheet, scores_combined_A)

write.csv(sampleSheet, "Analysis/QC/SmokingScores.csv")

pdf("Analysis/QC/Plots/Histogram_SmokingScores.pdf", height = 8, width = 8)
hist(scores_combined_A, xlab = "DNAm smoking score")
dev.off()


get_all_data<-function(fyear=2013, species=21740,region="'AI'",area="AI",MINAGE=100,filename="ai13_Nov.dat",WRITE=TRUE)  {

  ## Survey Age Data
  Age1=get_Sage(region=region,species=species,sy=1977,GEAR=172)
  Age2=get_Sage(region=region,species=species,sy=1977,GEAR=160)
  Age<-rbind(Age2,Age1)

  Age<-subset(Age,Age$YEAR<=fyear)
  Age_w<-subset(Age,Age$END_LONGITUDE > 0 | Age$END_LONGITUDE < -170)
  Age_w<-subset(Age_w,is.na(Age_w$AGE)==F)
  Age_w$AGE1<-Age_w$AGE
  Age_w$AGE1[Age_w$AGE1>=15]=15

##Survey Length Data
  Length1=get_Slength(region=region,species=21740,sy=1977,GEAR=172)
  Length2=get_Slength(region=region,species=21740,sy=1977,GEAR=160)
  Length<-rbind(Length2,Length1)

  Length<-subset(Length,Length$YEAR<=fyear)
  Length_w<-subset(Length,Length$END_LONGITUDE > 0 | Length$END_LONGITUDE < -170)
  Length_w<-subset(Length_w,Length_w$YEAR!=1982)
  Length_w<-subset(Length_w,Length_w$SEX!=3)

## Survey WEIGHT at Age
  TOTAL_AGE<-AGE_LENGTH(adata=Age_w,ldata=Length_w,fyear=fyear)  ##

## Survey Biomass Data
  BIOMASS<-get_AIbiom(species=21740)

  BIOMASS<-subset(BIOMASS,BIOMASS$YEAR<=fyear)

  BIO<-data.frame(aggregate(list(BIO=BIOMASS$AREA_BIOMASS,POP=BIOMASS$AREA_POP),by=list(YEAR=BIOMASS$YEAR),FUN=sum)  )
  VAR<-data.frame(aggregate(list(BIO=BIOMASS$BIOMASS_VAR,POP=BIOMASS$POP_VAR),by=list(YEAR=BIOMASS$YEAR),FUN=sum)  )
  survey_biomass=data.frame(YEAR=BIO$YEAR,BIO=BIO$BIO,B_STDEV=sqrt(VAR$BIO))

## calculate numbers at age

##BIO<-subset(BIO,YEAR!=2010)
  Total_WB<-merge(TOTAL_AGE$Total_AGE,BIO,all=T)
  Total_WB<-Total_WB[order(Total_WB$YEAR,Total_WB$AGE),]
  Total_WB$N_AGE<-Total_WB$PROB*Total_WB$POP
  Total_WB$W_AGE<-Total_WB$N_AGE*Total_WB$WEIGHT/1000000

  NAGE=aggregate(list(NUMBER=Total_WB$N_AGE),by=list(AGE=Total_WB$AGE,YEAR=Total_WB$YEAR,POP=Total_WB$POP),FUN=sum)
  NAGE$PROP<- NAGE$NUMBER/NAGE$POP
  NAGE<-subset(NAGE,select=-c(POP))

  years<-sort(unique(Age_w$YEAR))
  S_NAGE<-data.frame(matrix(ncol=15,nrow=length(years)))
  names(S_NAGE)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
  S_NAGE$YEAR<-years

 for( i in 1:length(years)){
  S_NAGE[i,2:15]<-NAGE$PROP[NAGE$YEAR==S_NAGE$YEAR[i]][2:15]
  }

  AI_DATA<-list(S_NAGE=S_NAGE)
##FISHEY
  FAge=get_Fage(species=201,sy=1977,area=area)

  FAge1<-subset(FAge,FAge$GENERIC_AREA==541&FAge$LATITUDE<5300)
  FAge2<-subset(FAge,FAge$GENERIC_AREA==542&FAge$LATITUDE<5230)
  FAge3<-subset(FAge,FAge$GENERIC_AREA==543&FAge$LATITUDE<5330)
  FAge<-rbind(FAge1,FAge2,FAge3)
  FAge<-FAge[order(FAge$YEAR,FAge$GENERIC_AREA),]
  remove(FAge1,FAge2,FAge3)
  FAge<-subset(FAge,select= -c(LATITUDE,LONGITUDE,E_W) )

  FLength= get_Flength(species=201,sy=1977,area=area)

  FLength1<-subset(FLength,FLength$GENERIC_AREA==541&FLength$LATITUDE<5300)
  FLength2<-subset(FLength,FLength$GENERIC_AREA==542&FLength$LATITUDE<5230)
  FLength3<-subset(FLength,FLength$GENERIC_AREA==543&FLength$LATITUDE<5330)
  FLength<-rbind(FLength1,FLength2,FLength3)
  FLength<-FLength[order(FLength$YEAR,FLength$GENERIC_AREA),]
  remove(FLength1,FLength2,FLength3)
  FLength<-subset(FLength,select= -c(LATITUDE,LONGITUDE,E_W) )

  DAge=get_Dage(species=201,area=area)

  DAge<-subset(DAge,DAge$YEAR<=fyear)
  DAge1<-subset(DAge,DAge$NMFS_AREA==541&DAge$LATDD_END<53.00)
  DAge2<-subset(DAge,DAge$NMFS_AREA==542&DAge$LATDD_END<52.50)
  DAge3<-subset(DAge,DAge$NMFS_AREA==543&DAge$LATDD_END<53.50)
  DAge<-rbind(DAge1,DAge2,DAge3)
  DAge<-DAge[order(DAge$YEAR,DAge$NMFS_AREA),]
  remove(DAge1,DAge2,DAge3)
  DAge<-subset(DAge,select= -c(LATDD_END,LONDD_END) )
  DAge<-subset(DAge,DAge$YEAR<1999)

  DLength=get_Dlength(species=201,area=area)

  DLength<-subset(DLength,DLength$YEAR<=fyear)
  DLength1<-subset(DLength,DLength$NMFS_AREA==541&DLength$LATDD_END<53.00)
  DLength2<-subset(DLength,DLength$NMFS_AREA==542&DLength$LATDD_END<52.50)
  DLength3<-subset(DLength,DLength$NMFS_AREA==543&DLength$LATDD_END<53.50)
  DLength<-rbind(DLength1,DLength2,DLength3)
  DLength<-DLength[order(DLength$YEAR,DLength$NMFS_AREA),]
  remove(DLength1,DLength2,DLength3)
  DLength<-subset(DLength,select= -c(LATDD_END,LONDD_END) )
  names(FLength)<-names(DLength)
  names(FAge)<-names(DAge)

  FAge<-rbind(FAge,DAge)
  FLength<-rbind(FLength,DLength)

  if(fyear  > 2006){
   AAge<-read.csv("Acoustic_survey_data.csv",header=T)
   AAge<-subset(AAge,AAge$YEAR<=fyear)

   AAge$WEIGHT<-AAge$WEIGHT/1000
   ALength<-aggregate(list(FREQ=AAge$LENGTH),by=list(YEAR=AAge$YEAR,NMFS_AREA=AAge$NMFS_AREA,SPECIES=AAge$SPECIES,SEX=AAge$SEX,LENGTH=AAge$LENGTH),FUN=length)
   ALength<-ALength[order(ALength$YEAR,ALength$LENGTH),]
   AAge$GEAR<-1
   ALength$GEAR<-1
   names(AAge)<-names(FAge)
   names(ALength)<-names(FLength)
   FAge<-rbind(FAge,AAge)
   FLength<-rbind(FLength,ALength)
   }

## Fishery AGE
  FAge_w<-subset(FAge,!is.na(FAge$AGE))
  FAge_w<-subset(FAge_w,!is.na(FAge_w$LENGTH))

  ## removing years with too few datapoints
  x<-aggregate(list(NUMBER=FAge_w$AGE),by=list(YEAR=FAge_w$YEAR),FUN=sum)
  x<-subset(x,x$NUMBER >=MINAGE)
  x<-unique(x$YEAR)
  FAge_w<-subset(FAge_w,FAge_w$YEAR%in%x)
  FLength_w<-subset(FLength,FLength$YEAR%in%x)
  remove(x)

  FAge_w$SEX1<-FAge_w$SEX
  FAge_w$SEX<-as.character(FAge_w$SEX)
  FAge_w$SEX[FAge_w$SEX1=="M"]=1
  FAge_w$SEX[FAge_w$SEX1=='F']=2
  FAge_w$SEX[FAge_w$SEX1=='U']=3
  FAge_w$LENGTH<-FAge_w$LENGTH*10
  FAge_w$WEIGHT<-FAge_w$WEIGHT*1000

  FLength_w$SEX1<-FLength_w$SEX
  FLength_w$SEX<-as.character(FLength_w$SEX)
  FLength_w$SEX[FLength_w$SEX1=='M']=1
  FLength_w$SEX[FLength_w$SEX1=='F']=2
  FLength_w$SEX[FLength_w$SEX1=='U']=3
  FLength_w$LENGTH<-FLength_w$LENGTH*10

  F_Total_AGE<-AGE_LENGTH(adata=FAge_w,ldata=FLength_w,fyear=fyear,type="F")

## Fishery Catch Data
  source("get_catch.r")

  GET_CATCH(area="AI",species="'PLCK'",FYR=fyear,ADD_OLD=TRUE,OLD_FILE="OLD_CATCH.csv")

  CATCH<-GET_CATCH(FYR=fyear)
  CATCH<-subset(CATCH,CATCH$YEAR<=fyear)

  F_Total_WB<-merge(F_Total_AGE$Total_AGE,CATCH,all.x=T)
  F_Total_WB<-F_Total_WB[order(F_Total_WB$YEAR,F_Total_WB$AGE),]

  F_Total_WB$N_AGE<-F_Total_WB$PROB*F_Total_WB$TONS/F_Total_WB$WEIGHT2*1000000
  F_Total_WB$W_AGE<-F_Total_WB$PROB*F_Total_WB$TONS

  F_total<-aggregate(list(FREQ=F_Total_AGE$Total_AGE$FREQ),by=list(YEAR=F_Total_AGE$Total_AGE$YEAR,AGE=F_Total_AGE$Total_AGE$AGE),FUN=sum)
  F_number<-aggregate(list(NUMBER=F_Total_AGE$Total_AGE$FREQ),by=list(YEAR=F_Total_AGE$Total_AGE$YEAR),FUN=sum)
  F_total<-merge(F_total,F_number)
  F_total$PROB<-F_total$FREQ/F_total$NUMBER
  F_total<-F_total[order(F_total$YEAR,F_total$AGE),]

  years<-sort(unique(F_total$YEAR))

  F_NAGE<-data.frame(matrix(ncol=15,nrow=length(years)))
  names(F_NAGE)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
  F_NAGE$YEAR<-years

 for( i in 1:length(F_NAGE$YEAR)){
  F_NAGE[i,2:15]<-F_total$PROB[F_total$YEAR==F_NAGE$YEAR[i]][1:14]
  }

## population weight at age
  test<-gam(log(WEIGHT)~s(AGE1),gamma=1.4,data=subset(Age_w,Age_w$YEAR>2002))
  PP_WEIGHT_AGE<-exp(predict(test,newdata=data.frame(AGE1=c(2:15))))

## get fishery length sample size
SS=get_FSS()
ss<-rbind(get_FSS(),get_DSS())
ss<-aggregate(list(SS=ss$SS),by=list(YEAR=ss$YEAR),FUN=sum)
ss<-subset(ss,ss$YEAR %in% F_NAGE$YEAR)
ss$SS[ss$YEAR>=2006]<-100

## Data set
  ##Start YEAR
  AI_DATA<-list(SY=1978,EY=fyear,FAC=2,LAC=15,NF=1,
  F_NAME=noquote("Aleutians"),
  CATCH=CATCH,
  Catch_CV=rep(0.05,length(unique(CATCH$YEAR) )),
  F_NAGE=F_NAGE,
  F_MN_SIZE=round(ss$SS),
  F_WEIGHT=F_Total_AGE$F_WEIGHT,
  NS=1,
  S_name=noquote("NMFS_summer_bottom_trawl"),
  S_BIO=survey_biomass,
  S_MN_SIZE=c(1,1,1,100,100,100,100,100,100,100),
  S_WEIGHT=TOTAL_AGE$S_WEIGHT,
  S_NAGE=subset(S_NAGE,S_NAGE > 1980),
  PP_WEIGHT_AGE=PP_WEIGHT_AGE,
  GMat= read.csv("GOA_MAT.csv",header=F),
  MSPWN=3,
  AERR=read.csv("AGEING_ERROR.csv",header=F),
  FILENAME=filename
  )
 if(WRITE==TRUE){
  write_dat(data=AI_DATA,data_file=filename)
  }
 AI_DATA
}


## this reads the data path, check if all files exist, group animals following metadata entries and create a minute summary spreadsheet
## it exclude entries, create time windows and make summaries for each time window from the minute summary data.
source ("Rcode/get_behav_gp.r")

#get rid of columns with NA (distance traveled if data comes from mbr)
Multi_datainput_m = Multi_datainput_m[, !colSums(is.na(Multi_datainput_m)) >
                                        0]

#multidimensional analysis, Random forest in 2 rounds result will be used for ICA code below
source ("Rcode/RF_selection_2rounds.r")# returns RF_selec = Input
source ("Rcode/ICA.r") # return plot called pls

#multidimensional analysis, PCA followed by wilocoxon test on 1st component, and effect size calculation
source ("Rcode/PCA_strategy.r")

## SVM procedure
set.seed(74)
## put this to FALSE if you want to get more tests and not overwrite Acc_sampled, only works if not using the shiny app.
if (TRUE) Acc_sampled = c()

source ("Rcode/svmtest.r")
if (!NO_svm){ source ("Rcode/svmperf.r") } # SVM done only if asked in app, and there is enough data.

if (length(unique(metadata$groupingvar)) == 3) {
  rmarkdown::render ("reports/multidim_anal_variable2.Rmd", output_file = "multidim_anal_variable.html")
} else {rmarkdown::render ("reports/multidim_anal_variable.Rmd")}

# save reports in the correct output folder.
file.copy(
  "reports/multidim_anal_variable.html",
  paste0(Outputs, "/Bseq", Name_project, groupingby, ".html"),
  overwrite = TRUE,
  copy.mode = TRUE,
  copy.date = FALSE
)

# save image in the same correct output folder, do not work if shiny app is used.
save.image(file = "reports/results.rdata")
file.copy(
  "reports/results.rdata",
  paste0(Outputs, "/Bseq", Name_project, groupingby, ".Rdata"),
  overwrite = TRUE,
  copy.mode = TRUE,
  copy.date = FALSE
)

## make a sound when it is finished
beepr::beep()


library(pedtools)
library(segregatr)

PEN_FILE <- "penetrances/penetrances_Belman_1998_2002.tsv"

COLNAMES <- c("FamID", "Name", "Target", "IndivID", "FathID", "MothID", "Sex", "MZtwin", "Dead", "Age", "Yob", "BC1", "BC2", "OC", "PRO", "PAN", "Ashkn", "BRCA1", "BRCA2", "PALB2", "ATM", "CHEK2", "BARD1", "RAD51D", "RAD51C", "BRIP1", "ER:PR:HER2:CK14:CK56")

DATA <- read.table("example_data/example1.txt", col.names=COLNAMES)

#TODO define cancer entities to consider
BrCa <- T
OvCa <- T
PanCa <- T
ProCa <- T
#TODO Gene/Frequency parameter handling
GENE <- "BRCA1"
FREQ <- 0.001

#TODO check for unique individual names
#TODO check for !=1 probands: proband=x$ID[which(DATA$Target==1)]

### write ped data.frame

id <- DATA["Name"][,1] # ids have to be unique (and will be used for fid/mid columns
#TODO check for doubled ids
id_ind = 1
for (i in seq(length(id)))
	if (id[i] == "0"){
		id[i] <- id_ind
		id_ind <- id_ind+1
	}

fid <- DATA["FathID"][,1]
mid <- DATA["MothID"][,1]
# fill fid/mid with ids
for (i in seq(length(id))){
	if (fid[i] != "0"){
		#cat(i, fid[i], id[as.integer(fid[i])], class(id[as.integer(fid[i])]), "\n")
		fid[i] <- id[as.integer(fid[i])]
	}
	if (mid[i] != "0"){
		#cat(i, mid[i], id[mid[i]], class(id[mid[i]]), "\n")
		mid[i] <- id[as.integer(mid[i])]
	}
}

sex <- DATA["Sex"] # M/F due to CanRisk, has to be converted into M=1, F=2
sex[which(sex == "M"),] <- 1
sex[which(sex == "F"),] <- 2

PED <- data.frame(id, fid, mid, sex)
#TODO define file name & flag for saving file
write.table(PED, 'tmp.ped', append = FALSE, sep = "\t", dec = ".", row.names = FALSE, col.names = TRUE)

x <- readPed("tmp.ped") #TODO delete

#carriers: A character vector (or coercible to such), containing the ID
#          labels of pedigree members known to carry the variant in
#          question.

#noncarriers: A character vector (or coercible to such), containing the
#          ID labels of pedigree members known _not_ to carry the
#          variant in question.

#    freq: A single number strictly between 0 and 1: the population
#          frequency of the observed allele.

#affected: The affected pedigree members.

# unknown: Pedigree members with unknown affection status.

# proband: The ID label of the proband. This person must also be in both
#          ‘carriers’ and ‘affected’.

#penetrances: Either a numeric vector of length 3, corresponding to (f0,
#          f1, f2) or a matrix or data frame with 3 columns. Each row
#          contains the penetrance values of a liability class.

#liability: A vector of length ‘pedsize(x)’, containing for each
#          pedigree member the row number of ‘penetrances’ which should
#          be used for that individual. (If ‘penetrances’ is just a
#          vector, it will be used for all classes.) If ‘liability’ is
#          NULL (the default), it is set to ‘1’ for all individuals.

PENETRANCES <- read.table(PEN_FILE, header=T)

CARRIERS <- x$ID[c(which(DATA[GENE] == "T:P"), which(DATA[GENE] == "S:P"))] #DONE
NONCARRIERS <- x$ID[c(which(DATA[GENE] == "T:N"), which(DATA[GENE] == "S:N"))]
AFFECTED <- c()
UNKNOWN <- c() #refers to affection status

# Penetrance matrix will have one entry per individual, hence liability vector is pre-defined
LIAB <- seq(pedsize(x)) #DONE
PENMAT <- matrix(ncol=3, nrow=0)
colnames(PENMAT) <- c("f0", "f1", "f2")

### TEST
#for (i in seq(pedsize(x))){
#	PENMAT <- rbind(PENMAT, c(f0=0, f1=0.5, f2=0.5))
#}
for (i in seq(pedsize(x))){

	if (DATA[i,]$Age == 0){
		UNKNOWN <- c(UNKNOWN, x$ID[i])
		mat <- PENETRANCES[PENETRANCES$GENE == GENE,]
		if (x$SEX[i] == 1){
			# male
			mat <- mat[mat$SEX == "male",]
		}
		else {
			mat <- mat[mat$SEX == "female",]
		}
		mat <- mat[mat$CANCER == "unaff",]
		mat <- mat[(mat$AGE_LOW <= 20) & (20 <= mat$AGE_HIGH),]
		#PENMAT[i,1:3] = mat[1,6:8]
		PENMAT <- rbind(PENMAT, mat[1,6:8])
	}
	else{
		agevec = c(DATA[i,]$Age, DATA[i,]$BC1, DATA[i,]$OC, DATA[i,]$PRO, DATA[i,]$PAN)
		agevec[which(agevec==0)] <- Inf

		entity <- c("BrCa", "OvCa", "ProCa", "PanCa")
		age <- c(DATA[i,]$BC1, DATA[i,]$OC, DATA[i,]$PRO, DATA[i,]$PAN)
		flag <- c(BrCa, OvCa, ProCa, PanCa)
		df <- data.frame(entity, age, flag)
		aff_df <- df[(df$age>0) & df$flag,]

		# UNAFFECTED
		if (length(aff_df[,1]) == 0){
			cat(x$ID[i], "unaffected", '\n')

			#_mat <- PENETRANCES[PENETRANCES$GENE == GENE & PENETRANCES$SEX == "male" & PENETRANCES$CANCER == "unaff",]
			mat <- PENETRANCES[PENETRANCES$GENE == GENE,]
			rownames(mat) <- c()
			if (x$SEX[i] == 1){
				# male
				mat <- mat[mat$SEX == "male",]
				cat('... and male\n') #DEBUG
			}
			else {
				mat <- mat[mat$SEX == "female",]
				cat('... and female\n') #DEBUG
			}
			mat <- mat[mat$CANCER == "unaff",]
			mat <- mat[(mat$AGE_LOW <= agevec[1]) & (agevec[1] <= mat$AGE_HIGH),]
			#PENMAT[i,1:3] = mat[1,6:8]
			PENMAT <- rbind(PENMAT, mat[1,6:8])
		}

		# AFFECTED
		else{
			# get min age
			aff_df <- aff_df[which(aff_df$age == min(aff_df$age)),]
			print(aff_df)
			if (length(aff_df[,1]) == 1){
				ent <- aff_df$entity[1]
				cat(x$ID[i], "affected with", ent, '\n')
				mat <- PENETRANCES[PENETRANCES$GENE == GENE,]
				if (x$SEX[i] == 1){
					# male
					mat <- mat[mat$SEX == "male",]
					cat('... and male\n') #DEBUG
				}
				else {
					mat <- mat[mat$SEX == "female",]
					cat('... and female\n') #DEBUG
				}
				mat <- mat[mat$CANCER == ent,]
				mat <- mat[(mat$AGE_LOW <= aff_df$age[1]) & (aff_df$age[1] <= mat$AGE_HIGH),]
				PENMAT <- rbind(PENMAT, mat[1,6:8])

				AFFECTED <- c(AFFECTED, x$ID[i])

			}
			else{
				#TODO
				cat(x$ID[i], "affected with several cancer entities at same age", '\n')
				print(aff_df)
				stop()
			}

		}

	}
}

#FLB(x, carriers=CARRIERS, noncarriers=NONCARRIERS, freq=FREQ, affected=AFFECTED, unknown=UNKNOWN, proband=x$ID[which(DATA$Target==1)], penetrances = PENMAT, liability=LIAB)


#!/usr/bin/env Rscript
# Perform differential gene expression on a SingleCellExperiment Object
#  Combiz Khozoie <c.khozoie@imperial.ac.uk>

#   ____________________________________________________________________________
#   Initialization                                                          ####

##  ............................................................................
##  Load packages                                                           ####
library(argparse)
library(cli)
# Note: scFlow is loaded after the mc.cores option is defined/overriden below

##  ............................................................................
##  Parse command-line arguments                                            ####

# create parser object
parser <- ArgumentParser()

# specify options
required <- parser$add_argument_group("Required", "required arguments")
optional <- parser$add_argument_group("Optional", "required arguments")

required$add_argument(
  "--sce",
  help = "path to SingleCellExperiment directory",
  metavar = "/dir/sce/",
  required = TRUE
)

required$add_argument(
  "--celltype",
  help = "celltype to subset for DE analysis",
  metavar = "DESEQ2PB",
  required = TRUE
)

required$add_argument(
  "--de_method",
  help = "differential gene expression method",
  metavar = "MAST",
  required = TRUE
)

required$add_argument(
  "--mast_method",
  help = "differential gene expression sub-method for MAST",
  metavar = "bayesglm",
  required = TRUE
)

required$add_argument(
  "--min_counts",
  type = "integer",
  default = 1,
  help = "minimum library size (counts) per cell",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--min_cells_pc",
  type = "double",
  default = 0.10,
  metavar = "N",
  help = "minimum percentage of cells with min_counts"
)

required$add_argument(
  "--rescale_numerics",
  help = "rescale numeric variables in the model (lgl)",
  metavar = "TRUE",
  required = TRUE
)

required$add_argument(
  "--pseudobulk",
  help = "perform pseudobulking option (lgl)",
  metavar = "TRUE",
  required = TRUE
)

required$add_argument(
  "--celltype_var",
  help = "celltype variable",
  metavar = "cluster_celltype",
  required = TRUE
)

required$add_argument(
  "--sample_var",
  help = "sample variable",
  metavar = "manifest",
  required = TRUE
)

required$add_argument(
  "--force_run",
  help = "force run if non-full-rank (lgl)",
  metavar = "TRUE",
  required = TRUE
)

required$add_argument(
  "--dependent_var",
  help = "dependent variable",
  metavar = "group",
  required = TRUE
)

required$add_argument(
  "--ref_class",
  help = "reference class within dependent variable",
  metavar = "Control",
  required = TRUE
)

required$add_argument(
  "--confounding_vars",
  help = "confounding variables",
  metavar = "age,sex,pc_mito",
  required = TRUE
)

required$add_argument(
  "--random_effects_var",
  help = "random effects variable",
  metavar = "individual",
  required = TRUE
)

required$add_argument(
  "--fc_threshold",
  type = "double",
  default = 1.1,
  metavar = "number",
  help = "Absolute fold-change cutoff for DE [default %(default)s]"
)

required$add_argument(
  "--pval_cutoff",
  type = "double",
  default = 0.05,
  metavar = "number",
  help = "p-value cutoff for DE [default %(default)s]"
)

required$add_argument(
  "--ensembl_mappings",
  help = "path to ensembl mappings file",
  metavar = "tsv",
  required = TRUE
)

required$add_argument(
  "--species",
  help = "the biological species (e.g. mouse, human)",
  default = "human",
  required = TRUE
)

required$add_argument(
  "--max_cores",
  default = NULL,
  help = "override for lower cpu core usage",
  metavar = "N",
  required = TRUE
)

# get command line options, if help option encountered print help and exit,
# otherwise if options not found on command line then set defaults
args <- parser$parse_args()

options("scflow_species" = args$species)

args$rescale_numerics <- as.logical(args$rescale_numerics)
args$pseudobulk <- as.logical(args$pseudobulk)
args$force_run <- as.logical(args$force_run)
if (tolower(args$random_effects_var) == "null") args$random_effects_var <- NULL

args$max_cores <- if (toupper(args$max_cores) == "NULL") NULL else {
  as.numeric(as.character(args$max_cores))
}

args$confounding_vars <- strsplit(args$confounding_vars, ",")[[1]]

#   ____________________________________________________________________________
#   Delay Package Loading for Optional Max Cores Override

n_cores <- future::availableCores(methods = "mc.cores")

if (is.null(args$max_cores)) {
  options(mc.cores = n_cores)
} else {
  options(mc.cores = min(args$max_cores, n_cores))
}

cli::cli_alert(sprintf(
  "Using %s cores on system with %s available cores.",
  getOption("mc.cores"),
  n_cores
))

library(scFlow)

#   ____________________________________________________________________________
#   Start DE                                                                ####

write(sprintf(
  "##### Starting DE of %s cells with %s",
  args$celltype, args$demethod
), stdout())

sce <- read_sce(args$sce)

sce_subset <- sce[, sce$cluster_celltype == args$celltype]

if (args$pseudobulk) {
  pb_str <- "_pb"
  sce_subset <- pseudobulk_sce(
    sce_subset,
    keep_vars = c(
      args$dependent_var, args$confounding_vars, args$random_effects_var
      ),
    assay_name = "counts",
    celltype_var = args$celltype_var,
    sample_var = args$sample_var
  )
} else {
  pb_str <- ""
}

de_results <- perform_de(
  sce_subset,
  de_method = args$de_method,
  min_counts = args$min_counts,
  min_cells_pc = args$min_cells_pc,
  rescale_numerics = args$rescale_numerics,
  dependent_var = args$dependent_var,
  ref_class = args$ref_class,
  confounding_vars = args$confounding_vars,
  random_effects_var = args$random_effects_var,
  fc_threshold = args$fc_threshold,
  pval_cutoff = args$pval_cutoff,
  mast_method = args$mast_method,
  force_run = args$force_run,
  ensembl_mapping_file = args$ensembl_mappings,
  species = getOption("scflow_species")
)

file_name <- paste0(args$celltype, "_",
                    args$de_method, pb_str, "_")

for (result in names(de_results)) {
  if (dim(de_results[[result]])[[1]] > 0) {
    write.table(de_results[[result]],
                file = file.path(getwd(),
                                paste0(file_name, result, "_DE.tsv")),
                quote = FALSE, sep = "\t", col.names = TRUE, row.names = FALSE)
    report_de(de_results[[result]],
              report_folder_path = file.path(getwd()),
              report_file = paste0(file_name, result, "_scflow_de_report"))
    print("report generated")
    png(file.path(getwd(),
                  paste0(file_name, result, "_volcano_plot.png")),
        width = 247, height = 170, units = "mm", res = 600)
    print(attr(de_results[[result]], "plot"))
    dev.off()

  } else {
    print(sprintf("No DE genes found for %s", result))
    }
}


#Uses devel version of AlphaSimR '0.3.0'
# > devtools::install_bitbucket("hickeyjohnteam/AlphaSimR", args = '--library=.')
library(AlphaSimR)

options(scipen=999)
args = commandArgs(trailingOnly=TRUE)
args = c("200", "1", "GBS")
nHD = as.numeric(args[1])
coverage = as.numeric(args[2])
parentStatus = args[3]

# print(args)
founderPop = runMacs(nInd = 100, nChr = 1, segSites = 200, inbred=FALSE, species="CATTLE")
# founderPop = runMacs(nInd = 100, nChr = 1, segSites = 1000, inbred=FALSE)

# ---- Set Simulation Parameters ----

SP = SimParam$new(founderPop)
SP$addSnpChip(nSnpPerChr=200)

gen0 = newPop(founderPop)

gen_parents = randCross(gen0, nCrosses = 10, nProgeny = 1)
ids = gen_parents@id

fathers = rep(1:5, each = 20)
mothers = rep(6:10, each = 20)

cross_plan = data.frame(fathers, mothers)

gen_offspring = makeCross(gen_parents, cross_plan)
output = c(gen_parents, gen_offspring)

write.table2 = function(x, file, ...) {
    write.table(x, paste0("example/", file), col.names=F, row.names=F,quote=F,...)
}

# PEDIGREE

ped_parents = data.frame(id = paste0("ind_", gen_parents@id), father = 0, mother = 0, stringsAsFactors = FALSE)
ped_offspring = data.frame(id = paste0("ind_", gen_offspring@id), father = paste0("ind_", gen_offspring@father), mother = paste0("ind_", gen_offspring@mother), stringsAsFactors = FALSE)
pedigree = rbind(ped_parents, ped_offspring)
write.table2(pedigree, "pedigree.txt")

write.table2(paste0("ind_", gen_offspring@id), "offspring.txt")

# GENOTYPES

genotypes_parents = AlphaSimR::pullSnpGeno(gen_parents, 1)
genotypes_offspring = AlphaSimR::pullSnpGeno(gen_offspring, 1)
genotypes = AlphaSimR::pullSnpGeno(output, 1)
write.table2(cbind(pedigree[,1], genotypes), "true_genotypes.txt")

### CREATE MASKED LD GENOTYPES

fam_id = paste(pedigree[,2], pedigree[,3], sep = "_")

families = unique(fam_id) # Create a list of full-sib families.
families = setdiff(families, "0_0") # Remove the founders.

n_hd_ind = 10
n_ld_snp = 50

ld_snps = c(1, floor(seq(2, ncol(genotypes), length.out = n_ld_snp)))

masked_genotypes = genotypes

for(fam in families) {

    individuals = which(fam_id == fam)
    hd_ind = individuals[1:n_hd_ind]
    ld_ind = individuals[(n_hd_ind + 1):length(individuals)]

    masked_genotypes[ld_ind, -ld_snps] = 9

}

write.table2(cbind(pedigree[,1], masked_genotypes), "masked_genotypes.txt")

# HAPLOTYPES

haplotypes = AlphaSimR::pullSnpHaplo(output, 1)

# Swap the haplotype values to be consistent with other software
indexes = lapply(1:nrow(genotypes), function(index) {
    val0 = (index -1)*2 + 1
    val1 = (index -1)*2 + 2
    return(c(val1, val0))
})
indexes = do.call("c", indexes)
haplotypes = haplotypes[indexes,]

gbsRandom = function(id, genotype, coverage) {
    nSnp = length(genotype)

    counts = rpois(nSnp, coverage)
    error = 0.001
    probs = (1-error) * as.numeric(genotype)/2.0 + error/2

    altReads = rbinom(nSnp, counts, prob = probs)
    values = matrix(c(id, counts-altReads, id, altReads), nrow = 2, byrow=TRUE)

    if(length(sequence) == 0) {
        sequence <<- values
    }
    else{
        sequence <<- rbind(sequence, values)
    }
}

sequence = c()

generate_sequence_data = function(pedigree, genotypes, coverage) {

    nInd = nrow(pedigree)
    for(i in 1:nInd){
        gbsRandom(pedigree[i, 1], genotypes[i,], coverage)
    }

}

if(parentStatus == "GBS") {
    generate_sequence_data(ped_parents, genotypes_parents, coverage)
}

if(parentStatus == "HD") {
    generate_sequence_data(ped_parents, genotypes_parents, 25)
}
if(parentStatus == "ND") {
    generate_sequence_data(ped_parents, genotypes_parents, 0)
}

generate_sequence_data(ped_offspring, genotypes_offspring, coverage)

write.table2(sequence, "sequence.txt")


## init
library(readr)

## load STAN params
#load('dat/params.RData')
load('dat/params_all.RData')

## load evidence
ev <- read_tsv('dat/evidence.txt')
#ev.f <- ev[ev$PEP < 0.05, c('Sequence',
ev.f <- ev[, c('Sequence',
                            'Proteins', 'Leading razor protein',
                            'Raw file', 'Retention time', 'PEP',
                            'Peptide ID', 'Best MS/MS')]
colnames(ev.f) <- c('Sequence','Proteins','Razor.protein',
                    'Raw.file','Retention.time','PEP', 'Peptide.ID', 'Obs.ID')

# get experiment ids
experiment_factors <- as.factor(ev.f$Raw.file)
experiment_id <- as.numeric(experiment_factors)
num_exps = max(experiment_id)
# get peptide ids
true_peptide_id <- ev.f$Peptide.ID
peptide_id <- as.numeric(as.factor(true_peptide_id))
# observation IDs
obs_id <- as.numeric(ev.f$Obs.ID)

retention_times <- ev.f$Retention.time

# map muij to experiments and peptides
pep_exp_all <- paste(peptide_id, experiment_id, sep=" - ")
pep_exp_pairs <- unique(pep_exp_all)
num_pep_exp_pairs <- length(pep_exp_pairs)
muij_map <- match(paste(peptide_id, experiment_id, sep=" - "), pep_exp_pairs)
splt <- strsplit(pep_exp_pairs, " - ")
muij_to_pep <- as.numeric(sapply(splt, function(x) x[1]))
muij_to_exp <- as.numeric(sapply(splt, function(x) x[2]))

# output table
ev.new <- data.frame(
  Obs.ID=numeric(),
  rt.minus=numeric(),
  rt.plus=numeric(),
  muijs=numeric(),
  sigmas=numeric(),
  PEP.new=numeric()
)

print('Processing...')
for (i in 1:num_exps) {
  # counter also doubles as experiment_id
  exp_id <- i
  # get exp subset of ev.f
  exp <- subset(ev.f, experiment_id==exp_id)
  exp_name <- exp$Raw.file[1]

  cat('\r', i, '/', num_exps, exp_name, '                           ')
  flush.console()

  # some experiments have very few rows??? skip these
  if(dim(exp)[1] < 10) next

  # unique peptide_ids of peptides in this experiment
  exp.peptide.map = peptide_id[experiment_id==exp_id]
  exp.peptides = unique(exp.peptide.map)
  # also get true_peptide_id so we can fetch more data from
  # the original data frame
  exp.true.peptide.map = true_peptide_id[experiment_id==exp_id]

  # retention times for this experiment
  exp.rts <- retention_times[experiment_id==exp_id]
  # adjusted mean retention times, for peptide i in experiment j
  muijs <- pars[sprintf('muij[%i]', which(muij_to_exp==exp_id))]
  # NOTE: need to disable scientific notation since
  #       weird "e" tricks will break indexing later
  names(muijs) <- format(exp.peptides, trim=TRUE, scientific=FALSE)
  # adjusted retention time standard deviations (not experiment specific)
  sigmas <- pars[sprintf('sigma[%i]', exp.peptides)]
  names(sigmas) <- gsub('[^0-9]', '', names(sigmas))

  # PEP.new = P(-|RT) = P(RT|-)*P(-) / (P(RT|-)*P(-) + P(RT|+)*P(+)
  # + <- PSM=Correct
  # - <- PSM=Incorrect

  # P(RT|-) = probability of peptides RT, given that PSM is incorrect
  #           calculated from the empirical distribution of all RTs (rt.edf)
  exp.rt.edf <- density(exp.rts)
  exp.rt.minus <- approx(exp.rt.edf$x, exp.rt.edf$y, xout=exp.rts)$y

  # P(-) = probability that PSM is incorrect (PEP)
  # P(+) = probability that PSM is correct (1-PEP)

  # P(RT|+) = probability that given the correct ID, the RT falls in the
  #           lognormal distribution of RTs for that peptide, for that experiment
  exp.rt.plus <- unlist(sapply(exp.peptides, function(id) {
    # NOTE: more non-scientific formatting as described above
    pid <- format(id, trim=TRUE, scientific=FALSE)

    rts <- exp.rts[exp.peptide.map==id]
    muij <- muijs[as.character(pid)]
    sigma <- sigmas[as.character(pid)]
    dnorm(rts, mean=muij, sd=sigma)
  }))

  exp.PEP <- exp$PEP
  # sometimes MQ will output PEP > 1, which makes no sense, and will
  # result in negative values for our adjusted PEP
  # set all PEP > 1 to PEP = 1
  exp.PEP[exp.PEP > 1] <- 1

  # now we can update the PEP
  PEP.new <- (exp.rt.minus*exp.PEP) /
    ((exp.rt.minus*exp.PEP) + (exp.rt.plus*(1-exp.PEP)))

  #hist(PEP.new[PEP.new<0.1], breaks=seq(0, 0.1, by=0.001), main=i)

  # output table for this experiment
  exp.new <- data.frame(
    Obs.ID=as.numeric(exp$Obs.ID),
    rt.minus=as.numeric(exp.rt.minus),
    rt.plus=as.numeric(exp.rt.plus),
    muijs=as.numeric(muijs[match(exp.peptide.map, as.numeric(names(muijs)))]),
    sigmas=as.numeric(sigmas[match(exp.peptide.map, as.numeric(names(sigmas)))]),
    PEP.new=as.numeric(PEP.new)
  )
  # append to master output table
  ev.new <- rbind(ev.new, exp.new)
}

# remove experiments with few observations
# (7/4/17 quick fix until STAN can be run again with better params)
ev <- ev[-which(experiment_id==61),]

# reorder ev.new in the same fashion as the original ev
ev.new.f <- ev.new[order(ev.new$Obs.ID),]
rownames(ev.new.f) <- NULL

# combine ev and ev.new
ev.adjusted <- cbind(ev, ev.new.f)
# remove some columns we dont need
ev.adjusted <- ev.adjusted[,!(names(ev.adjusted) %in%
                                c('Obs.ID'))]

write.table(ev.adjusted, 'dat/ev.adjusted.txt', sep='\t', row.names=FALSE, quote=FALSE)

ev.ff <- ev.adjusted[, c('Sequence', 'Proteins', 'Leading razor protein', 'Raw file',
                'Retention time', 'Retention length', 'PIF', 'PEP', 'Intensity',
                'Reporter intensity corrected 0', 'Reporter intensity corrected 1',
                'Reporter intensity corrected 2', 'Reporter intensity corrected 3',
                'Reporter intensity corrected 4', 'Reporter intensity corrected 5',
                'Reporter intensity corrected 6', 'Reporter intensity corrected 7',
                'Reporter intensity corrected 8', 'Reporter intensity corrected 9',
                'Reverse', 'Peptide ID',
                'rt.minus', 'rt.plus', 'muijs', 'sigmas', 'PEP.new')]
write.table(ev.ff, 'dat/ev.adj.txt', sep='\t', row.names=FALSE, quote=FALSE)


library(ggplot2)
library(compiler)
enableJIT(3)
library(ggplot2)
library("Cairo")

data =read.table("align.tab")

data = data[which(data$V1 %in% c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10" )),]
data = data[which(data$V3 %in% c("chr1", "chr2", "chr3", "chr4", "chr5", "chr6", "chr7", "chr8", "chr9", "chr10" )),]
data$V1 = factor(data$V1, levels=c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10" ))
data$V3 = factor(data$V3, levels=c("chr1", "chr2", "chr3", "chr4", "chr5", "chr6", "chr7", "chr8", "chr9", "chr10" ))

g = ggplot(data=data, aes(x=V4, y=V2))+geom_point(size=0.5, aes(color=V5))+facet_grid(V1~V3, scales="free", space="free" )+ theme_grey(base_size = 60) +
    labs(x="Arabidopsis thaliana", y="Brassica rapa")+
    theme(axis.line = element_line(colour = "black"),
    panel.background = element_blank(),
    panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
    axis.text.y = element_text( colour = "black"),
    legend.position='none',
    axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black") )

CairoPNG(file="align.png",width = 6000, height = 3500)
print(g)
dev.off()


##
## Initialisation variables, functions, etc.
##
library(tidyverse)
# library(readxl)
# library(data.table)
library(igraph)
library(futile.logger)

flog.info("Initialising...")

##
## directories for loading/saving stuff
##
data.dir    = "./data"
plots.dir   = "./plots"
results.dir = "./results"
models.dir  = "./models"

# create the directories if they don't exist
if (!dir.exists(plots.dir))
  dir.create(plots.dir)
if (!dir.exists(results.dir))
  dir.create(results.dir)
if (!dir.exists(models.dir))
  dir.create(models.dir)

############################################################################
## Import all data
##
flog.info("Importing data files...")

herders      = read.csv(file.path(data.dir, "herders.csv"))
herders.wide = read.csv(file.path(data.dir, "herders-dyadic-wide.csv"))
gifts        = read.csv(file.path(data.dir, "gifts.csv"))
net.maps     = read.csv(file.path(data.dir, "net-maps.csv"))

##
## some useful lists
##
interviewee_list = subset(herders, Interviewed.==1)$HerderID  # people we interviewed (list everyone, including unlicensed herders but *not* people in district 30C)
netmappers_list  = unique(net.maps$Interviewee)               # people who drew net-maps

############################################################################
## Create social networks
##
flog.info("Creating social networks...")

##
## First, a bit of data wrangling
##
# make dataframe containing outbound connections only
net.maps.o = filter(net.maps, Alter!=Interviewee) %>% dplyr::select(Ego, Alter, LinkType)
## in this case, in-degree will be a measure of help received, as reported by others
## and out-degree will be the amount of self-reported help given to others
#... inbound connections only
net.maps.i = filter(net.maps, Alter==Interviewee) %>% dplyr::select(Ego, Alter, LinkType)
## in this case, in-degree will be a self-reported measure of help received
## and out-degree will be the amount of help given, as reported by others

# keep only one entry for each Ego-Alter pair, rather than separate entries for each help type
# (this would have the same effect as using igraph::simplify())
coop.net   = unique(subset(net.maps,   select=c(Ego, Alter)))
coop.net.o = unique(subset(net.maps.o, select=c(Ego, Alter)))
coop.net.i = unique(subset(net.maps.i, select=c(Ego, Alter)))

##
## create networks
##
# siida membership
siida.mem = subset( herders.wide, SameSiida==1, select=c(Ego, Alter) )
g.siida = graph.data.frame(siida.mem, vertices=herders, directed=T)
rm(siida.mem)

# relatives
kin = subset( herders.wide, r>0, select=c(Ego, Alter, r) )  # this overwrites the previous `kin` df that was created from the net maps (and, thus, was incomplete)
kin$Weight = kin$r
g.kin = graph.data.frame(kin, vertices=herders, directed=T)

# gifts (the `gifts` dataframe was created directly from the netmap, towards the beginning of this file)
gifts$Weight = gifts$GiftSize
g.gifts = graph.data.frame(gifts, vertices=herders, directed=T)

# net-maps with interviewees' outbound connections only
g.netmap.o = graph.data.frame(coop.net.o, vertices=herders, directed=T)

# net-maps with interviewees' inbound connections only
g.netmap.i = graph.data.frame(coop.net.i, vertices=herders, directed=T)

# net-map with everything
g.all = graph.data.frame(coop.net, vertices = herders, directed = T)

##
## make graphs of each type of net-map (self-reported outbound connections only)
##
net.maps.advice  = subset(net.maps.o, LinkType=="Advice", select=c(Ego, Alter))
net.maps.help    = subset(net.maps.o, LinkType=="Help",   select=c(Ego, Alter))
net.maps.sharing = subset(net.maps.o, LinkType=="Items",  select=c(Ego, Alter))

g.advice  = simplify( graph.data.frame( net.maps.advice,  vertices=herders, directed=T) )
g.help    = simplify( graph.data.frame( net.maps.help,    vertices=herders, directed=T) )
g.sharing = simplify( graph.data.frame( net.maps.sharing, vertices=herders, directed=T) )

# don't need these anymore
rm(coop.net.i, coop.net.o)
rm(net.maps.i, net.maps.o)

#######################################################################################
## Calculate centrality measures (in/out degrees)
##
flog.info("Calculating network statistics...")

## there are four measures of degree in the cooperative network:
##
## - cooperation given from ego to alter, as reported by ego (`herders$CoopGiven.SelfReport` which is out-degree in `g.netmap.o`)
## - cooperation given from ego to alter, as reported by alter (`herders$CoopGiven.OtherReport` which is out-degree in `g.netmap.i`)
## - cooperation received by ego from alter, as reported by ego (`herders$CoopReceived.SelfReport` which is in-degree in `g.netmap.i`)
## - cooperation received by ego from alter, as reported by alter (`herders$CoopReceived.OthersReport` which is in-degree in `g.netmap.o`)
##
# cooperation from outbound links (in-degree = cooperation received, reported by others; out-degree = cooperation given, reported by self)
deg.in  = degree(g.netmap.o, mode="in")
herders$CoopReceived.OthersReport = deg.in[ as.character(herders$HerderID) ]
deg.out = degree(g.netmap.o, mode="out")
herders$CoopGiven.SelfReport = deg.out[ as.character(herders$HerderID) ]

# cooperation from inbound links (in-degree = cooperation received, reported by self; out-degree = cooperation given, reported by others)
deg.in  = degree(g.netmap.i, mode="in")
herders$CoopReceived.SelfReport = deg.in[ as.character(herders$HerderID) ]
deg.out = degree(g.netmap.i, mode="out")
herders$CoopGiven.OtherReport = deg.out[ as.character(herders$HerderID) ]

# cooperation from complete network
deg.in  = degree(g.all, mode="in")
herders$coop.deg.in = deg.in[ as.character(herders$HerderID) ]
deg.out = degree(g.all, mode="out")
herders$coop.deg.out = deg.out[ as.character(herders$HerderID) ]

# no. gifts received
deg.in  = degree(g.gifts, mode="in")
herders$NumGifts = deg.in[ as.character(herders$HerderID) ]
herders$gifts.bin = ifelse(herders$NumGifts > 0, 1, 0)  # also create a binary variable for whether/not they received a gift

# no. gifts given
deg.out = degree(g.gifts, mode="out")
herders$NumGiftsGiven = deg.out[ as.character(herders$HerderID) ]

rm(deg.in, deg.out)

flog.info("Finished initialising")


#' common_group_quantification.r
#' Supply a sv/otu table, a taxonomy file, and a phylogenetic level.
#' Return sample abundances, relative abundances and sequence depth for all taxa at that level
#' found in greater than X% of samples (default 50%).
#' Also returns the number of unique SVs/OTUs that went into each group.
#'
#' @param sv           #sv or otu table where columns are unique taxonomic assignments, rows are samples.
#' @param tax          #taxonomy for sv/otu table. 7 columns for k/p/c/o/f/g/s.
#' @param groups       #unique groups you are looking for. ex: c('Ascomycota','Basidiomycota')
#' @param phyla_level  #level of phylogeny in quotes. i.e. 'phylum'.
#'
#' @return
#' @export
#'
#' @examples
common_group_quantification <- function(sv, tax, groups, tax_level, samp_freq = 0.5){
  #some tests.
  if(ncol(sv) != nrow(tax)){
    stop('Number of columns of sv table does not match number of rows in taxonomy table.')
  }
  tax_level <- tolower(tax_level)
  #make sure taxonomy column names are lower case.
  tax_names <- c('kingdom','phylum','class','order','family','genus','species')
  colnames(tax) <- tax_names

  #merge taxonomy and sv file.
  k <- cbind(tax, t(sv))
  k <- data.table(k)
  to_change <- colnames(k)[colnames(k) %in% tax_level]
  setnames(k,to_change,'tax_level')
  #count sequence abundance in each group by sample, and number of samples in which it occurs.
  abundance <- list()
  frequency <- list()
  unique.sv <- list()
  diversity <- list()
   evenness <- list()
  for(i in 1:length(groups)){
    z <- k[tax_level == groups[i],]
    start <- ncol(tax) + 1
    seq.count <- colSums(z[,start:ncol(z)])
    seq.freq  <- length(seq.count[seq.count > 0]) / nrow(sv)
    #get diversity, richness and evenness.
    seq.div <- rowSums(z[,start:ncol(z)])
    seq.div <- seq.div[seq.div > 0]
    n.SVs   <- length(seq.div)
    div     <- vegan::diversity(seq.div / sum(seq.div)) #same whether proportional or not.
    n.SVs <- length(seq.div[seq.div > 0])
    even <- div/log(n.SVs)

    abundance[[i]] <- seq.count
    frequency[[i]] <- seq.freq
    unique.sv[[i]] <- n.SVs
    diversity[[i]] <- div
     evenness[[i]] <- even
  }
  abundance <- do.call(rbind,abundance)
  frequency <- do.call(rbind,frequency)
  unique.sv <- data.frame(unlist(unique.sv))
  diversity <- data.frame(unlist(diversity))
   evenness <- data.frame(unlist( evenness))

  #name some stuff.
     unique.sv$groups <- groups
     diversity$groups <- groups
      evenness$groups <- groups
  rownames(abundance) <- groups
  colnames(abundance) <- rownames(sv)
  colnames(unique.sv) <- c('N.SVs','groups')
  colnames(diversity) <- c('diversity','groups')
  colnames( evenness) <- c( 'evenness','groups')

  #put together frequency table and order.
  frequency <- data.frame(cbind(groups,frequency))
  colnames(frequency)[2] <- 'sample_frequency'
  frequency$sample_frequency <- as.character(frequency$sample_frequency)
  frequency$sample_frequency <- as.numeric(frequency$sample_frequency)
  #subset to those that are found in > sam_freq of samples (default 50%).
  ref.frequency <- frequency[frequency$sample_frequency > samp_freq,]
  #kill unknown and anything unknown
  ref.frequency <- ref.frequency[!(ref.frequency$groups %in% c('unknown','Unknown')),]
  #merge in number of OTUs, diversity and evenness in each group to frequency table.
  frequency <- merge(frequency,unique.sv, all.x = T)
  frequency <- merge(frequency,diversity, all.x = T)
  frequency <- merge(frequency, evenness, all.x = T)
  frequency <- frequency[order(-frequency$sample_frequency),]

  #get sequence depth per sample.
  seq_total <- rowSums(sv)

  #only keep groups that are found in >samp_freq% of samples.
  abundance <- abundance[rownames(abundance) %in% ref.frequency$groups,]
  abundance <- t(abundance)

  #get abundances and relative abundances.
          other <- seq_total - rowSums(abundance)
      abundance <- cbind(other, abundance)
  rel.abundance <- abundance / colSums(abundance)

  #return output: abundances, relative abundances, sequence depth, group sample frequencies.
         to_return  <- list(abundance,rel.abundance,seq_total,frequency)
   names(to_return) <- c('abundances','rel.abundances','seq_total','group_frequencies')
  return(to_return)
}


#' @import lme4
#' @importFrom reshape2 dcast
#' @importFrom reshape2 acast

modelBuilder <- function(taxa_data, species_name, space_time,
                         list_length = FALSE, site_effect = FALSE,
                         overdispersion = FALSE, model_formula = NULL,
                         family = 'Binomial', verbose = FALSE){

  # Get data for just this species as 0 and 1 against visits
  y <- taxa_data[taxa_data$taxa == species_name, ]
  spDat <- merge(x = space_time, y = y, all.x = T, all.y = F)
  spDat$taxa <- as.character(spDat$taxa)
  spDat$taxa[is.na(spDat$taxa)] <- 0
  spDat$taxa[spDat$taxa == species_name] <- 1
  spDat$taxa <- as.numeric(spDat$taxa)
  # Add data for overdispersion
  spDat$obs <- 1:nrow(spDat)

  if(!list_length){
    # Summarise each site~year as a row
    MMdata <- dcast(spDat, year + site ~ ., fun.aggregate = length,
                    value.var = 'listLength') #how many lists for each year?
    # This has created a number of visits column
    names(MMdata)[ncol(MMdata)] <- 'nVis'
    # Number of successful visits for our species
    MMdata$successes <- as.numeric(acast(spDat, year + site ~ .,
                                         fun.aggregate = sum,
                                         value.var='taxa'))
    # Number of unsuccessful visits for our species
    MMdata$failures <- with(MMdata, nVis - successes)
    # Add data for overdispersion
    MMdata$obs <- 1:nrow(MMdata)
  }

  if(is.null(model_formula)){
    # Build the formula
    model_formula <- formulaBuilder(family,
                                    list_length,
                                    site_effect,
                                    overdispersion)
  }

  # We only use the mixed model if we have random effects
  # The formula + data used specifies if it is binomial or bernoulli
  if(site_effect | overdispersion){
    MM <- try(glmer(as.formula(model_formula),
                    data = if(list_length) spDat else MMdata,
                    family = binomial,
                    verbose = verbose),
              silent = TRUE)
  } else { #else we use glm
    MM <- try(glm(as.formula(model_formula),
                  data = if(list_length) spDat else MMdata,
                  family = binomial),
              silent = TRUE)
  }

  # Return the data too
  attr(MM, 'dataset') <- spDat
  return(MM)

}


#!/usr/bin/Rscript

## njfilter.r -- iteratively adds SNPs that don't have a genotype
## profile similar to SNPs already added to a set of informative SNPs

## The most informative SNP is always selected, and each additional
## considered SNP will have the highest delta. So, hopefully,
## maximally informative SNPs that are not similar in profile to
## already selected SNPs will be selected. Cutoff values are defined
## as a probability based on a normal distribution of pairwise
## similarity values (a good first-guess at this value would be 0.5).
## Lower values correspond to a set with many SNPs (lower cutoff...
## the probability of SNPs being considered close is low), while
## higher values will result in a set with fewer SNPs.

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

usage <- function(){
  cat("usage: ./njfilter.r <Genotype file> -s <split point> [<SNP ranking file>] [options]\n");
  cat("\nOther Options:\n");
  cat("  -r   probability resolution (default 0.01)\n");
  cat("  -min minimum probability (default 0)\n");
  cat("  -max maximum probability (default 1)\n");
  }

infile.name <- FALSE;
SNPrankfile.name <- FALSE;
splitPoint <- FALSE;
probResolution <- 0.01;
minProb <- 0;
maxProb <- 1;

argLoc <- 1;
while(!is.na(commandArgs(TRUE)[argLoc])){
  if(file.exists(commandArgs(TRUE)[argLoc])){ # file existence check
    if(infile.name == FALSE){
      infile.name <- commandArgs(TRUE)[argLoc];
    } else{
      if(SNPrankfile.name == FALSE){
        SNPrankfile.name <- commandArgs(TRUE)[argLoc];
      }
      else{
        cat("Error: More than two input files specified\n");
        usage();
        quit(save = "no", status=1);
      }
    }
  }
  if(commandArgs(TRUE)[argLoc] == "-s"){
      splitPoint <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(commandArgs(TRUE)[argLoc] == "-r"){
      probResolution <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(commandArgs(TRUE)[argLoc] == "-min"){
      minProb <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(commandArgs(TRUE)[argLoc] == "-max"){
      maxProb <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(length(grep("-h",commandArgs(TRUE)[argLoc])) > 0){
    usage();
    quit(save = "no", status = 0);
  }
  argLoc <- argLoc+1;
}

if(infile.name == FALSE){
  cat("Error: No input file specified\n");
  usage();
  quit(save = "no", status=1);
}

if(splitPoint == FALSE){
  cat("Error: No split point (-s <value>) specified\n");
  usage();
  quit(save = "no", status=2);
}

gt2Num <- function(x){
  if(is.data.frame(x)){
    tmpRownames <- rownames(x);
    out.df <- data.frame(lapply(x,gt2Num));
    rownames(out.df) <- tmpRownames;
    return(out.df);
  } else if(length(x)>1){
    return(mapply(gt2Num,x));
  }
  x <- toupper(x);
  if((x == "AT") | (x == "TA")){
#    cat(file="STDERR","Warning: complementary mutation found");
    return(NA);
  }
  if((x == "CG") | (x == "GC")){
#    cat(file="STDERR","Warning: complementary mutation found");
    return(NA);
  }
  if((x == "AA") | (x == "TT")){
    return(0);
  } else if ((x == "AC") | (x == "CA") |
             (x == "AG") | (x == "GA") |
             (x == "TC") | (x == "CT") |
             (x == "TG") | (x == "GT")){
    return(1);
  } else if ((x == "CC") | (x == "GG")){
    return(2);
  } else {
    return(NA);
  }
}

## Determines pairwise differences between each SNP (or each
## individual if the matrix is rotated...). The value returned in each
## cell is the number of allelic differences across all individuals.
## For a simple implementation of this (which occurs when
## checkComplement = FALSE), there's an assumption that the A/T allele
## of one SNP is linked to the A/T allele of the other SNP, which is
## not always correct. To highlight this, consider a case where one
## SNP is homozygous AA for all individuals, and another SNP is
## homozygous CC for all individuals. The simple implementation will
## consider these two SNPs to have maximal difference (i.e. a value of
## 200 for 100 individuals), where they should really be treated as
## having no difference. A better comparison (which occurs when
## checkComplement = TRUE) involves choosing the minimum value of two
## comparisons, one assuming A/T = A/T, and the other assuming A/T =
## C/G. This minimum check is probably a bit slower, so the option to
## turn it off has been provided. Also, if you're comparing
## indivduals, you'd *want* the alleles to be consistent, because in
## that case the compared SNPs are the same.

pairwiseDiff <- function(in.mat, compareRows, na.rm = TRUE,
                         checkComplement = TRUE){
  matSize <- length(compareRows);
  if(checkComplement){
    inv.mat <- 2 - in.mat;
    res.mat <- matrix(NA,matSize,matSize*2);
    dim(res.mat) <- c(matSize,matSize,2);
  } else {
    res.mat <- matrix(NA,matSize,matSize);
    dim(res.mat) <- c(matSize,matSize,1);
  }
  ## For loops are *slow* in R... it would be nice to be able to
  ## vectorise this completely.
  for(x in 1:matSize){
    if(x %% 10 == 0){
      cat(".");
    }
    res.mat[x,,1] <- colSums(abs((in.mat[compareRows[x],] %*%
                                  t(rep(1,matSize))) -
                                 t(in.mat[compareRows,])),
                             na.rm = TRUE);
    if(checkComplement){
      res.mat[x,,2] <- colSums(abs((in.mat[compareRows[x],] %*%
                                    t(rep(1,matSize))) -
                                   t(inv.mat[compareRows,])),
                               na.rm = TRUE);
    }
  }
  if(checkComplement){
    res.mat <- apply(res.mat,c(1,2),min); # calculate minimum difference
  } else {
    res.mat <- res.mat[,,1];
  }
  rownames(res.mat) <- compareRows;
  colnames(res.mat) <- compareRows;
  return(res.mat);
}

cat("Reading in file...");
con <- file(infile.name);
open(con);
gt.df <- read.table(con, colClasses = "character", row.names = 1);
close(con);
cat("done!\n");

## takes about 50s on assimilis
cat("Converting genotype data into matrix...");
gt.mat <- as.matrix(gt2Num(gt.df));
cat("done!\n");

gt.deltaStats <-
  data.frame(
             T1D = rowSums(gt.mat[,1:splitPoint], na.rm = TRUE) /
             (splitPoint * 2),
             NBS = rowSums(gt.mat[,-(1:splitPoint)], na.rm = TRUE) /
             ((dim(gt.mat)[2] - splitPoint) * 2),
             T1DAdj = rowSums(gt.mat[,1:splitPoint], na.rm = TRUE) /
             (apply(!is.na(gt.mat[,1:splitPoint]),1,
                   function(x){length(which(x))}) * 2),
             NBSAdj = rowSums(gt.mat[,-(1:splitPoint)], na.rm = TRUE) /
             (apply(!is.na(gt.mat[,-(1:splitPoint)]),1,
                   function(x){length(which(x))}) * 2));
gt.deltaStats$Delta <- abs(gt.deltaStats$T1DAdj - gt.deltaStats$NBSAdj);

if(!(SNPrankfile.name == FALSE)){
  cat("Reading in SNP ranking file...");
  gt.deltaStats <- read.table(SNPrankfile.name, row.names = 1);
  if(is.null(colnames(gt.deltaStats))){
    colnames(gt.deltaStats) <- 1:(dim(gt.deltaStats)[2]);
  }
  colnames(gt.deltaStats)[dim(gt.deltaStats)[2]] <- "Delta";
  cat("done!\n");
}

## takes about 2min on assimilis
cat("Calculating pairwise SNP vs SNP matrix...");
pairwise.mat <- pairwiseDiff(gt.mat,rownames(gt.mat));
cat("done!\n");

## njFilterSNP -- removes SNPs that are close neighbours to SNPs
## already in the selection set. The most informative SNP is always
## selected, and each additional considered SNP will have the highest
## delta. So, hopefully, maximally informative SNPs that are not
## similar in profile to already selected SNPs will be selected. The
## cutoff here refers to a probability based on a normal distribution
## of pairwise similarity values (a good first-guess at this value
## would be 0.5). Lower values include more SNPs (lower cutoff), while
## higher values include fewer SNPs.
njFilterSNP <- function(cutoff){
  cutoff <- qnorm(cutoff,
                  mean = mean(pairwise.mat),
                  sd = sd(as.vector(pairwise.mat)));
  deltaSortedSNPs <- rownames(gt.deltaStats[rev(order(gt.deltaStats$Delta)),
                                            c("Delta","Delta")]);
  limit <- length(deltaSortedSNPs);
  SNPset <- deltaSortedSNPs[1];
  if(limit>1){
    for(x in 2:limit){
      testSNP <- deltaSortedSNPs[x];
      if(min(pairwise.mat[testSNP,SNPset]) > cutoff){
        SNPset <- c(SNPset,testSNP);
      }
    }
  }
  return(SNPset);
}

setSize <- NULL;
for(x in seq(minProb,maxProb,by=probResolution)){
  cat("Number of SNPs at p>",x,": ",sep="");
  cat(length(njFilterSNP(x)));
  cat("\n",sep="");
  cat("SNPs at p>",x,": ",sep="");
  cat(njFilterSNP(x));
  cat("\n",sep="");
}


fragment_HL <- function(probe, cores = 1, pen=pen, pen_out=pen_out) {
    num_args <- list(pen, pen_out)
    names(num_args) <- c("pen", "pen_out")
    registerDoMC(cores)

    probe <- probe[with(probe, order(-xtfrm(probe$strand), probe$position)), ]

    probe[probe$strand == "-", ] <-
        probe[probe$strand == "-", ][order(probe[probe$strand == "-", ]$position,
                                           decreasing = TRUE), ]

    probe[, "HL_comb_fragment"] <- NA
    probe[, "HL_mean_comb_fragment"] <- NA

    # the position is not relevant in this case
    tmp_df <-
        data.frame(
            ID = probe$ID,
            val = probe$distance_HL,
            seg = probe$position_segment
        )

    # the fragmentation is performed on the delay_fragments, independent on
    # if they are (terminal) outliers or NAs.
    tmp_df[, "seg"] <- gsub("_O|_NA", "", tmp_df$seg)

    # although _NA will most probably will be dismissed here, because there
    # should be no half-life, if there is no delay
    tmp_df <- na.omit(tmp_df)

    unique_seg <- unlist(unique(tmp_df$seg))

    count <- 1

    # II. Dynamic Programming: the scoring function is interpreted

    frags <- foreach(k = seq_along(unique_seg)) %dopar% {
        section <- tmp_df[which(tmp_df$seg == unique_seg[k]), ]

        best_frags <- c()
        best_names <- c()

        if (nrow(section) > 1) {
            # only segments with more than one value are grouped...*

            for (i in 2:nrow(section)) {
                tmp_score <-
                    score_fun_ave(section[seq_len(i), "val"],
                                  section[seq_len(i), "ID"], pen)
                tmp_name <- names(tmp_score)
                if (i > 3) {
                    # fragments of the size at least 4 are allowed for half-life
                    for (j in (i - 1):3) {
                        tmp_val <- section[j:i, "val"]
                        tmp_ID <- section[j:i, "ID"]
                        tmp <-
                            score_fun_ave(tmp_val, tmp_ID, pen_out) + pen + best_frags[j - 2]
                        tmp_score <- c(tmp_score, tmp)
                        tmp_n <- paste0(best_names[j - 2], "|", names(tmp))
                        tmp_name <- c(tmp_name, tmp_n)
                    }
                }
                pos <- which(tmp_score == min(tmp_score))[1]
                tmp_score <- tmp_score[pos]
                tmp_name <- tmp_name[pos]
                best_frags <- c(best_frags, tmp_score)
                best_names <- c(best_names, tmp_name)
            }
        } else {
            #* ...all segments with less than two values are grouped automatically
            tmp_score <-
                score_fun_ave(section[, "val"], section[, "ID"], pen_out)
            tmp_name <- names(tmp_score)
            best_names <- c(best_names, tmp_name)
        }

        best_names[length(best_names)]
    }

    # III. Fill the dataframe

    for (k in seq_along(frags)) {
        na <- strsplit(frags[[k]], "\\|")[[1]]

        for (i in seq_along(na)) {
            tmp_trgt <- strsplit(na[i], "_")[[1]][1]
            trgt <- strsplit(tmp_trgt, ",")[[1]]
            if (length(strsplit(na[i], "_")[[1]]) == 3) {
                tmp_outl <- strsplit(na[i], "_")[[1]][3]
                outl <- strsplit(tmp_outl, ",")[[1]]
                trgt <- trgt[-which(trgt %in% outl)]
                rows <- match(outl, probe[, "ID"])
                nam <- paste0("Dc_", count, "_O")
                probe[rows, "HL_comb_fragment"] <- nam
                # the value assigned here is the mean (compare velocity and intercept
                # for delay)
                probe[rows, "HL_mean_comb_fragment"] <-
                    as.numeric(strsplit(na[i], "_")[[1]][2])
            }
            rows <- match(trgt, probe[, "ID"])
            nam <- paste0("Dc_", count)
            probe[rows, "HL_comb_fragment"] <- nam
            probe[rows, "HL_mean_comb_fragment"] <-
                as.numeric(strsplit(na[i], "_")[[1]][2])
            count <- count + 1
        }
    }
    row_NA <- which(is.na(probe$HL_comb_fragment))
    if (length(row_NA) > 0) {
        group <- c(row_NA[1])
        for (i in seq_along(row_NA)) {
            if (is.na(probe$HL_comb_fragment[row_NA[i] + 1])) {
                group <- c(group, row_NA[i] + 1)
            } else if (gsub("_O", "", probe$HL_comb_fragment[group[1] - 1]) ==
                       gsub("_O", "", probe$HL_comb_fragment[group[length(group)] + 1])) {
                probe$HL_comb_fragment[group] <-
                    paste0(gsub("_O", "", probe$HL_comb_fragment[group[1] - 1]), "_NA")
                probe$HL_mean_comb_fragment[group] <-
                    probe$HL_mean_comb_fragment[group[1] - 1]
                group <- row_NA[i + 1]
            } else if (probe$HL_comb_fragment[group[1] - 1] != probe$HL_comb_fragment[
                group[length(group)] + 1]) {
                probe$HL_comb_fragment[group] <-
                    paste0("Dc_", as.numeric(
                        gsub("Dc_|_O", "", probe$HL_comb_fragment[group[1] - 1])) + 0.5, "_NA")
                group <- row_NA[i + 1]
            }
        }
    }
    probe$HL_comb_fragment[is.na(probe$HL_comb_fragment)] <- paste0("Dc_", as.numeric(
        gsub("Dc_|_O", "", probe$HL_comb_fragment[!is.na(probe$HL_comb_fragment)]
             [length(probe$HL_comb_fragment[!is.na(probe$HL_comb_fragment)])])) + .5, "_NA")
    probe
}


REBOL [
    Title: "Rectangle-packing Test"
    Date: 25-Oct-2010/21:53:10+2:00
    Name: none
    Version: none
    File: none
    Home: none
    Author: "Oldes"
    Owner: none
    Rights: none
    Needs: none
    Tabs: none
    Usage: none
    Purpose: none
    Comment: none
    History: none
    Language: none
    Type: none
    Content: none
    Email: none
    require: [
    	rs-project %rectangle-pack
    	rs-project %imagick 'minimal
    	rs-project 'utf8-cp1250
	]
]

unless value? 'img-files [
	img-files: copy []
]
if empty? img-files [
	foreach file read dir: %/d\RS\projects-mm\robotek\_export\15_bar.swf_export\ [
		if parse file [%tag35_ thru %.jpg end][
			probe size: get-image-size dir/:file
			repend img-files [
				size
				dir/:file
			]
		]
	]
]
new-line/skip img-files true 2

maxpair: 0x0
foreach [size id] img-files [
	maxpair: max maxpair size
]

probe maxi: max maxpair/x maxpair/y
ask ""

size: case [
	maxi < 64  [  64x64  ]
	maxi < 128 [ 128x128 ]
	maxi < 256 [ 256x256 ]
	maxi < 512 [ 512x512 ]
	true       [1024x1024]
]

size-data: copy img-files
while [not empty?  second result: rectangle-pack size-data size][
	if size/x >= 1024 [
		print "images too big to fit in one bmp"
		ask ""
		break
	]
	size: size * 2
]

print ["using size:" size]
ask ""

combine-files: func[files size into][
	with ctx-imagick [
		start
				*pixel: NewPixelWand
				not zero? MagickNewImage *wand size/x size/y *pixel

				*wand2: NewMagickWand
				png?: find into %.png
				foreach [pos size file] files [
					print [pos size file]
					if block? file [parse file [to file! set file 1 skip]]
					if png? [file: replace copy file %.jpg %.png]
					unless all [
						*wand2: NewMagickWand
						not zero? MagickReadImage *wand2 utf8/encode to-local-file file
						tmp:  make image! size
				 		not zero? MagickExportImagePixels *wand2 0 0 size/x size/y "RGBO" 1 address? tmp
				 		;tmp: to-binary tmp
				 		not zero? MagickImportImagePixels *wand pos/x pos/y size/x size/y "RGBO" 1 address? tmp
			 		][
			 			errmsg: reform [
							Exception/Severity "="
							ptr-to-string tmp:  MagickGetException *wand Exception
						]
						MagickRelinquishMemory tmp
						ClearMagickWand   *wand2
						DestroyMagickWand *wand2
						ClearPixelWand    *pixel
						DestroyPixelWand  *pixel
						end
						make error! errmsg
		 			]
			 		ClearMagickWand   *wand2
		 		]
				not zero? MagickWriteImages *wand to-local-file into
			DestroyMagickWand *wand2
			ClearPixelWand    *pixel
			DestroyPixelWand  *pixel
		end
	]
]
combine-files result/1 size %/d/android/test/test.jpg
combine-files result/1 size %/d/android/test/test.png
;combine-files result2/1 size %/f/test2.jpg