if (1 == 0){
 probs10 <- read.table("D:/DATASETS/UKTraffic/probs/recprobs10.txt", header = F)
 plot(probs10$V1, type = 'b', cex = 0.4, xlim = c(0, 2000))
 abline(h = 0.003)
 abline(h = 0.004)
}
# Prepare figures for the paper

####
### 1) Plot improvement vs delay fractions
two_plots_traffic <- function(perf1, perf2, outf1, outf2, mu = 287){
  HLIN  = 6
  perf1 = read.table(perf1, header = T, sep=',')
  d1 = perf1$Delay * mu / mu
  f1 = perf1$fracFA
  t1 = perf1$fracTP
  perf2 = read.table(perf2, header = T, sep=',')
  d2 = perf2$Delay * mu / mu
  f2 = perf2$fracFA
  t2 = perf2$fracTP
  maxdelay = 300
  ######################## 1nd plot
  pdf(outf1)
  par(mar = c(5, 5, 4, 2) + 0.1)
  plot(d1, t1, lwd=3, col = "black", type = "l", cex = 0.7, xlab = "Delay", ylab = "Fraction",
       cex.lab = 2.0, ylim = c(0,1), cex.axis = 2)
  points(d1,t1,cex = 2)
  #
  lines(d1, f1, lwd = 1, type='l', lty=1, cex = 0.7, col = "grey")
  points(d1, f1, cex = 1, col = "black", pch = 16)
  #text(16, 0.9, expression(paste(lambda, " = 0.05")), cex = 2)
  text(16, 0.35 , "TP", cex = 2);
  text(16, 0.85 , "FA", cex = 2)
  abline(v = HLIN, lwd = 2)
  dev.off()
  ######################### 2rd plot
  pdf(outf2)
  par(mar = c(5, 5, 4, 2) + 0.1)
  plot(d2, t2, lwd=3, col = "black", type = "l", cex = 1., xlab = "Delay", ylab = "Fraction",
       cex.lab = 2.0, ylim = c(0,1), cex.axis = 2)
  points(d2,t2,cex = 2)
  #
  lines(d2, f2, lwd = 1, type='l', lty=1, cex = 0.7, col ="grey")
  points(d2, f2, cex = 1, col = "black", pch = 16)
  #text(30, 0.4, expression(paste(lambda, " = 0.2")), cex = 2)
  text(16, 0.90 , "TP", cex = 2);
  text(16, 0.17 , "FA", cex = 2)
  #abline(v = HLIN, lwd = 2)
  dev.off()
}
#two_plots_traffic("D:/DATASETS/UKTraffic/out/postImprVsDelay1.txt", "D:/DATASETS/UKTraffic/out/postImprVsDelay2.txt", "D:/DATASETS/UKTraffic/out/img/performance1.pdf", "D:/DATASETS/UKTraffic/out/img/performance2.pdf" )
two_plots_traffic("~/GITLOCAL/recurrency-code/ecml-icdm-15/dat/UKTraffic/out/postImprVsDelay1.txt",
                  "~/GITLOCAL/recurrency-code/ecml-icdm-15/dat/UKTraffic/out/postImprVsDelay2.txt",
                  "~/_tmp/p/uk/performance1sdm.pdf",
                  "~/_tmp/p/uk/performance2sdm.pdf" )

####
## 2) ROC plots for pre and post-processing settings
#mainpath = "D:/DATASETS/UKTraffic/out/"

if (1 == 0){
	probs <- read.table("D:/_tmp/tst_probsconfirmtst.txt", header = F)$V1
	plot(probs, type='l'); abline(h=0.004)
}

ROCplotimprovement <- function(mainpath, stat_roc_file,  postproc_roc_1_file, postproc_roc_2_file, roc_pre_file, outpdf_file ){
	# Plot fractions of removed TP / FA for internet traffic data
	roc0 = read.table( paste(mainpath, stat_roc_file , sep = ""), sep = "," , header = TRUE)
	roc_post1 = read.table( paste(mainpath, postproc_roc_1_file, sep = ""), sep = "," , header = TRUE)
	roc_post2 = read.table( paste(mainpath, postproc_roc_2_file, sep = ""), sep = "," , header = TRUE)
	roc_pre   = read.table( paste(mainpath, roc_pre_file  , sep = "") , sep = "," , header = TRUE)

	pdf(file = paste(mainpath, outpdf_file, sep = ""))
	par(mar = c(5,5,4,2) + 0.1)
	#plot(roc0$FA, roc0$TP, xlab= "FP rate", ylab = "TP rate", cex.axis = 2, cex.lab = 1, lwd=2, col = "black", type = "l", cex = 0.7)
	plot(roc0$FA, roc0$TP, type = 'l', xlab= "FP rate", ylab = "TP rate", cex.axis = 2, cex.lab = 2, cex = 2)
	points(roc0$FA, roc0$TP, pch = 19)
	if( 1 == 1 )
	{
		points(roc_pre$OldFPr  , roc_pre$OldTPr  , col = "blue", pch = 23, cex = 2.5, bg = "blue")
		points(roc_pre$NewFPr  , roc_pre$NewTPr  , col = "red" , pch = 24, lwd = 2)
	}
	if ( 1 == 1 )
	{
		points(roc_post1$OldFPr, roc_post1$OldTPr, col = "white", pch = 21, cex = 2.5)
		points(jitter(roc_post1$NewFPr, 0.02), jitter(roc_post1$NewTPr, 0.02), col = "red")
		print("Jitter")
		points(roc_post2$OldFPr, roc_post2$OldTPr, col = "blue", pch = 23, cex = 2.5, bg = "blue")
		points(roc_post2$NewFPr, roc_post2$NewTPr, col = "red", pch = 19, lwd = 2)
	}
	text(0.01, 0.95, "Static", cex = 1.5)
	dev.off()
}
# ROCplotimprovement("D:/DATASETS/UKTraffic/out/", "ROCstatic.txt", "postROC1.txt", "postROC2.txt", "preROC.txt", "img/ROCimprtraff2.pdf")
# , xlim = c(0,1), ylim = c(0,1)
#points(roc_pre$OldFPr, roc_pre$OldTPr, col  = "red", pch  = 16)


#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：diameter_bv ,  break voltage 破碎电压与三种液体之间随流量、极间距离、针头直径变化的影响

######################读取文件模块###################
#setwd("D:/data")
library(xlsx)

#读取v~h的数据
de_r<-read.xlsx("voltage.xls",sheetName="ethanol_r", header=TRUE)
da_r<-read.xlsx("voltage.xls",sheetName="acetone_r", header=TRUE)
di_r<-read.xlsx("voltage.xls",sheetName="iso_r", header=TRUE)

#保存pdf
pdf("diameter_3liquids_bv.pdf")
#画图-乙醇

plot(de_r$radius, de_r$BV,  col=0, xaxs="i", xlim=c(0.2, 0.9), ylim=c(1.8, 3.5),
xlab="OD(mm)", cex.lab=1.1, mgp=c(1, 0, 0),
tck=0.02,ylab=expression(V["bv"](kv)))

title( main="Break Voltage changes with diameter",line=0.5,cex.main=1.1)

model_ebv <- loess(de_r$BV ~ de_r$radius)
fit <- fitted(model_ebv)
ord <- order(de_r$radius)

lines(de_r$radius[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2) # 乙醇的拟合曲线

#画图-丙酮
#points(da_r$radius, da_r$BV,  pch=23, col="blue")

model_abv <- loess(da_r$BV ~ da_r$radius)
fit <- fitted(model_abv)
ord <- order(da_r$radius)

lines(da_r$radius[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2) # 丙酮的拟合曲线

#画图-异丙醇
#points(di_r$radius, di_r$BV,  pch=23, col="green")

model_ibv <- loess(di_r$BV ~ di_r$radius)
fit <- fitted(model_ibv)
ord <- order(di_r$radius)

lines(di_r$radius[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2) # 异丙醇的拟合曲线

#图例标注
legend("bottomright",bty="n",
       c("Ethanol", "Acetone", "Isoproply"), inset=.1,
       pch=c(6, 23, 24), col=c("red", "blue", "darkgreen")
       , lty=2, lwd=2.5, cex=1)

dev.off()


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Fri Apr 02 20:35:30 2010
########################################################
#What will the homicide rate be in 2009 and 2010

source("library/utilities.r")

saveplotRegM <- function(hexe){
  print(ggplot(hexe, aes(Executions, murders, label = tmon)) +
      geom_text(hjust=-.1) +
      geom_point() +
      stat_smooth(method = lm))
  dev.print(png, "predictions/output/exe-hom.png",
            width = 450, height = 300)
}

regM <- function(df, executions, saveplot = FALSE){
  #The murder rate for january and february was low cause it was low
  #in Mexico City, which isn't beset by the drug war, so we exlude it.
  #Alos exclude December 2008 because it will be off by 25% or so
  h07.08 <- df[208:227,]

  #The data for november looks wrong, so I'm using the average
  #exe[35, "Milenio"] <- (exe[34, "Milenio"] + exe[36, "Milenio"])/2
  hexe <- merge(h07.08, executions, by.x=c("year", "month"),
        by.y=c("Year", "Month"))
  hexe <- hexe[order(hexe$year, hexe$month),]
  hexe$tmon <- paste(factor(format(as.Date(hexe$date), "%b")),
                     hexe$year)
  reg <- lm(murders ~ Executions, data = hexe)
  print(summary(reg))
  if(saveplot == TRUE) saveplotRegM(hexe)
  reg
}

murderRate <- function(vec, pop = 107550697){
    (sum(vec)) / pop * 100000
}

predict09 <- function(reg) {
  e2009 <- subset(exe, Year == 2009)

  pre09 <- data.frame(predict(reg,
                              data.frame(Executions =
                                         e2009$Executions),
                              interval = "confidence"))
  res <- sapply(pre09, murderRate)
  res
}

predictChart <- function(exe, homrate) {
  pre10 <- data.frame(predict(reg,
                              data.frame(Executions =
                                         exe$Executions[25:39]),
                              interval = "confidence"))
  pre10$date <- monthSeq("2009/01/15", 15)

  pop <- c(homrate$Monthly.Pop, rep(NA,11),
           107550697, rep(NA,11), 108396211)

  pre10$pop <- na.spline(pop, na.rm=FALSE)[235:249]
  pre10 <- rbind(pre10, data.frame(fit = homrate[228, "murders"],
                   lwr = homrate[228, "murders"],
                   upr = homrate[228, "murders"],
                   date = homrate[228, "date"],
                   pop = homrate[228, "Monthly"]))
  pre10[1:3] <- sapply(pre10[1:3],
                       function(x) x / pre10$pop * 100000 * 12)
  pre10
}

exeRate <- function(df, population){
  df$date <- monthSeq("2007/01/15", 39)
  df$pop <- population
  df$rate <- df$Executions / df$pop * 100000 * 12
  df
}

homRate2010 <- function(pre10, homrate){
  rate08.09 <- data.frame(rate =
                             c(homrate$rate[214:228], pre10$fit[1:15]),
                          date = 1:30)
  reg10 <- lm(rate ~ date, data = rate08.09)
  x <- predict(reg10, data.frame(date = 25:36),
               interval = "confidence")
  pre10[13:14,1:3]
  all10 <- rbind(x[3:12,], pre10[13:14,1:3])
  apply(all10,2,mean)
}

plotHomEx <- function(pre10, exe, homrate) {
  label09 <- paste("homicide rate\nin 2009 ~",round(k2009.rate[[1]],1))
  label10 <- paste("homicide rate\nin 2010 ~",round(k2010.rate[[1]],1))
  ggplot(pre10, aes(as.Date(date), fit)) +
    scale_x_date() +
    geom_line(linetype = 2, color = "darkred") +
    geom_line(data = homrate[204:228,], aes(as.Date(date), rate),
              color = "darkred") +
    geom_ribbon(aes(ymax = upr, ymin = lwr), alpha = .2,
                fill ="darkred") +
    xlab("") + ylab("Annualized Homicide Rate") +
    annotate("text", x = as.numeric(as.Date("2007-07-01")), y = 27,
             label = "homicide rate\nin 2007 = 8.3") +
    annotate("text", x = as.numeric(as.Date("2008-07-01")), y = 27,
             label = "homicide rate\nin 2008 = 12.8") +
    annotate("text", x = as.numeric(as.Date("2009-07-01")), y = 27,
             label = label09) +
    annotate("text", x = as.numeric(as.Date("2010-05-15")), y = 27,
             label = label10) +
    annotate("text", x = as.numeric(as.Date("2010-04-15")), y = 22.5,
             label = "homicide\nrate", hjust =0, color = "darkred") +
    annotate("text", x = as.numeric(as.Date("2010-04-15")), y = 12,
             label = "execution\nrate", hjust =0, color ="darkgreen") +
    geom_line(data = exe, aes(as.Date(date), rate), color = "darkgreen") +
    scale_x_date(limits = c(as.Date("2006-11-01"),
                     as.Date("2010-08-01"))) +
    scale_y_continuous(limits = c(1.5, 28)) +
    opts(title = "Monthly Homicide and Execution Rates")
}

savePlot <- function(p) {
  Cairo(file = "predictions/output/estimate.png", w = 640, h = 480)
  print(p)
  dev.off()
}

#Let's explore the differences in executions reported by the
#newpapers Milenio and Reforma
exe.st <- read.csv("predictions/data/executions-bystate.csv")
exe.st$Universal <- NULL
exe.st <- melt(exe.st, id = "State")
exe.st$State <- with(exe.st,reorder(State, value))
exe.st$State <- iconv(exe.st$State, "windows-1252", "utf-8")
print(ggplot(exe.st, aes(value, State, group = variable,
                         color = variable, shape = variable)) +
    geom_point() +
    opts(title = "Differences in Reported Number of Executions in 2009"))
dev.print(png, "predictions/output/diff-execut2009.png",
            width = 500, height = 600)

#Prepare the data
hom <- read.csv(bzfile("timelines/data/county-month-gue-oax.csv.bz2"))
hom <- cleanHom(hom)
hom <- addMonths(hom)
pop <- monthlyPop()
homrate <- addHom(hom, pop)
homrate <- addTrend(homrate)

#The predictions
exe <- read.csv("predictions/data/executions-bymonth.csv")
ggplot(exe, aes(1:39, Milenio)) +
    geom_line(color = "blue") +
    geom_line(aes(1:39, Reforma), color = "red")
exe$diff <- exe$Reforma - exe$Milenio
#I couldn't find the data for March so here's and estimated
exe$Reforma[39] <- exe$Milenio[39] + mean(exe$diff[32:38])
exe$Executions <- (exe$Reforma + exe$Milenio) /2

reg <- regM(homrate, exe, saveplot = TRUE)
#plot(reg)
durbinWatsonTest(reg)
adf.test(residuals(reg))

k2009.rate <- predict09(reg)
print(round(k2009.rate,1))
pre10 <- predictChart(exe, homrate)
k2010.rate <- homRate2010(pre10, homrate)
print(round(k2010.rate,1))
exe <- exeRate(exe, c(homrate$Monthly[205:228], pre10$pop[1:15]))

savePlot(plotHomEx(pre10, exe, homrate))


# Tests an unordered categorical phenotype with multinomial regression
# and saves this result in the multinomial logistic results file.
testCategoricalUnordered <- function(varName, varType, thisdata, varlogfile) {

    pheno <- thisdata[,phenoStartIdx:ncol(thisdata)]
    geno <- thisdata[,"geno"]

    idxNA <- which(is.na(pheno))
    numNotNA <- length(which(!is.na(pheno)))
    numRows <- nrow(thisdata)

    if (numNotNA < opt$catunordnacutoff) {
        cat("CATUNORD-SKIP-", opt$catunordnacutoff, " (", numNotNA, ") || ",sep="",
            file=varlogfile, append=TRUE)
        incrementCounter(paste("unordCat.", opt$catunordnacutoff, sep=""))
        return(NULL)
    } else {
        # Check there are not too many levels and skip if there are.
        numUnique <- length(unique(na.omit(pheno)))
        if (numUnique > opt$maxunorderedcategories) {
            cat("Too many levels: ", numUnique, " > ", opt$maxunorderedcategories,
                " || SKIP ", sep="", file=varlogfile, append=TRUE)
            incrementCounter("unordCat.cats")
            return(NULL)
        }

        phenoFactor <- chooseReferenceCategory(pheno, varlogfile)
        loop <- levels(phenoFactor)
        varBinarymat <- as.data.frame(matrix(ncol=length(loop), nrow=numRows))

        j <- 1
        binaryMatColNames <- paste(varName, loop, sep='_')
        binaryMatColNames <- gsub("[[:space:]]", "", binaryMatColNames)

        for (i in loop) {
            idxForVar <- which(phenoFactor == i)
            cat(" CAT-SINGLE-BINARY-VAR: ", i, " || ", sep="",
                file=varlogfile, append=TRUE)
            incrementCounter("catSingle.binary")
            # Make zero vector and set 1s for those with this variable value
            varBinarymat[,j] <- rep.int(FALSE, numRows)
            varBinarymat[idxForVar,j] <- TRUE
            j <- j+1
        }

        varBinarymat[idxNA,] <- NA

        # BEGIN TRYCATCH
        tryCatch(
        {
            incrementCounter("success.unordCat")
            return(list(varBinarymat, binaryMatColNames))
            # END TRYCATCH
        }, error = function(e) {
            cat(paste("ERROR:", varName, gsub("[\r\n]", "", e), sep=" "))
            incrementCounter("unordCat.error")
    	})
    }
}

# Find reference category - category with most number of examples
chooseReferenceCategory <- function(pheno, varlogfile)
{
    uniqVar <- unique(na.omit(pheno))
    phenoFactor <- factor(pheno, ordered=FALSE)
    maxFreq <- 0
    maxFreqVar <- ""

    for (u in uniqVar) {
        withValIdx <- which(pheno==u)
        numWithVal <- length(withValIdx)

        if (numWithVal > maxFreq) {
            maxFreq <- numWithVal
            maxFreqVar <- u
        }
    }

    cat("reference: ", maxFreqVar, "=", maxFreq, " || ", sep="",
        file=varlogfile, append=TRUE)

    # Choose reference (category with largest frequency)
    phenoFactor <- relevel(phenoFactor, ref = paste("", maxFreqVar, sep=""))
    return(phenoFactor)
}


library(tidyverse)
library(lubridate)

today()
now()

### STOCK EXAMPLE
link <- 'https://github.com/gumdropsteve/datasets/raw/master/stocks/TSLA.csv'
df <- read_csv(link)
df <- as_tibble(df)
df

# extract specific values from columns
day(df$ds)
month(df$ds)
year(df$ds)

wday(df$ds, label=TRUE, abbr=FALSE)

# see last 5 and first 5 rows
tail(year(df$ds))
head(year(df$ds))

### TAXI EXAMPLE
link <- 'https://github.com/gumdropsteve/datasets/raw/master/nyc_transport/taxi/yellow_tripdata_2019-01.csv'
df <- read.csv(link)
df <- as_tibble(df)
df

pickup_times <- df$tpep_pickup_datetime

# break down
days <- day(pickup_times)
months <- month(pickup_times)
years <- year(pickup_times)

hours <- hour(pickup_times)
minutes <- minute(pickup_times)
seconds <- second(pickup_times)

# build
# ymd(str_c(years[1], months[1], days[1], collapse=TRUE))  # ERROR
?ymd
ymd(20191204)  # works if switch 4 -> 04

str_c(years[1], months[1], paste0(0, days[1]), collapse=TRUE)  # 4 -> 04 with paste0()

ymd(str_c(years[1], months[1], paste0(0, days[1]), collapse=TRUE))


#!/usr/bin/Rscript

# Load all the census data relating to slavery and population, and create a
# single table that can be used in a d3.nest.

library(dplyr)
library(stringr)
library(foreign)
options(stringsAsFactors = FALSE)

sqm_sqmi <- function(sq_meters) {
  sq_meters / 2589988.110336;
}

# Read all the CSV files into a list of data frames
fn  <- Sys.glob("data/*.csv")
csv <- lapply(fn, read.csv)
names(csv) <- fn %.% str_replace("data/", "") %.% str_replace(".csv", "")
rm(fn)

calc_derived <- function(df) {
  df %.% mutate(freeTotalPopulation = totalPopulation - slavePopulation,
         slavePercentage = round(100 * slavePopulation / totalPopulation, 2),
         freeAfAmPercentage = round(100 * freeAfAmPopulation / totalPopulation, 2),
         freeTotalPercentage = round(100 * freeTotalPopulation / totalPopulation, 2),
         slaveDensity = round(slavePopulation / sqm_sqmi(area), 2),
         freeAfAmDensity = round(freeAfAmPopulation / sqm_sqmi(area), 2),
         totalDensity = round(totalPopulation / sqm_sqmi(area), 2),
         freeTotalDensity = round(freeTotalPopulation / sqm_sqmi(area), 2)
         ) %.%
  select(-area)
}
# Read all the DBF files into a list of data frames
fn <- Sys.glob("/home/lmullen/research-data/nhgis-shapefiles/epsg4326/*.dbf")
dbf <- lapply(fn, read.dbf, as.is = TRUE)
names(dbf) <-  fn %.%
  str_replace("/home/lmullen/research-data/nhgis-shapefiles/epsg4326/", "") %.%
  str_replace(".dbf", "")

c_1790 <- csv$nhgis0013_ds1_1790_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1790, by = "GISJOIN") %.%
  select(GISJOIN,
         totalPopulation = A00AA1790,
         freeAfAmPopulation = AAQ001,
         slavePopulation = AAQ002,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1800 <- csv$nhgis0013_ds2_1800_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1800, by = "GISJOIN") %.%
  select(GISJOIN,
         totalPopulation = A00AA1800,
         freeAfAmPopulation = AAY001,
         slavePopulation = AAY002,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1810 <- csv$nhgis0013_ds3_1810_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1810, by = "GISJOIN") %.%
  select(GISJOIN,
         totalPopulation = A00AA1810,
         freeAfAmPopulation = AA7001,
         slavePopulation = AA7002,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1820 <- csv$nhgis0013_ds4_1820_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1820, by = "GISJOIN") %.%
  mutate(freeAfAmPopulation = ABB005 + ABB006,
         slavePopulation = ABB003 + ABB004) %.%
  select(GISJOIN,
         totalPopulation = A00AA1820,
         freeAfAmPopulation,
         slavePopulation,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1830 <- csv$nhgis0013_ds5_1830_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1830, by = "GISJOIN") %.%
  mutate(freeAfAmPopulation = ABO005 + ABO006,
         slavePopulation = ABO003 + ABO004) %.%
  select(GISJOIN,
         totalPopulation = A00AA1830,
         freeAfAmPopulation,
         slavePopulation,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1840 <- csv$nhgis0013_ds7_1840_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1840, by = "GISJOIN") %.%
  select(GISJOIN,
         totalPopulation = A00AA1840,
         freeAfAmPopulation = ACS002,
         slavePopulation = ACS003,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1850 <- csv$nhgis0013_ds10_1850_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1850, by = "GISJOIN") %.%
  select(GISJOIN,
         totalPopulation = A00AA1850,
         freeAfAmPopulation = AE6002,
         slavePopulation = AE6003,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

c_1860 <- csv$nhgis0016_ds14_1860_county %.%
  left_join(csv$nhgis0014_ts_county, by = "GISJOIN") %.%
  left_join(dbf$county_1860, by = "GISJOIN") %.%
  mutate(freeAfAmPopulation = AH2003 + AH2004,
         slavePopulation = AH2005 + AH2006) %.%
  select(GISJOIN,
         totalPopulation = A00AA1860,
         freeAfAmPopulation,
         slavePopulation,
         area = SHAPE_AREA,
         year = YEAR) %.%
  calc_derived()

# Join all the data together
all <- rbind(c_1790, c_1800, c_1810, c_1820, c_1830, c_1840, c_1850, c_1860)

write.csv(all, "census.csv", na = "")


# Analyze Stan fit object generated on the cluster
# The here presented code is

rm(list = ls())
gc()

setwd("~/Desktop/Code/laplace_approximation/Script/")
.libPaths("~/Rlib")
scriptDir <- getwd()

library(rstan)
library(posterior)
library(dplyr)
library(tidyr)
library(boot)
library(latex2exp)
source("tools/cmdStanTools.r")
source("tools/stanTools.r")
source("tools/analysisTools.r")

# pars <- c("lambda", "tau", "caux", "f", "lp__")
pars <- c("lambda", "tau", "caux", "xi")

nChains <- 6
nIter <- 2000
nIter_total <- nChains * nIter

modelName <- c("skim_logit", "skim_logit_ela")
delivDir <- file.path("deliv", modelName, "cluster")

stanfit <- readRDS(file = file.path(delivDir[1],
                                    paste0(modelName[1], "Fit.Rsave")))

check_div(stanfit)
samples_standard <- rstan::extract(stanfit, pars = pars)
index_standard <- select_lambda(samples_standard$lambda,
                                quant = 0.9, n_select = 6)

stanfit2 <- readRDS(file = file.path(delivDir[2],
                                     paste0(modelName[2], "Fit.Rsave")))
check_div(stanfit2)
samples_ela <- rstan::extract(stanfit2, pars = pars)
index_ela <- select_lambda(samples_ela$lambda,
                           quant = 0.9, n_select = 6)

pdf(file = file.path("deliv", "cluster_analysis",
                     paste(modelName,"Plots%03d.pdf",  sep = "")),
    width = 6, height = 6, onefile = F)
quant_select_plot2(log(samples_standard$lambda),
                   log(samples_ela$lambda), quant = 0.9,
                   threshold = 2.3, alpha = 0.5, x = 0.98, y = 0.9,
                   index_offset = 2500)

# Let's look at the first two covariates in index_standard, 81 and 86.
# We add 2000, given we've taken a subsample.
# NOTE: we can also look at xi.
samples_select <- function(sample) {
  data.frame(
  log_lambda_2581 = log(sample$lambda[, 81]),
  log_lambda_2586 = log(sample$lambda[, 86]),
  tau = log(sample$tau),
  caux = log(sample$caux),
  xi = log(sample$xi))
}

posterior_standard <- samples_select(samples_standard)
n_parm <- ncol(posterior_standard)
posterior_ela <- samples_select(samples_ela)
posterior_all <- rbind(posterior_standard, posterior_ela)
posterior_all <- gather(posterior_all)
posterior_all$method <-
  rep(rep(c("(full) HMC", "HMC + Laplace"), each = 12000), n_parm)
key_labels <- c(TeX("$\\log \ c_{aux}$"), TeX("$\\log \\lambda_{1816}$"),
                TeX("$\\log \\lambda_{2586}$"), TeX("$\\log \\tau$"),
                TeX("$\\log \\chi"))
posterior_all$key <- factor(posterior_all$key, label = key_labels)

sample_comparison_plot(posterior_all)

pars = c("tau", "caux", "xi", "lambda[81]", "lambda[86]")
ness_standard <- summary(stanfit, pars = pars)[1]$summary[, 9]
time_standard <- sum(get_elapsed_time(stanfit)) / 6
eff_standard <- ness_standard / time_standard

ness_ela <- summary(stanfit2, pars = pars)[1]$summary[, 9]
time_ela <- sum(get_elapsed_time(stanfit2)) / 6
eff_ela <- ness_ela / time_ela

data_eff <- data.frame(parameter = rep(pars, 2), eff = c(eff_standard, eff_ela),
                       method = rep(c("(full) HMC", "HMC + Laplace"),
                                    each = n_parm))

eff_comparison_plot(data_eff, y = 0.8) +
  scale_x_discrete(labels = c("tau" = parse(text = TeX("$\\tau$")),
                              "caux" = parse(text = TeX("$\\c_{aux}$")),
                              "xi" = parse(text = TeX("$\\chi$")),
                              "lambda[86]" = parse(text = TeX("$\\lambda_{2586}$")),
                              "lambda[81]" = parse(text = TeX("$\\lambda_{2581}$")))) +
  theme(text = element_text(size = 18))

dev.off()


CreateAlternativeModels <- function(data) {
  # This function takes the complete dataset at individual level for all the
  # countries, select the interesting columns and fit the linear model for the
  # different preferences on it.
  # It returns a list of models containing the preferences in the first level,
  # and the countries in the second level.

  # Use gender as a factor and not as numeric
  data[, gender := as.factor(gender)]
  # Select the interesting columns
  colsVar <- c("country", names(data)[5:13])
  # Select the data to fit
  dataToFit <- data %>% select(all_of(colsVar))

  # Create a model for each preference
  preferences <- names(dataToFit)[2:7]

  models <- lapply(preferences, function(x) {
    form <- paste0(x, " ~ gender")
    model <- EstimateModel(dat = dataToFit, formula = form, var = "country")
  })

  names(models) <- preferences

  return(models)
}


library("ensembleBMA")

# Load the data
data(prcpGrid)

# Put the data into an ensemble data object
prcpGridData <- ensembleData(forecasts = prcpGrid[,1:9],
    latitude = prcpGrid[,"latitude"], longitude = prcpGrid[,"longitude"],
    date = "20030115", forecastHour = 48, initializationTime = "00")

# Load the fit
data(prcpFit)

# Get the BMA quantile forecast
gridForc <- quantileForecast( prcpFit, prcpGridData,
    date = "20030115", q = c(0.5, 0.9))

# Make plots
library(fields)
library(maps)
plotProbcast( gridForc[,"0.5"], type = "image", zlim = c(0,280),
lon = prcpGridData$lon, lat = prcpGridData$lat)
title("Median Forecast for Precipitation", cex = 0.5)
plotProbcast( gridForc[,"0.9"], type = "image", zlim = c(0,280),
lon = prcpGridData$lon, lat = prcpGridData$lat)
title("Upper Bound Forecast for Precipitation", cex = 0.5)


## Plot the tree from BEAST
## Kaichi Huang 2019 Jul

library(ggtree)
library(treeio)
library(ape)
library(tidyverse)
library(RColorBrewer)

mu <- 6.9e-3
my.colors <- c("#000000","#FFCE6E","#338732","#D39117","#4BB7B7","#447499","#645084","#000000")
my.labels <- c(' ','H. annuus type 0','H. argophyllus','H. annuus type 2','H. petiolaris petiolaris','H. petiolaris fallax', 'H. niveus canescens','Perennial outgroup')

tree <- read.beast("Ha412HOChr05.pos1.inv.fixTree.mcc.tre")
#ggtree(tree) + geom_text(aes(label=node))
tree <- groupOTU(tree, list(seq(2,6),c(10,11),c(1,7,8,9,14),c(15,16),c(18,20),c(17,19),c(12,13)))

p <- ggtree(tree, aes(color=group))
revts(p) +
  theme_tree2() +
  geom_range(range="height_0.95_HPD", color="grey", alpha=.6, size=2, branch.length="height") +
  theme(legend.position="right", legend.title=element_blank()) +
  scale_color_manual(values=my.colors, labels=my.labels) +
  scale_x_continuous(limits=c(-0.018, 0.0005), breaks=seq(0,3,0.5)*(-mu), minor_breaks=seq(0,3,0.25)*(-mu), labels=seq(0,3,0.5))


#interpolate catch rates from survey data for mapping

#####
#####Notes this was run to produce the interpolated survey maps for EMERA fixed link November 15, 2013 12:27:44 PM Maritime Link

p = bio.snowcrab::load.environment()
require(raster)

	  do.interpolation=F

if(do.interpolation) {
#get crab data new
	det <- snowcrab.db('set.biologicals')
	gps <- c('totno.male.imm','totno.female.imm','totno.male.mat','totno.female.mat')
	det <- det[,c('trip','station','set','plat','plon',gps,'yr')]
	d 	<- aggregate(trip~station,data=det,FUN=length)
	det	<- det[det$yr>2003 & det$station %in% d[d[,2]>3,1],]

	geo.mean=T

	for(i in 1:length(gps)) {
		de 				<- det[,c('station',gps[i],'plat','plon','trip','set')]
		names(de)[2] 	<- 'gg'

		if(!geo.mean) dp 	<- aggregate(cbind(gg,plat,plon)~station,data=de,FUN=mean)
		if(geo.mean)  dp	<- aggregate(cbind(gg,plat,plon)~station,data=de,FUN=function(x) exp(mean(log(x+1)))-1)

		dp$limm 		<- log(dp[,'gg']+1)
		params 			<- list(nmax=15,drange=15,power=0.8)
# 		fp 				<- interpol.grid(dp[,c('plon','plat','limm')],locs=spatial_grid(p=p, nm=c("x","y")) ,method='inv.dist.gstat',params=params,outfile='iminterp.dat')
    fp        <- iwd(dp[,c('plon','plat','limm')],locs=spatial_grid(p=p, nm=c("x","y")) ,method='inv.dist.gstat',params=params,outfile='iminterp.dat')
		er 				<- with(dp[dp$limm>0,],quantile(limm,probs=c(0.025,0.975)))
		datarange 		<- c(0,seq( er[1], er[2], length.out=100))
    corners 		<- data.frame(rbind( cbind( plon=c(220, 990), plat=c(4750, 5270) )))
    cols 			<- colorRampPalette(c("darkblue","cyan","green", "yellow", "orange","darkred", "black"), space = "Lab")
    names(fp)[1:3] 	<- c('plon','plat','z')
    fo 				<- file.path("C:","~","bio","snowcrab","Adam","Emera","abundance maps","global average")
    if(geo.mean) fo 				<- file.path("C:","~","bio","snowcrab","Adam","Emera","abundance maps","global average","geomean")
    if(!geo.mean) fo 				<- file.path("C:","~","bio","snowcrab","Adam","Emera","abundance maps","global average","arithmean")

      outfn = gps[i]
      dir.create (fo, showWarnings=FALSE, recursive =TRUE)
      fn = file.path( fo, paste(outfn, "png", sep="." ) )
      png( filename=fn, width=3072, height=2304, pointsize=40, res=300 )
      lp = aegis_map( fp[,1:3], xyz.coords="planar", depthcontours=TRUE,
        at=datarange , col.regions=cols(length(datarange)+1), colpts=T, corners=p$planar.corners, annot=gps[i], plotlines="cfa.regions"  )
      print(lp)
      dev.off()

    ras 			<- rasterFromXYZ(fp[,c('plon','plat','z')], crs=p$aegis_proj4string_planar_km)

    writeRaster(ras,filename=file.path(fo,paste(gps[i],".asc",sep="")), format="ascii", overwrite=TRUE)
    }

}


#################################################
# Projection datasets
#################################################

# Possible datasets for temperature:
#################################################
# tas_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Mean air temperature at 1.5m °C
# tasmax_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Max air temperature at 1.5m °C
# tasmin_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Min air temperature at 1.5m °C

# Possible datasets for humidity:
#################################################
# hurs_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Relative humidity at 1.5m %

# Possible datasets for wind:
#################################################

# Question: How can we combine temp, humidity, and wind? (Temp+Humid = Heat Index)

# Libraries we need
library(raster)
library(sf)
library(sp)
library(ncdf4)
library(ggplot2)
library(rgdal)
library(rlang)
library(dplyr)
library(lubridate)
library(zoo)

#################################################
# .nc to raster
#################################################

tasmin.nc <- nc_open("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tasmin_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
print(tasmin.nc)

tasmin <- ncvar_get(tasmin.nc, "tasmin")
dim(tasmin) # Monthly UKCP18 data is stored in arrays of 82 · 112 · 1200, where the dimensions are eastings · northings · date.


############################################################
#####  Discriminant Analysis of Principal Components   #####
############################################################

##### Load libraries and data

library(adegenet)
library(tidyverse)
library(ggrepel)
library(BNTHarvestComposition)
data(BNTHarvestComposition)

hatchery.dat <- allGeno.dat[pop=c("WR_MI", "SE_MI", "Sturgeon", "Gilchrist", "SE_WI", "WR_WI")]
creel.dat <- allGeno.dat[pop=c("Creel_Frankfort", "Creel_Ludington", "Creel_Manistee", "Creel_Onekama")]

##### Perform DAPC #####
# Hatchery only
dapc.hatchery <- dapc(hatchery.dat, var.contrib = TRUE, scale = FALSE, n.pca = 25, n.da = nPop(hatchery.dat) - 1)
summary(dapc.hatchery)$assign.per.pop*100 #Reassignment probability

# Add harvested
pred.supp <- predict.dapc(dapc.hatchery, newdata = creel.dat)
posterior.probs.creel <- round(pred.supp$posterior[1:118, 1:6],3)

##### Plot DAPC #####
# Hatchery data frame #
dapc.df <- cbind(as.data.frame(dapc.hatchery$ind.coord)[1:2], as.factor(hatchery.dat@pop))
dapc.df$labelNames <- c(rep("Wild Rose-MI",50),rep("Seeforellen-MI",50),rep("Sturgeon River",50),rep("Gilchrist Creek",50), rep("Seeforellen-WI",50),rep("Wild Rose-WI",50))
names(dapc.df) <- c("A1", "A2", "pop", "labelNames")

# Harvest data frame #
harvest.df <- as.data.frame(pred.supp$ind.scores[,1:2])
names(harvest.df) <- c("A1", "A2")

# Plot DAPC with harvested individuals overlayed #
dapc.plot <- ggplot(dapc.df, aes(x = A1, y = A2, color = labelNames)) +
  geom_point(alpha = 0.25, size = 4) +
  ylab("Discriminant function 2") +
  xlab("Discriminant function 1") +
  labs(color = "labelNames") +
  geom_point(data = harvest.df, pch=17, col=transp("black", .7), cex=2.5) +
  theme_classic(base_size = 18) +
  theme(
    legend.position = "bottom") +
  NULL


## script to plot PCA output and colour by 1000G ethnicity

calcPopDist<-function(dat.pca, ref){
# dat.pca is test individual's data across pcs
# ref is matrix with 1 row per population and 1 column per pca
	popDist<-rep(NA, nrow(ref))
	names(popDist)<-rownames(ref)
	for(i in 1:nrow(ref)){
		diffs<-dat.pca - ref[i,]
		sqdiffs<-diffs^2
		popDist[i]<-sqrt(sum(sqdiffs))
	}
	return(popDist)
}

args<-commandArgs(TRUE)

setwd(args[1])
refFolder<-args[2]
subset<-args[3] ## use , to separate multiple files

if(!is.na(subset)){
	subset = unlist(strsplit(subset, ","))
	#print(subset)
	keepFiles<-sapply(subset, read.table, simplify=FALSE)

}

pcas<-read.table("mergedw1000G.pca.eigenvec", stringsAsFactors = FALSE)
KGped<-read.table(paste(refFolder, "/20130606_g1k.ped", sep = ""), stringsAsFactors = FALSE, header = TRUE, sep = "\t")
popInfo<-read.table(paste(refFolder, "/PopInfo.txt", sep = ""), stringsAsFactors = FALSE, header = TRUE, sep = "\t") ## table made from 1000G website

KGped<-KGped[match(pcas[,2], KGped[,2]),]
nPops<-length(table(KGped$Population))
popInfo<-popInfo[match(popInfo$Population.Code,levels(as.factor(KGped$Population))),]

KGped<-cbind(KGped,popInfo$Super.Population.Code[match(KGped$Population, popInfo$Population.Code)])
colnames(KGped)[ncol(KGped)]<-"SuperPopulation"
nSuperPops<-length(table(KGped$SuperPopulation))

ptType<-c(20,3)[as.factor(is.na(KGped[,1]))]
ptCol<-rainbow(nPops)[as.factor(KGped$Population)]
ptCol[is.na(ptCol)]<-"black"

pdf("PCAplotwith1KG.pdf", width = 10, height = 10)
par(mfrow = c(2,2))
par(mar = c(4,4,0.75,0.75))
plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", pch = ptType, col = ptCol)
plot(pcas[,3], pcas[,5], xlab = "PC1", ylab = "PC3", pch = ptType, col = ptCol)
plot(pcas[,3], pcas[,6], xlab = "PC1", ylab = "PC4", pch = ptType, col = ptCol)
plot(0,1,type = "n", axes = FALSE, xlab = "", ylab = "")
legend("center", pch = 16, col = rainbow(nPops), levels(as.factor(KGped$Population)), cex = 1.5, ncol = 3)

if(length(args) > 2){
	for(each in subset){
		par(mfrow = c(2,2))
		filterIndex<-which(pcas[,1] %in% keepFiles[[each]][,1] | !is.na(KGped[,1]))

		plot(pcas[filterIndex,3], pcas[filterIndex,4], xlab = "PC1", ylab = "PC2", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(pcas[filterIndex,3], pcas[filterIndex,5], xlab = "PC1", ylab = "PC3", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(pcas[filterIndex,3], pcas[filterIndex,6], xlab = "PC1", ylab = "PC4", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(0,1,type = "n", axes = FALSE, xlab = "", ylab = "")
		fileName<-tail(unlist(strsplit(each, "/")), n = 1)
		title(sub = paste(fileName, "\n(", nrow(keepFiles[[each]]), " individuals)", sep = ""))
		legend("center", pch = 16, col = rainbow(nPops), levels(as.factor(KGped$Population)), cex = 1.5, ncol = 3)
	}
}

## alternatively plot "super populations"

ptCol<-rainbow(nSuperPops)[as.factor(KGped$SuperPopulation)]
ptCol[is.na(ptCol)]<-"black"
layout(matrix(c(1,2,3,4), ncol = 2), widths = c(3,3,3,0.75))
plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", pch = ptType, col = ptCol)
plot(pcas[,3], pcas[,5], xlab = "PC1", ylab = "PC3", pch = ptType, col = ptCol)
plot(pcas[,3], pcas[,6], xlab = "PC1", ylab = "PC4", pch = ptType, col = ptCol)
plot(0,1,type = "n", axes = FALSE, xlab = "", ylab = "")
legend("center", pch = 16, col = rainbow(nSuperPops), levels(as.factor(KGped$SuperPopulation)), cex = 1.5)

if(length(args) > 2){
	for(each in subset){

		filterIndex<-which(pcas[,1] %in% keepFiles[[each]][,1] | !is.na(KGped[,1]))

		plot(pcas[filterIndex,3], pcas[filterIndex,4], xlab = "PC1", ylab = "PC2", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(pcas[filterIndex,3], pcas[filterIndex,5], xlab = "PC1", ylab = "PC3", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(pcas[filterIndex,3], pcas[filterIndex,6], xlab = "PC1", ylab = "PC4", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(0,1,type = "n", axes = FALSE, xlab = "", ylab = "")
		fileName<-tail(unlist(strsplit(each, "/")), n = 1)
		title(sub = paste(fileName, "\n(", nrow(keepFiles[[each]]), " individuals)", sep = ""))
		legend("center", pch = 16, col = rainbow(nSuperPops), levels(as.factor(KGped$SuperPopulation)), cex = 1.5)
	}
}

dev.off()

## for each super population calculate cluster medians

nMatches<-rep(NA,20)
for(nPCs in 2:20){
	pop.medians<-apply(pcas[,-c(1:2)][,1:nPCs], 2,aggregate, by = list(KGped$SuperPopulation), median)
	pop.medians<-cbind.data.frame(pop.medians)
	rownames(pop.medians)<-pop.medians[,1]
	pop.medians<-pop.medians[,seq(2,nPCs*2,2)]

	## for each individual compare to each super population and find most similar

	popDistsAll<-apply(pcas[,-c(1:2)][,1:nPCs], 1, calcPopDist, pop.medians)
	popDistsAll<-t(popDistsAll)
	predPop<-colnames(popDistsAll)[apply(popDistsAll, 1, which.min)]

	compTrue<-table(predPop, KGped$SuperPopulation)
	nMatches[nPCs]<-sum(diag(compTrue))
}
pdf("SelectOptimalnPCsForPopulationPrediction.pdf")
plot(1:20,nMatches/sum(!is.na(KGped$SuperPopulation))*100, xlab = "nPCs", ylab = "Percentage Correct")
dev.off()

nPCs<-which.max(nMatches)
pop.medians<-apply(pcas[,-c(1:2)][,1:nPCs], 2,aggregate, by = list(KGped$SuperPopulation), median)
pop.medians<-cbind.data.frame(pop.medians)
rownames(pop.medians)<-pop.medians[,1]
pop.medians<-pop.medians[,seq(2,nPCs*2,2)]

## for each individual compare to each super population and find most similar
popDistsAll<-apply(pcas[,-c(1:2)][,1:nPCs], 1, calcPopDist, pop.medians)
popDistsAll<-t(popDistsAll)
predPop<-colnames(popDistsAll)[apply(popDistsAll, 1, which.min)]

## calculate a quality score for prediction
## ideally want one population much closer than the others
rangeDist<-t(diff(apply(popDistsAll,1,range)))
qsPred<-(apply(popDistsAll,1,quantile, 0.25)-apply(popDistsAll,1,min))/rangeDist
pdf("BoxplotPrePopQCScores.pdf", width = 12, height = 6)
par(mfrow = c(1,2))
boxplot(qsPred ~ KGped$SuperPopulation, col = rainbow(5), xlab = "Known populations")
boxplot(qsPred ~ predPop, col = rainbow(5), xlab = "Predicted populations")
dev.off()
## can define thresholds for each population based on 1000 genomes samples
#pop99<-aggregate(popDistsAll, by = list(KGped$SuperPopulation), quantile, 0.95)
#pop99Thres<-diag(as.matrix(pop99[,-1]))
#names(pop99Thres)<-colnames(popDistsAll)
#table(apply(popDistsAll, 1, min) < pop99Thres[predPop],as.factor(predPop))

ptCol<-rainbow(nSuperPops)[as.factor(predPop)]
pdf("PCAplotwith1KGpredictedPopulations.pdf", width = 10, height = 10)
layout(matrix(c(1,2,3,4), ncol = 2), widths = c(3,3,3,0.75))
plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", pch = ptType, col = ptCol)
plot(pcas[,3], pcas[,5], xlab = "PC1", ylab = "PC3", pch = ptType, col = ptCol)
plot(pcas[,3], pcas[,6], xlab = "PC1", ylab = "PC4", pch = ptType, col = ptCol)
plot(0,1,type = "n", axes = FALSE, xlab = "", ylab = "")
legend("center", pch = 16, col = rainbow(nSuperPops), levels(as.factor(KGped$SuperPopulation)), cex = 1.5)
plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", type = "n")
points(pcas[which(ptType == 20),3], pcas[which(ptType == 20),4], pch = 20, col = ptCol[which(ptType == 20)])
plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", type = "n")
points(pcas[which(ptType == 3),3], pcas[which(ptType == 3),4], pch = 3, col = ptCol[which(ptType == 3)])

if(length(args) > 2){
	for(each in subset){
		layout(matrix(c(1,2,3,4), ncol = 2), widths = c(3,3,3,0.75))
		filterIndex<-which(pcas[,1] %in% keepFiles[[each]][,1] | !is.na(KGped[,1]))

		plot(pcas[filterIndex,3], pcas[filterIndex,4], xlab = "PC1", ylab = "PC2", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(pcas[filterIndex,3], pcas[filterIndex,5], xlab = "PC1", ylab = "PC3", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(pcas[filterIndex,3], pcas[filterIndex,6], xlab = "PC1", ylab = "PC4", pch = ptType[filterIndex], col = ptCol[filterIndex])
		plot(0,1,type = "n", axes = FALSE, xlab = "", ylab = "")
		fileName<-tail(unlist(strsplit(each, "/")), n = 1)
		title(sub = paste(fileName, "\n(", nrow(keepFiles[[each]]), " individuals)", sep = ""))
		#legend("center", pch = 16, col = rainbow(nSuperPops), levels(as.factor(KGped$SuperPopulation)), cex = 1.5)

		plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", type = "n")
		points(pcas[which(ptType == 20),3], pcas[which(ptType == 20),4], pch = 20, col = ptCol[which(ptType == 20)])
		plot(pcas[,3], pcas[,4], xlab = "PC1", ylab = "PC2", type = "n")
		points(pcas[which(pcas[,1] %in% keepFiles[[each]][,1]),3], pcas[which(pcas[,1] %in% keepFiles[[each]][,1]),4], pch = 3, col = ptCol[which(pcas[,1] %in% keepFiles[[each]][,1])])

	}
}

dev.off()

## look at predications of our sample
outPred<-cbind(pcas[,1:2], predPop, qsPred, popDistsAll)
outPred<-outPred[which(ptType == 3),]
write.csv(table(outPred$predPop), "TablePredictedPopulations.csv")
write.csv(outPred, "PredictedPopulations.csv", quote = FALSE, row.names = FALSE)

if(length(args) > 2){
	for(each in subset){
		fileName<-tail(unlist(strsplit(each, "/")), n = 1)
		outPred.tmp<-outPred[which(outPred[,1] %in% keepFiles[[each]][,1]),]
		write.csv(table(outPred.tmp$predPop), paste("TablePredictedPopulations", fileName, ".csv", sep = ""))
	}
}


#' @title interpolate.xy.robust
#' @description Interpolate some xy data used by netmensuration and mode fifnding methods.
#' @family abysmally documented
#' @author  Jae Choi, \email{jae.choi@dfo-mpo.gc.ca}
#' @export
interpolate.xy.robust = function( xy, method, target.r2=0.9, mv.win=10, trim=0.05,
  probs=c(0.025, 0.975), loess.spans=seq( 0.25, 0.01, by=-0.01 ), inla.model="rw2",
  smoothing.kernel=kernel( "modified.daniell", c(2,1)), nmax=3, inla.h=0.1, inla.diagonal=0.01, inla.ngroups=400 ) {

  # simple interpolation methods
  # target.r2 == target prediction R^2

  if (FALSE) {
    x=seq(-5,5,by=0.1)
    y=sin(x) + runif(length(x))^2
    xy = data.frame( x=x, y=y )
    target.r2=0.9
    nmax=5  # max number of times to try to reduce data set
    probs=c(0.025, 0.975)
    loess.spans=seq( 0.2, 0.01, by=-0.01 )
    inla.model="rw2"
    smoothing.kernel=kernel( "modified.daniell", c(2,1))
  }

  if ( is.vector(xy) ) {
    nz = length(xy)
    z = data.frame( x=1:nz, y=xy )
  } else {
    if (ncol(xy) == 2 ) {
      nz = nrow(xy)
      z = data.frame( xy)
      names(z) = c("x", "y" )
    } else {
      stop( "Error: y or c(x,y) expected")
    }
  }

  z$p= NA
  z$noise = FALSE
  z$loc = 1:nz  # row index used in seq lin method

  if (method == "moving.window" ) {
    z$p = z$y
    for (nw in mv.win:1) {
      win = -nw:nw
      z$p = NA
      for( i in 1:nz ) {
        iw = i+win
        iw = iw[ which( iw >= 1 & iw <=nz ) ]
        z$p[i] = mean( z$y[iw], na.rm=TRUE )
      }
      z$diff = abs( z$p - z$y )
      qnts = quantile( z$diff, probs=(1-trim), na.rm=TRUE )  # remove upper quantile
      ii = which( z$diff > qnts )
      if (length(ii) > 0) z$p[ ii ] = NA
      z$p[ii] = approx( x=z$x, y=z$p, xout=z$x[ii], method="linear", rule=2 )$y
      rsq = cor( z$p, z$y, use="pairwise.complete.obs" )^2
      if (!is.na(rsq)) {
        if (rsq > target.r2 ) break()
      }
    }
  }

  if (method =="sequential.linear") {
    # check adjacent values and reject if differences are greater than a given range of quantiles (95%)

      m = z # locs are the location indices for z$y ... to bring back into "z"
      m = m[ which(is.finite( m$y)) , ]
      lg = 1 # lag
      nw = nrow( m )  # staring number of data points
      nw_target =  nw * (1-trim)  # proportion of data to retain (not trim)

      while ( nw > nw_target ) {
        yd0 = c( diff( m$y, lag=lg ) , rep( 0, lg )) # diffs left-right # padding with 0's  (no change)
        dm = quantile( yd0, probs=probs, na.rm=TRUE )
        n = which( yd0 < dm[1] | yd0 > dm[2] )
        if (length(n) == 0 ) break()
        if ( length(n) > 0 ) m = m[-n, ]  # remove na's and then assess again
        nw = nrow( m )
      }

      # m$locs contains indices of "good" data .. setdiff to get the "bad" .. set to NA and then
      #   infill missing with interpolated values
      ii = setdiff( 1:nz, unique(m$loc) )
      if (length(ii) > 0)  {
        z$y[ii] = NA
        afun = approxfun( x=z$x, y=z$y,  method="linear", rule=2  )
        z$y[ii] = afun( z$x[ii] )
      }
    z$p = z$y
  }

  if (method =="local.variance") {
    # local variance estimates used to flag strange areas .. where local variance is too high .. remove the data

    z$p = z$y
    for (nw in mv.win:1) {
      z$Zvar = NA
      win = c( -nw : nw )
      for (i in 1:nz ) {
        iw = i+win
        iw = iw[ which(iw >=1 & iw<= nz)]
        if (length(iw)> 3)  z$Zvar[i] = var( z$p[iw], na.rm=TRUE )
      }
      qnts = quantile( z$Zvar, probs=(1-trim), na.rm=TRUE )  # remove upper quantile
      ii = which( z$Zvar > qnts )
      if (length(ii) > 0) z$p[ ii ] = NA
      afun = approxfun( x=z$x, y=z$p,  method="linear", rule=2  )
      z$p[ii] = afun( z$x[ii] )
      rsq = cor( z$p, z$y, use="pairwise.complete.obs" )^2
      if (!is.na(rsq)){
        if (rsq > target.r2 ) break()
      }
    }
  }

  if (method == "loess" ) {
    var0 = var( z$y, na.rm=TRUE)
    for( sp in loess.spans ) {
      # ID a good span where loess solution ~ real data

      loess.mod = try( loess( y ~ x, data=z, span=sp, control=loess.control(surface="direct"),na.action = na.exclude ), silent=TRUE )
      if ( "try-error" %in% class(loess.mod) ) next()
      z$p = predict( loess.mod, newdata=z )
      rsq = cor( z$p, z$y, use="pairwise.complete.obs" )^2
      if (!is.na(rsq)) {
        if (rsq > target.r2 ) {
         # if ( var( z$p, na.rm=TRUE) < var0 )
		break()
        }
      }
    }
  }

  if (method == "inla") {

    require(INLA)
    ymean = mean( z$y, na.rm=TRUE )
    z$y = z$y - ymean
    nn = abs( diff( z$x) )
    dd = median( nn[nn>0], na.rm=TRUE )
    z$xiid = z$x = jitter( z$x, amount=dd / 20 ) # add noise as inla seems unhappy with duplicates in x?

    rsq = 0
    nw = length( which(is.finite( z$y)))
    nw0 = nw + 1
    count = 0

    ndat = nrow( z )
    #if ( ndat < inla.ngroups ) inla.ngroups = ndat

    # m = get("inla.models", INLA:::inla.get.inlaEnv())
    # m$latent$rw2$min.diff = NULL
    # assign("inla.models", m, INLA:::inla.get.inlaEnv())

    # inla's default RW2 resolution is too coarse, causing incomplete solution:
    # alter a bit as this is potentially a smoothed series
    #menv = get("inla.models", INLA:::inla.get.inlaEnv())
    #menv$latent$rw2$min.diff =1e-4
    # assign("inla.models", menv, INLA:::inla.get.inlaEnv() )
    h = 0.02
    while ( nw != nw0 ) {
      count = count + 1
      if (count > nmax ) break() # this is CPU expensive ... try only a few times

      FM = formula(  y ~ f( inla.group(xiid, n=inla.ngroups), model="iid")
                       + f( inla.group(x, n=inla.ngroups), model=inla.model )
                       )
      v = NULL
      v = try( inla( FM, data=z,
            control.predictor=list (compute=TRUE ),
            control.compute=list(config=TRUE),
            control.results=list(return.marginals.random=TRUE, return.marginals.predictor=TRUE ),
            control.inla = list( h=h ), # increase in case values are too close to zero
            # control.mode = list( restart=TRUE, result=v ), # restart from previous estimates
            quantiles=NULL,  # no quants to save storage requirements
            verbose=FALSE )
        , silent=TRUE )

      if ( "try-error" %in% class(v) ) next()

      # make sure Eigenvalues of Hessian are appropriate (>0)
      if ( v$mode$mode.status > 0 ) {
        h = h + 0.02
        next()
      }

      z$p = v$summary.fitted.values$mean
      rsq = cor( z$p, z$y, use="pairwise.complete.obs" )^2

      if (!is.na(rsq)) if (rsq > target.r2) break()

      # drop a few extreme data points and redo
      iid = v$summary.random$xiid[["mean"]]
      qiid = quantile( iid, probs=probs, na.rm=TRUE )
      i = which( iid > qiid[2] | iid < qiid[1] )
      if (length( i) > 0 ) z$y[i] = z$p[i]
      nw0 = nw
      nw = length( which(is.finite( z$y))) # to check for convergence
    }
    # return to original scale
    z$y = z$y + ymean
    z$p = z$p + ymean
  }

  if (method=="kernel.density") {
    # default method is kernel( "modified.daniell", c(2,1)),
    # a 2X smoothing kernel: 2 adjacent values and then 1 adjacent on the smoothed series .. i.e. a high-pass filter
    nd = length(smoothing.kernel$coef) - 1 # data points will be trimmed from tails so need to recenter:

    # test in case x increments are not uniform
    vv = unique( diff( z$x ) )
    xr = min(vv[vv>0])
    uu = unique( round( vv, abs(log10(xr))))
    if (length(uu) > 1 ) {
      # interpolate missing/skipped data before smoothing
      ifunc = approxfun( x= z$x, y=z$y, method="linear", rule=2 )
      r0 = range( z$x, na.rm=TRUE )
      fx = seq( r0[1], r0[2], by= min(uu) )
      fy = ifunc( fx)
    } else if (length(uu) ==1 ) {
      fx = z$x
      fy = z$y
    }
    fn = length( fx)
    si = (nd+1):(fn-nd)
    fp = rep( NA, fn)
    fp[si] = kernapply( as.vector(z$y), smoothing.kernel )

    pfunc = approxfun( x=fx, y=fp, method="linear", rule=2)
    z$p = pfunc( z$x)
    # plot( p ~ x, z, type="l" )

    # constrain range of predicted data to the input data range
    TR =  quantile( z$y, probs=probs, na.rm=TRUE  )
    toolow = which( z$p < TR[1] )
    if ( length(toolow) > 0 )  z$p[toolow] = TR[1]
    toohigh = which( z$p > TR[2] )
    if ( length(toohigh) > 0 ) z$p[toohigh] = TR[2]
    # lines( y ~ x, z, col="green" )
  }

  if (method=="tukey" ) {
    z$p =smooth( z$y )
  }

  if (method=="simple.linear") {
    pfunc = approxfun( x=z$x, y=z$y, method="linear", rule=2)
    z$p = pfunc( z$x)
  }

  if (method=="gam") {
    require(mgcv)
    gmod = gam( y ~ s(x) , data=z)
    z$p = predict( gmod, z, type="response" )
  }

  if (method=="smooth.spline") {
    # similar to inla .. duplicated x is problematic for smooth.spline ... add small noise
    nn = abs( diff( z$x) )
    dd = median( nn[nn>0], na.rm=TRUE )
    z$x = jitter( z$x, amount=dd / 20) # add noise as inla seems unhappy with duplicates in x?
    rsq = 0
    nw = length( which(is.finite( z$y)))
    nw0 = nw + 1
    count = 0
    while ( nw != nw0 ) {
      count = count + 1
      if ( count > nmax ) break()  # in case of endless loop
      uu = smooth.spline( x=z$x, y=z$y, keep.data=FALSE, control.spar=list(tol=dd / 20) )
      if ( length(uu$x) != nrow(z)  ) {
        afun = approxfun( x=uu$x, y=uu$y,  method="linear", rule=2  )
        vv = afun( z$x )
        z$p = vv$y
      } else {
        z$p = uu$y
      }
      rsq = cor( z$p, z$y, use="pairwise.complete.obs" )^2
      if (!is.na(rsq)){
        if (rsq > target.r2) break()
      }
      # drop a few extreme data points and redo
      iid = z$y - z$p
      qiid = quantile( iid, probs=probs, na.rm=TRUE )
      i = which( iid > qiid[2] | iid < qiid[1] )
      if (length( i) > 0 ) {
        z$y[i] = z$p[i]
      }
      nw0 = nw
      nw = length( which(is.finite( z$y))) # to check for convergence
    }
  }

  return(z$p)

}


############################################################
#R code for FISH554 Beautiful Graphics in R
#Animation lecture
#School of Aquatic and Fishery Sciences
#University of Washington, USA
#Instructor: Trevor A. Branch, tbranch@uw.edu#
############################################################

#============manual method using gifmaker.me==========================
#Create a sequence of images, e.g. in png format
#then open the webpage "gifmaker.me" to create an animated
#gif. Upload png files, select Create GIF Animation,
#then select Download the GIF.
#Note: animated gifs run when embedded in powerpoint and
#the powerpoint is displayed.
#===========================================================
set.seed(101)
for (i in 1:20) {
   #create a png with sequential numbering
   #this is sent directory on my hard drive
   #called Gifmaker.me\rnorm
   norm.data <- tibble(nums=rnorm(n=i^2*10))
   range(norm.data$nums)
   ggplot(data=norm.data, aes(x=nums)) +
      geom_histogram(binwidth=0.2) + theme_minimal() +
      xlim(c(-4,4))
   ggsave(filename=paste0("Gifmaker.me\\rnorm\\fig",i,".png"))
}

#==========USING GGANIMATE===================================
library(tidyverse)
library(gganimate)
library(magick)

#animation based on Species column in iris dataset
library(gganimate)
head(iris)
ggplot(iris, aes(x = Petal.Width, y = Petal.Length)) +
   geom_point(aes(colour = Species)) +
   transition_states(Species,
                     transition_length = 2,
                     state_length = 1)

#transitions using group=1
ggplot(iris, aes(x = Petal.Width, y = Petal.Length)) +
   geom_point(aes(colour = Species, group = 1)) +
   transition_states(Species,
                     transition_length = 2,
                     state_length = 1) +
   theme_minimal()

#control entrance and exit of points with enter_fade() and exit_shrink()
ggplot(iris, aes(x = Petal.Width, y = Petal.Length)) +
   geom_point(aes(colour = Species), size = 2) +
   transition_states(Species,
                     transition_length = 2,
                     state_length = 1) +
   theme_minimal() +
   enter_fade() +
   exit_shrink()

#save as an animated gif
anim_save(filename='Figs\\iris.gif')

#============forest example using gganimate===========================
#Data and original source code by Emilio Vilanova <vilanova@uw.edu>
#Shared on 8 March 2020. Simplified for teaching purposes by
#Trevor Branch tbranch@uw.edu
#Data are trees in a forest plot, with animation in the order in
#which data were collected: species, position (X,Y), diameter
#of tree, and other measurements.
#=====================================================================
library(tidyverse)   #includes ggplot
library(gganimate)   #the package that does the magic
library(magick)      #delete library(gifski)

PackForestData <- read_csv(file=here("Documents", "data","beautiful_graphics","PackForest.csv"))

#need to specify that the data are grouped using the
#seq_along command based on the cnt column (numbers 1:nrow(data))
PackMap3 <- ggplot(PackForestData, aes(x = X, y = Y, colour = CommonName,
                              group = seq_along(cnt))) +
   geom_point(aes(size = Diameter, color = CommonName), alpha=0.6) +
   scale_size_area(breaks = c(10,30,50,70,90,120)) +
   scale_color_manual(values = c("#00AFBB", "#E7B800", "#FC4E07",
         "blue4", "chocolate4", "#E69F00", "#56B4E9", "darkmagenta")) +
   theme_bw() +
   theme(plot.background = element_blank(),
      panel.grid.minor = element_blank(),
      panel.border = element_rect(colour = "gray80"),
      legend.position = "right") +
   scale_y_continuous(breaks = seq(0, 100, 20)) +
   scale_x_continuous(breaks = seq(0, 100, 20)) +

   #make the legend circles a bit bigger
   guides(color = guide_legend(override.aes = list(size=5),
                               title = 'Common name'),
          size = guide_legend(title='Diameter (cm)')) +
   labs(title="Stem map - Marteloscope plot - Pack Forest",
        x = "X (meters)", y = "Y (meters)") +
   #this is the gganimate step: reveals each data point based
   #on the groupings in the "cnt" column
   transition_reveal(cnt)

#can just run   PackMap3  but the code below allows fine-tuning.
#duration determines how long it takes to animate in seconds
#height and width are the fixed size of the resulting figure
#This takes ~60 seconds to render
p1 <- animate(PackMap3, duration = 10, height = 500,
              width = 700)
p1 #shows the plot in R

anim_save("PackForest.gif", p1)


# Goals: A first look at R objects - vectors, lists, matrices, data frames.

# To make vectors "x" "y" "year" and "names"
x <- c(2,3,7,9)
y <- c(9,7,3,2)
year <- 1990:1993
names <- c("payal", "shraddha", "kritika", "itida")
# Accessing the 1st and last elements of y --
y[1]
y[length(y)]

# To make a list "person" --
person <- list(name="payal", x=2, y=9, year=1990)
person
# Accessing things inside a list --
person$name
person$x

# To make a matrix, pasting together the columns "year" "x" and "y"
# The verb cbind() stands for "column bind"
cbind(year, x, y)

# To make a "data frame", which is a list of vectors of the same length --
D <- data.frame(names, year, x, y)
nrow(D)
# Accessing one of these vectors
D$names
# Accessing the last element of this vector
D$names[nrow(D)]
# Or equally,
D$names[length(D$names)]

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/b1.r


# The code reads the presence absence matrix (PAM) and matches family names between the PAM and the age file generated in previous steps.
# Then it estimates and plots species (and family) richness maps across the globe using the grid resolution used for the PAM.
# Continues with R objects generated in previous steps.
# Uses additional files

load("~/prPAM_FAM_grid.r") ### file in data folder

cat("Maximum number of species per grid-cell:",max(rowSums(prPAM_g[,-c(1:2)])),"species","\n")
which(rowSums(prPAM_g[,-c(1:2)]) == 0) -> iden_inf
prPAM_g2 <- prPAM_g[-iden_inf,]
nana <- which(is.na(match(colnames(prPAM_g2),rownames(resB)[fams])));colnames(prPAM_g2)[nana]
which(is.na(match(colnames(prPAM_g2),rownames(resB)[fams])))
prPAM_fam <- prPAM_g2
prPAM_fam[,-c(1:2)] <- decostand(prPAM_fam[,-c(1:2)],method="pa")
ssp <- coordinates(prPAM_fam[,1:2])
which(rowSums(prPAM_g2[,-c(1:2)]) > 5) -> iden
f <- clean_coordinates(as.data.frame(ssp[iden,]), lon = "LON",lat = "LAT",
                       tests="seas",species=NULL,value="flagged",seas_scale = 110)
k <- 20
richness_fam <- rowSums(prPAM_fam[iden,-c(1:2)]);range(richness_fam)
Data<-data.frame(Order=1:dim(prPAM_fam[iden,])[1],z=richness_fam)
Data<-Data[order(Data$z),]; ssp<-coordinates(prPAM_fam[iden,1:2])
breaks <- getJenksBreaks(Data$z[f],k)
cols_breaks <- rev(viridis(k))
Data$col <- cols_breaks[k]
for (i in k:1){Data$col[which(Data$z <= breaks[i])] <- cols_breaks[i]}
orderedcolors<-Data[order(Data$Order),"col"]
pdf(paste(ruta_write,"4.Richness_MAPS.pdf",sep=""))
maps::map("world",interior=F)
title("Family richness per 2x2 grid-cell")
points(ssp[f,],pch=22,lwd=0.4,bg=orderedcolors[f],cex= 0.45,col=orderedcolors[f])
rect(xleft =-180,xright = 190,ybottom = -86,ytop = 85,border = "black")
color.legend(xl=-35,xr=35,yb=-83,yt=-67,align="lt",gradient="x",
             legend=c(range(richness_fam)),rect.col=cols_breaks)
abline(h=c(23.5,-23.5),lwd=2,lty=3)
richness <- rowSums(prPAM_g2[iden,-c(1:2)])
Data <- data.frame(Order=1:dim(prPAM_g2[iden,])[1],z=richness)
Data <- Data[order(Data$z),];ssp<-coordinates(prPAM_g2[iden,1:2])
breaks <- getJenksBreaks(Data$z[f],k)
cols_breaks <- rev(viridis(k))
Data$col <- cols_breaks[k]
for (i in k:1){Data$col[which(Data$z <= breaks[i])] <- cols_breaks[i]}
orderedcolors<-Data[order(Data$Order),"col"]
maps::map("world",interior=F)
title("Species richness per 2x2 grid-cell")
points(ssp[f,],pch=22,lwd=0.4,col=orderedcolors[f],bg=orderedcolors[f],cex= 0.45)
rect(xleft =-180,xright = 190,ybottom = -86,ytop = 85,border = "black")
color.legend(xl=-35,xr=35,yb=-83,yt=-67,align="lt",gradient="x",
             legend=c(range(richness)),rect.col=cols_breaks)
abline(h=c(23.5,-23.5),lwd=2,lty=3)

par(mfrow = c(1, 1), pty = "s")
plot(log(richness),log(richness_fam),cex=0.7,pch=21,bg=rgb(1,0,0,0.5),lwd=0.6,
     ylab="Family Richness (log-trasnformed)",xlab="Species Richness (log-trasnformed)")
abline(lm(log(richness_fam)~log(richness)))
summ_lm <- summary(lm(log(richness_fam)~log(richness)))
legend("bottomright",inset=0.03,legend=paste("b = ",round(summ_lm$coefficients[2,1],2),";","F = ",round(summ_lm$fstatistic[1],2),";",
                                               "p-val < 0.001",";","R2* = ",round(summ_lm$adj.r.squared,2),sep=""))
dev.off()


apply_transformations = function(in_data, features, transformations){
  new_feats = rep("", length(features) * length(transformations))
  out_data = list()
  i = 1
  for(f in features){
    for(trans_name in names(transformations)){
      feat = paste0(f, "_", trans_name)
      trans = transformations[trans_name][[1]]
      out_data[feat] = list(trans(in_data[,f]))

      new_feats[i] = feat
      i = i + 1
    }
  }
  data.frame(out_data)
}


 DSYRFS Example Program Results

 Solution(s)
             1          2
 1     -4.0000     1.0000
 2     -1.0000     4.0000
 3      2.0000     3.0000
 4      5.0000     2.0000

 Backward errors (machine-dependent)
       9.9E-17    8.3E-17
 Estimated forward error bounds (machine-dependent)
       2.4E-14    3.2E-14


#-------------------------------------------------------------------------------
# KINSHIP matrix calculation using GenABEL package
#
# Here we convert PLINK tped and tfam files to GenABEL data and we calculate
# kinship matrix using "ibs" function. We need tped and tfam files
#
# Note: tped should have subject alleles coded by letters, EX: A,C,G,T (see
#       page 233 of GenABEL tutorial)
#
# Author     : Karim Oualkacha
# Adapted by : Pablo Cinoglani
#
#																			2012
#-------------------------------------------------------------------------------

library(GenABEL)
library(nFactors)
library(CompQuadForm)

#-------------------------------------------------------------------------------
# Create kinship file
#-------------------------------------------------------------------------------
createKinship <- function(kinshipFile, tfam ) {
	# Convert TFAM to GenABEL phenotype
	# Save as genable phenotype file
	# It contains: subject IDs, SEX and the quantitaive phenotype.
	# This file should have headers for each column: "id   sex   pheno"
	cat('Writing GenABEL phenotype file\n');
	sexOri <- (2 - tfam$sex);			# Note: Sex has to be coded as 0=female and 1=male, instead of 1=male, 2=female)
	sex <- pmin(1, pmax(0,sexOri) );	# Make sure it is always {0,1}
	if( sum(sex!=sexOri) )	{ cat("\n\nWARNING: Sex had to be adjusted to {0,1}. This will probably create some problems\n\n"); }
	genPhen <- data.frame( id=tfam$individualId, sex=sex, pheno=tfam$phenotype );
	write.table( genPhen, file=genabelPhenFile, col.names=TRUE, row.names=FALSE, quote=FALSE);

	#---
	# Converts PLINK tped file to GenABEL genotype
	#---
	convert.snp.tped(tped = tpedFile, tfam = tfamFile, out = genabelGenFile, strand = "+")

	#---
	# Calculate and save kinship matrix
	#---

	# Load GenABEL data
	data.GenABEL <- load.gwaa.data(phe = genabelPhenFile, gen = genabelGenFile, force = T)

	# Next command calculates the kinship matrix using all autosomal markers that we have in the tped file
	cat('Calculating Kinship matrix (IBS)\n');
	kinshipMatrix = ibs(data.GenABEL[, autosomal(data.GenABEL)], weight = "freq")
	kinshipMatrix = diagReplace(kinshipMatrix, upper=TRUE)

	# Save kinship as RData file
	cat('Saving file', kinshipFile, '\n');
	save( kinshipMatrix, file=kinshipFile );
	kinshipMatrix;
}

#-------------------------------------------------------------------------------
# Create 'pheno.txt' file (used by FaST-LMM)
#-------------------------------------------------------------------------------
createPheno <- function(phenoFileName, tfam){
	# Create 'pheno' file
	pheno.test = data.frame(tfam$familyId, tfam$individualId, tfam$phenotype)
	colnames(pheno.test) = c( 'familyId', 'individualId', 'phenotype');
	cat('Writing phenotype to file: ', phenoFileName , '\n' );
	write.table(pheno.test, file = phenoFileName, sep = " ", quote = FALSE, row.names = FALSE, col.names = FALSE)
}

#-------------------------------------------------------------------------------
# Create 'sim' file for FaST-LMM
#
# From FastLMM's handbook:
#		Instead of SNP data from which genetic similarities are computed, the user may provide
#		the genetic similarities directly using the –sim <filename> option. The file containing
#		the genetic similarities should be tab delimited and have both row and column labels for
#		the IDs (family ID and individual ID separated by a space). The value in the top-left
#		corner of the file should be var.
#
# Arguments:
#
# tfam            : This is the TFAM matrix (PLINK's TFAM format file)
#
# kinshipMatrix   : The kinship matrix. If the kinship matrix noted is calculated from
#          GenABEL we should convert it to the kinship matrix using this
#          command:
#              kin1 = diagReplace(kin1, upper=TRUE)
#
#-------------------------------------------------------------------------------
createSim <- function(simFileName, tfam, kinshipMatrix ) {

	# Create 'simmilarity' file for FaST-LMM (simFileName).
	kin.FaST = 2 * kinshipMatrix
	n.col = paste(tfam[,1] , tfam[,2])		# Create labels 'family_ID individual_ID'
	colnames(kin.FaST) <- n.col
	rownames(kin.FaST) <- n.col

	# Write simmilarity file
	cat('Writing simmilarity matrix to file: ', simFileName , '\n' );
	write.table(c('var\t'), file = simFileName, quote = FALSE, sep = "\t", row.names = FALSE, col.names = FALSE, eol = "");	# This is just to create the required 'var'
	write.table(kin.FaST, file = simFileName, quote = FALSE, sep = "\t", row.names = TRUE , col.names = TRUE , append=TRUE); # Now we dump the data
  //write(t(kin.FaST[ ,1:(dim(kin.FaST)[1])]), file = file.name.data, ncolumns = dim(kin.FaST)[1], sep= "\t")
} //Above comment is from working R-askat code

#-------------------------------------------------------------------------------
# Main
#-------------------------------------------------------------------------------

debug          <- FALSE
exitAfterError <- !debug        # Exit after any error, (unless we are in debug mode)

if( exitAfterError ) {
    options(
        #warn=2,	# This will change all warnings into errors, so warnings will also be handled like errors
        error= quote({ traceback(); q("no",status=1,FALSE) })	# Make sure we get an error code after a 'stop'
    );
}

#---
# Parse command line arguments
# Debug:
#	cmdLineArgs <- c( 'geno_cov.tped', 'geno_cov.tfam', 'geno_cov.genable.gen', 'geno_cov.genable.phen', 'geno_cov.kinship.RData', 'geno_cov.sim', 'geno_cov.pheno.txt' );
#---
if( !exists('cmdLineArgs') )	{ cmdLineArgs <- commandArgs(trailingOnly = TRUE); }

tpedFile		<- cmdLineArgs[1];
tfamFile		<- cmdLineArgs[2];
genabelGenFile	<- cmdLineArgs[3];
genabelPhenFile	<- cmdLineArgs[4];
kinshipFile		<- cmdLineArgs[5];
simFile			<- cmdLineArgs[6];
phenoFileName	<- cmdLineArgs[7];

cat("Kinship arguments:\n");
cat("\tInput TPED file                 :", tpedFile, "\n");
cat("\tInput TFAM file                 :", tfamFile, "\n");
cat("\tOutput GenABEL 'genotype' file  :", genabelGenFile, "\n");
cat("\tOutput GenABEL 'phenotype' file :", genabelPhenFile, "\n");
cat("\tOutput Kinship matrix file      :", kinshipFile, "\n");
cat("\tOutput SIM matrix file          :", simFile, "\n");
cat("\tOutput pheno file               :", phenoFileName, "\n");

#---
# Read TFAM
#---
cat('Reading TFAM file\n');
tfam <- read.csv(tfamFile, sep="", header=FALSE, col.names=c('familyId','individualId', 'paternalId', 'maternalId', 'sex', 'phenotype') );

# Create (or load) kinship file
if( file.exists(kinshipFile) ) {
	cat("Kinship file '", kinshipFile ,"' exists. Loading.\n");
	load( kinshipFile )
} else {
	kinshipMatrix <- createKinship(kinshipFile, tfam );
}

# Create SIM file (for FaST-LMM)
createSim(simFile, tfam, kinshipMatrix );

# Create pheno.txt file (for FaST-LMM)
createPheno(phenoFileName, tfam);


################################################################################
# The contents of this file are Teradata Public Content
# and have been released to the Public Domain.
# Licensed under BSD; see "license.txt" file for more information.
# Copyright (c) 2021 by Teradata
################################################################################
#
# R And Python Analytics with SCRIPT Table Operator
# Orange Book supplementary material
# Alexander Kolovos - October 2021 - v.2.1
#
# Example 3: Multiple Models Fitting and Scoring: Fitting module (R version)
# File     : ex3rFit.r
#
# Use case:
# Using simulated data for a retail store:
# Model fitting step ("ex3rFit.r"): Fit a model to each one of specified
#   product IDs, each featuring 5 dependent variables x1,...,x5. Return the
#   model information back to Vantage, and store it in a table.
# Model scoring step ("ex3rSco.r"): Score a set of records for each one
#   of the product IDs.
# The R scripts perform each step for one individual product ID whose
# data reside on the corresponding AMP. Scaling is achieved by
# - (on the SQL side) partitioning the input data for each product ID onto
#   individual AMPs.
# - (on the Pyhton script side) executing the same script across all AMPS,
#   thus operating simultaneously on mutiple product IDs.
#
# Script accounts for the general scenario that an AMP might have no data.
#
# Requires the caTools add-on package.
#
# Required input:
# - ex3tblFit table data from file "ex3dataFit.csv" for fitting step.
#
# Output:
# - p_id        : Product ID
# - modelSerB64 : Python model information in a serialized + encoded format
#
################################################################################

# Load dependency package
# We use the suppressPackageStartupMessages() function to prevent unwanted
# output that may interfere with the output expected by the database.
suppressPackageStartupMessages(library(caTools))

DELIMITER <- '\t'
stdin <- file(description="stdin", open="r")

inputDF <- data.frame();

# Know your data: You must know in advance the number and data types of the
# incoming columns from the Teradata database! Use this information in following:
cv <- c("numeric","numeric","numeric","numeric","numeric","numeric","numeric")
inputDF <- try(read.table(stdin, sep=DELIMITER, flush=TRUE, header=FALSE,
                          quote="", na.strings="", colClasses=cv), silent=TRUE)

close(stdin)

# For AMPs that receive no data, exit the script instance gracefully
if (class(inputDF) == "try-error") {
    inputDF <- NULL
    quit()
}

nObs <- nrow(inputDF)

p_id <- inputDF[,1];
x1   <- inputDF[,2];
x2   <- inputDF[,3];
x3   <- inputDF[,4];
x4   <- inputDF[,5];
x5   <- inputDF[,6];
y    <- inputDF[,7];

dataDF <- data.frame(x1, x2, x3, x4, x5);
colnames(dataDF) <- c("x1", "x2", "x3", "x4", "x5")

# Fit a model to the given data
# We use the suppressWarnings() function to prevent unwanted
# output that may interfere with the output expected by the database.
myModel <- suppressWarnings( glm(y ~ x1 + x2 + x3 + x4 + x5,
                                 data = dataDF, family = "binomial") )
# names(myModel) provides the list of possible arguments to extract

# Serialize the model and then encode the model to base64 from serialized
# raw. Plain serialization creates newline characters ("\n"), and when
# passed to Teradata they create multiples rows instead of a single-line CLOB.
modelSer <- serialize(myModel, NULL, TRUE)
# Use the "caTools" library to encode the model to base64 from serialized raw.
# Alternatively, rawToChar() function could be used to encode the model to a
# string. Alas, rawToChar() creates newline characters ("\n"), and when
# passed to Teradata they create multiples lines instead of a single CLOB.
modelSerB64 <- base64encode(modelSer)

# Export results to the SQL Engine database through standard output
cat(p_id[1], "\t", modelSerB64, "\n")


#regress parameter estimates vs. out of sample R2 for predictable taxa fungi.
rm(list=ls())
source('paths.r')

#set output path.----
output.path <- effect.size_r2_correlation_data.path

#load fit statistics and model parameters.----
#parameter tables.
pl <- readRDS(ted_ITS_prior_all.groups_JAGSfits.path)
names(pl)[6] <- 'functional'
#R2, RMSE statistics tables for in and out of sample fits.
vl <- readRDS(NEON_dmilti.ddirch_analysis_summary.path)
ins.dat <- vl$calibration$cal.stat
oos.dat <- vl$validation$val.stat$site.stat
oos.dat <- oos.dat[order(match(names(oos.dat), names(pl)))]
ins.dat <- ins.dat[order(match(names(ins.dat), names(pl)))]

#organize parameters by taxa/group.----
par.out <- list()
for(i in 1:length(pl)){
  #grab parameters within a level.
  lev  <- pl[[i]]$species_parameter_output
  pars <- list()
  for(k in 1:length(lev)){
    pars[[k]] <- as.numeric(as.character(lev[[k]]$Mean))
  }
  pars <- do.call(rbind, pars)
  rownames(pars) <- names(lev)
  colnames(pars) <- as.character(lev$other$predictor)
  pars <- pars[!(rownames(pars) == 'other'),]
  par.out[[i]] <- pars
}
par.out <- do.call(rbind, par.out)

#Get in and out of sample stats tables in same order.-----
ins.dat <- do.call(rbind, ins.dat)
oos.dat <- do.call(rbind, oos.dat)
ins.dat <- ins.dat[order(match(ins.dat$name, rownames(par.out))),]
oos.dat <- oos.dat[order(match(oos.dat$name, rownames(par.out))),]

#rename columns, merge all data together.----
colnames(ins.dat) <- paste0('ins.',colnames(ins.dat))
colnames(oos.dat) <- paste0('oos.',colnames(oos.dat))
all.dat <- cbind(par.out,ins.dat,oos.dat)

#grab R2 values, plot correlations.----
par(mfrow = c(4,3))
rsq.out <- list()
for(i in 1:ncol(par.out)){
  dat <- all.dat
  dat$oos.rsq.1 <- ifelse(dat$oos.rsq.1 < 0, 0, dat$oos.rsq.1) #set negative oos.rsq1 values to zero.
  dat$ins.rsq.1 <- ifelse(dat$ins.rsq.1 < 0, 0, dat$ins.rsq.1) #set negative oos.rsq1 values to zero.
  y <- dat$ins.rsq.1
  x <- abs(dat[,i])
  lab <- colnames(dat)[i]
  m <- lm(y~x)
  m.rsq <- round(summary(m)$r.squared, 2)
  plot(y ~ x, bty = 'l', cex = 1, xlab = lab)
  mtext(paste0('R2=',m.rsq), side = 3, line = -1, adj = 0.05)
  abline(m, lwd = 1, lty = 2)
  rsq.out[[i]] <- m.rsq
}
rsq.out <- unlist(rsq.out)
names(rsq.out) <- colnames(par.out)
rsq.out <- rsq.out[!(names(rsq.out) %in% c('intercept'))]

#Wrap up parameter vs. prediction R2 - R2 values, and data.-----
output <- list(rsq.out,dat)
names(output) <- c('rsq','dat')
saveRDS(output, output.path)


library(survival)
library(survcomp)
library(ROCR)

calculate_C <- function(true_survival_time, status, cov, beta, tied = T){
  #true_survival_time: true survival time
  #stauts: 1--> occurrence 0 --> censored
  #cov: predicting attributes/features/covariates
  #beta: the estimated coefficients associated with different covariates
  status <- as.numeric(status)
  status[status != 0] = 1
  if (length(beta) > 1){
    score = cov %*% beta
  }else{
    score = cov * beta
  }

  if(tied){
    C = survConcordance(Surv(true_survival_time, status) ~ score)
    return(C$concordance)
  }else{
    C = concordance.index(x=score, surv.time=true_survival_time, surv.event=status, method="noether")
    return(C$c.index)
  }
}

eval <- function(post, ground.truth, thres = 0.5, alternative = "greater"){

  #browser()
  ind <- !is.na(post)
  post <- post[ind]
  ground.truth <- ground.truth[ind]

  if(alternative == "greater"){
    p.label <- as.numeric(post > thres)
  }else if(alternative == "less"){
    p.label <- as.numeric(post < thres)
  }

  TP <- sum(p.label * ground.truth)

  TN <- sum((1 - p.label) * (1 - ground.truth))

  FP <- sum(p.label * (1 - ground.truth))

  FN <- sum((1 - p.label) * ground.truth)

  #sensitivity recall  TP/conditional POSITIVE
  sen <- sum(TP)/sum(ground.truth)

  #specifity: TN/conditional NEGATIVE
  spe <- sum(TN)/sum(1 - ground.truth)

  #false discorvery rate: FP/predictive POSITIVE
  fdr <- sum(FP)/sum(p.label)

  #precision: TP/predictive POSITIVE = 1 - FDR
  pre <- sum(TP)/sum(p.label)

  #accuraccy TP+TN/(conditional POSITIVE + conditioal Negative)
  acc <- (sum(TP) + sum(TN))/(length(ground.truth))

  #balanced accuracy
  bacc <- 1/2 * (sum(TP)/sum(ground.truth) + sum(TN)/sum(ground.truth == 0))

  #F1 score  harmonic mean of sensitivity and precision (2TP/(2TP + FN + FP))
  f1 <- 2*sum(TP)/(2*sum(TP) + sum(FN) + sum(FP))

  ##mcc
  mcc1 = sum(TP) * sum(TN) - sum(FP) * sum(FN)
  mcc2 = sqrt((sum(TP) + sum(FP)) * (sum(TP) + sum(FN)) * (sum(TN) + sum(FP)) * (sum(TN) + sum(FN)))
  mcc = mcc1/mcc2

  ##
  ground_positive = sum(ground.truth)
  ground_negative = sum(ground.truth==0)
  predict_positive = sum(p.label)
  predict_negative = sum(1 - p.label)
  true_positive = TP
  true_negative = TN
  percentage_predict_positve = predict_positive/length(p.label)

  retval <- c(sen, spe, fdr, pre, acc, bacc, f1, mcc,
	         ground_positive, ground_negative, predict_positive,
			 predict_negative, true_positive, true_negative,
			 percentage_predict_positve, thres)

  names(retval) <- c("sensitivity", "specifity", "false discovery rate",
  					"precision", "accuracy", "balanced accuracy", "F1 score","MCC",
	   	            "ground_positive", "ground_negative", "predict_positive",
	   			    "predict_negative", "true_positive", "true_negative",
	   			    "percentage_predict_positve", "cutoff")

  retval <- data.frame(t(retval))

  return(retval)
}

plot.ROC <- function(post, ground.truth){

  pred = prediction(post, ground.truth)
  roc = performance(pred, "tpr", "fpr")

  setEPS()
  postscript("ROC.eps")
  plot(roc, lwd=2)
  lines(x=c(0, 1), y=c(0, 1), col="black", lwd=1)
  dev.off()
}

#precision@N
prec_n <- function(post, ground.truth, topN){
  eval.ind <- order(post, decreasing = T)
  post.order <- post[eval.ind]

  ground.truth <- ground.truth[eval.ind]

  precision <- sapply(topN, function(x){
    sum((ground.truth[1:x] == 1))/x
  })

  names(precision) <- as.character(topN)
  return(precision)
}

#recall@N
rcal_n <- function(post, ground.truth, topN){
  eval.ind <- order(post, decreasing = T)
  post.order <- post[eval.ind]

  ground.truth <- ground.truth[eval.ind]

  recall <- sapply(topN, function(x){
    sum((ground.truth[1:x] == 1))/sum(ground.truth)
  })

  names(recall) <- as.character(topN)
  return(recall)
}

#s.precision@N
s.prec_n <- function(post, ground.truth, thres = 0.05, topN){
  ind <- !is.na(post)
  post <- post[ind]
  ground.truth <- ground.truth[ind]

  eval.ind <- order(post, decreasing = F)
  post.order <- post[eval.ind]
  ground.truth <- ground.truth[eval.ind]

  precision <- sapply(topN, function(x){
    sum(!xor(post.order[1:x] < thres, ground.truth[1:x]))/x
  })

  names(precision) <- as.character(topN)
  return(precision)
}

#recall@N
s.rcal_n <- function(post, ground.truth, thres = 0.05, topN){

  N <- sum(ground.truth)

  ind <- !is.na(post)
  post <- post[ind]
  ground.truth <- ground.truth[ind]

  eval.ind <- order(post, decreasing = F)
  post.order <- post[eval.ind]
  ground.truth <- ground.truth[eval.ind]

  recall <- sapply(topN, function(x){
    sum(!xor(post.order[1:x] < thres, ground.truth[1:x]))/N
  })

  names(recall) <- as.character(topN)
  return(recall)
}

#school conformatiy
post.with.school <- function(post, school.id){
  #browser()
  #agg.post <- aggregate(post, list(school.id), mean)

  agg.post <- aggregate(post, list(school.id), function(x){
    if(sum(x > 0.5) < sum(x < 0.5)){
      val <- 0
    }
    else{
      val <- 1
    }
  })

  colnames(agg.post) <- c("id", "post")

  return(agg.post$post)
}

truth.with.school <- function(ground.truth, school.id){
  agg.truth <- aggregate(ground.truth, list(school.id), function(x){
    if(sum(x > 0.5) < sum(x < 0.5)){
      val <- 0
    }
    else{
      val <- 1
    }
  })

  colnames(agg.truth) <- c("id", "truth")

  return(agg.truth$truth)
}

ndcg <- function(post, ground.truth, topN){

  eval.ind <- order(post, decreasing = T)

  post.order <- ground.truth[eval.ind]

  ground.truth.order <- ground.truth[order(ground.truth, decreasing = T)]

  ind <- 2:(length(post.order) + 1)

  pred.dg <- (2^post.order - 1)/log2(ind)
  truth.dg <- (2^ground.truth.order - 1)/log2(ind)
  ndcg <- sapply(topN, function(x){
    val.pred <- sum(pred.dg[1:x])
    val.truth <- sum(truth.dg[1:x])
    val <- val.pred/val.truth
    return(val)
  })

  names(ndcg) <- as.character(topN)

  return(ndcg)
}

school.from.top.com <- function(post, school, topN){

  eval.ind <- order(post, decreasing = T)

  school.order <- school[eval.ind, ]
  school.order <- school.order[1:topN, ]

  val <- unique(school.order[, -1])

  val.lst <- list(school.info = val, n = nrow(val), prec = sum(val$label)/nrow(val))

  return(val.lst)
}

school.t.test <- function(post, school){
  #options(digits=22)
  options(error = recover)

  rslt <- aggregate(post, list(school), function(x){
    #x <- log(x)
    if(length(x) < 2 || sd(x) < 10^(-14)){
      return(NA)
    }else{
      val <- t.test(x, mu = 0.5, alternative = "greater")
      p.value <- val$p.value
      return(p.value)
    }

  })
  #browser()
  colnames(rslt) <- c("SchoolID", "p.value")
  return(rslt)
}

# mean average precision @k
#apk
apk <- function(k, actual, predicted)
{
  score <- 0.0
  cnt <- 0.0

  ind <- order(predicted, decreasing = T)
  predicted <- predicted[ind]
  actual <- actual[ind]

  predicted <- as.numeric(predicted > 0.5)

  for (i in 1:min(k,length(predicted)))
  {
    if (actual[i] == 1)
    {
      cnt <- cnt + 1
      score <- score + cnt/i
    }
  }
  if(sum(actual) == 0)
    score <- 0
  else
    score <- score / min(sum(actual), k)

  return(score)
}

#mapk
mapk <- function (K, actual, predicted)
{
  rslt <- sapply(K, function(k){

    if( length(actual)==0 || length(predicted)==0 )
    {
      return(0.0)
    }

    #browser()
    scores <- rep(0, length(actual))
    for (i in 1:length(scores))
    {
      scores[i] <- apk(k, actual[[i]], predicted[[i]])
    }
    score <- mean(scores)
    return(score)
  })
  names(rslt) <- as.character(K)
  return(rslt)
}

# mapkNZ
mapkNZ <- function (K, actual, predicted){

  rslt <- sapply(K, function(k){
    if( length(actual)==0 || length(predicted)==0 )
    {
      return(0.0)
    }

    count = 0
    #browser()
    scores <- rep(0, length(actual))
    for (i in 1:length(scores))
    {
      scores[i] <- apk(k, actual[[i]], predicted[[i]])
      if(sum(actual[[i]]) != 0)
        count = count + 1
    }
    score <- sum(scores)/count
    return(score)
  })
  names(rslt) <- as.character(K)
  return(rslt)
}

#mean reciprocal rank
mrr <- function(actual, predicted){

  if( length(actual)==0 || length(predicted)==0 )
  {
    return(0.0)
  }

  scores <- rep(0, length(actual))

  score <- mapply(function(x,y){

    ind <- order(y, decreasing = T)
    x_ord <- x[ind]
    x_ord_ind <- which(x_ord == 1)
    if(length(x_ord_ind) == 0)
      rslt <- 0
    else
      rslt <- 1/x_ord_ind[1]

    return(rslt)
  }, actual, predicted)

  retval <- mean(score)

  return(retval)
}

mrrNZ <- function(actual, predicted){

  if( length(actual)==0 || length(predicted)==0 )
  {
    return(0.0)
  }

  scores <- rep(0, length(actual))

  score <- mapply(function(x,y){

    ind <- order(y, decreasing = T)
    y_ord <- x[ind]
    y_ord_ind <- which(y_ord == 1)

    if(length(y_ord_ind) == 0)
      rslt <- 0
    else
      rslt <- 1/y_ord_ind[1]

    return(rslt)
  }, actual, predicted)

  count_vec <- sapply(actual, function(x){
    rslt <- any(x == 1)
    return(rslt)
  })

  retval <- sum(score)/sum(count_vec)

  return(retval)
}
library(caTools)

#' Area under the ROC curve
#'
#' improt ROCR
auc_roc <- function(obs, pred) {
  pred <- prediction(pred, obs)
  auc  <- performance(pred, "auc")@y.values[[1]]
  return(auc)
}

#' Area under Precision-recall curve
#'
#' import ROCR
#' import caTools
auc_pr <- function(obs, pred) {
  xx.df <- prediction(pred, obs)
  perf  <- performance(xx.df, "prec", "rec")
  xy    <- data.frame(recall=perf@x.values[[1]], precision=perf@y.values[[1]])

  # take out division by 0 for lowest threshold
  xy <- subset(xy, !is.nan(xy$precision))

  # Designate recall = 0 as precision = x...arbitrary
  xy <- rbind(c(0, 0), xy)
  #xy <- xy[!(rowSums(xy)==0), ]

  res   <- trapz(xy$recall, xy$precision)
  res
}

# Function to create raw data needed to plot Precision against recall
#
# For a vector of observed and predicted, creates x-y coordinates for a ROC
# or PR curve.
rocdf <- function(pred, obs, data=NULL, type=NULL) {
  # plot_type is "roc" or "pr"
  if (!is.null(data)) {
    pred <- eval(substitute(pred), envir=data)
    obs  <- eval(substitute(obs), envir=data)
  }

  rocr_xy <- switch(type, roc=c("tpr", "fpr"), pr=c("prec", "rec"))
  rocr_df <- prediction(pred, obs)
  rocr_pr <- performance(rocr_df, rocr_xy[1], rocr_xy[2])
  xy <- data.frame(rocr_pr@x.values[[1]], rocr_pr@y.values[[1]])

  # If PR, designate first (undefined) point as recall = 0, precision = x
  if (type=="pr") {
    xy[1, 2] <- 0
    #xy <- xy[!(rowSums(xy)==0), ]
  }

  colnames(xy) <- switch(type, roc=c("tpr", "fpr"), pr=c("rec", "prec"))
  return(xy)
}


readsdssfit <- function(fname, dname="spectra", extcor=TRUE, rest=TRUE) {
  require(FITSio)

  metastrings <- c("PLUG_RA","PLUG_DEC","SPECOBJID","BESTOBJID","PLATE","MJD","FIBERID",
                   "CLASS", "SUBCLASS","Z","Z_ERR","ZWARNING","VDISP","VDISP_ERR",
                   "WAVEMIN","WAVEMAX")
  meta.out <- tolower(metastrings)
  meta.out[meta.out=="plug_ra"] <- "ra"
  meta.out[meta.out=="plug_dec"] <- "dec"

  hd <- readFITS(file.path(dname, fname), hdu=0)
  vals <- hd$col
  names(vals) <- hd$colNames
  vals <- vals[metastrings]
  names(vals) <- meta.out
  meta <- vals
  hd <- readFITS(file.path(dname, fname), hdu=1)
  vals <- hd$col
  names(vals) <- hd$colNames
  lambda <- 10^(vals[["loglam"]])
  flux <- vals[["flux"]]
  ivar <- vals[["ivar"]]
  ivar[ivar <= 0] <- NA
  flux[is.na(ivar)] <- NA
  if (extcor) {
    if (!exists("ebvmap", envir=.GlobalEnv)) {
      data(ebvmap, package="sfdmap", envir=.GlobalEnv)
    }
    lb <- radec2lb(meta$ra, meta$dec)
    ebv <- sfdmap::lookupebv(lb)
    meta$ebv <- ebv
    meta$l <- lb$l
    meta$b <- lb$b
    extc <- elaw(lambda, ebv)
    flux <- flux*extc
    ivar <- ivar/extc^2
  }
  if (rest) {
    lambda <- lambda/(1+meta$z)
  }
  list(meta=meta, lambda=lambda, flux=flux, ivar=ivar)
}


## cumalative frequency histogramic data library
## orignally devloped to process data from tables ACS DP04/Census DP4 for owner-occupied home values
## (c)2017 Michael Penhallegon, All Right Reserved
## contact me: crimson@crimsonfae.net

## libaries
library(dplyr)

## histo is the representation of the histogram buckets and values
##
##  the default is for the home values of census dp4/acs table dp04
##
histo <- data.frame(label = c("0-50,000",
                      "50,000-100,000",
                      "100,000-150,0000",
                      "150,000-200,000",
                      "200,000-300,000",
                      "300,000-500,000",
                      "500,000-1,000,000",
                      "1,000,000 or more"))
histo["upper"] <- c(50000, 100000,
                    150000, 200000,
                    300000, 500000,
                    1000000, 2000000)
histo["lower"] <- c(0,50000,
                    100000, 150000,
                    200000, 300000,
                    500000, 1000000)

#' return_bucket return the text label of the bucket
#'
#' this is used for testing to make sure that value falls inside
#'
#' @param idx the index of the bucket to be returned
#' @return the text label of the bucket at index idx
#' @export
return_bucket <- function(idx){
  return(histo %>% slice(idx) %>% select(label))
}

#' cumul_buckets generate cumalative frequencies
#'
#' converts a histogram data set to cumalative frequencies
#'
#' @param x input histogram vector
#' @return cumulative frequencies vector
#'
#' @examples
#' freq = [1, 4, 5, 3, 1]
#' cumul_buckets(freq)
#'
#' @export
cumul_buckets <- function(x){
  sums = rep(0, length(x))
  for(n in 1:length(x)){
         sums[n] = sum(x[1:n])
     }
  return(sums)
}

#' findbin takes a percentile and returnsa value of % n
#'
#' the target histogramic data buckets and returns which buckets would perc exist in that histogram
#'
#' @param perc percentiles vector
#' @param buckets histogram vector
#'
#' @return integer index of the bin on histo
#'
#' @examples
#' histogram_freq = [10, 20, 40, 10, 0, 0, 1]
#'
#' percentile_20th_idx = perc_findbin(0.5, histogram_freq)
#'
#' median_idx = perc_bin(0.5, histogram_freq)
#' median_idx == median(histogram_freq)
#' @export
perc_findbin <- function(perc, buckets){
  perc_buck = perc * sum(buckets)
  cum_bucks = cumul_buckets(buckets)

  lenb = length(buckets)
  lower = 0
  index = 1
  upper = cum_bucks[index]

  while(index <= lenb){
    if((lower <= perc_buck) & (perc_buck < upper)){
      result = index
      break
    }
    lower = cum_bucks[index]
    index = index + 1
    upper = cum_bucks[index]
  }

  return(result)
}

#' line returns a function that is the line equation
#'
#' returns a line equation in relation to ns of histogram. This will provide a closure that will return the value of the houses.
#'
#' @param idx index of bin integer
#' @param buckets histogram vector
#' @return function of line to calculate
#' @export
n_line <- function(idx, buckets){
  p1 = c(histo$upper[idx], cumul_buckets(buckets)[idx])
  p2 = c(histo$lower[idx], cumul_buckets(buckets)[idx-1])
  if(idx == 1){p2 = c(0,0)}
  findslope <- function(){
    return((p1[2]-p2[2])/(p1[1]-p2[1]))
  }
  m = findslope()

  findb <- function(){
    return(p1[2]-(m*p1[1]))
  }
  b = findb()

  findline <- function(y){
    return((y - b)/m)
  }

  return(findline)
}

#' histo_findbin takes a histogram and return the percentiles values
#'
#' takes a histogram and returns the percentile values. aggregrates findbin and line together
#'
#' @param buckets histogram buckets
#' @param percentiles vector defualts to 20%(0.2) and 80%(0.8
#' @return percentile values as double
#' @export
histo_findbin <- function(buckets, percentiles = c(0.2, 0.8)){
    perc_n <- function(x){x*sum(buckets)}
    ls = percentiles %>% lapply(perc_findbin, buckets) %>% lapply(n_line, buckets)
    cs = percentiles %>% perc_n
    result = c()
    for(n in 1:length(cs)){
        result <- append(result, ls[[n]](cs[n]))
    }

    return(result)
}

#' findctbin takes a value and find the bin tat value would exist based on histo
#'
#' @param val double value bound of percentile
#' @return index of bin on census tract histogram
#' @export
findctbin <- function(val){
  index = 1
  while(index < length(histo$upper)){
    if((histo$upper[index] > val) & (histo$lower[index] <= val)){
      break
    }
    index = index + 1
  }
  return(index)
}

#' ctLine takes the index of a bin and returns a line function mapping
#'
#' a Value to the cumalative number of tracts below that value
#'
#' @param idx interger of bin
#' @param buckets histogram data from cesnsus tract as vector
#' @return closure function to calculate number of homes at percentile
#' @export
ctLine <- function(idx, buckets){
  p1 = c(histo$upper[idx], cumul_buckets(buckets)[idx])
  p2 = c(histo$lower[idx], cumul_buckets(buckets)[idx-1])
  if(idx == 1){p2 = c(0,0)}
  findslope <- function(){
    return((p1[2]-p2[2])/(p1[1]-p2[1]))
  }
  m = findslope()
  findb <- function(){
    return(p1[2]-(m*p1[1]))
  }
  b = findb()
  findline <- function(x){
    return(x*m+b)
  }
  return(findline)
}

#'perc_MSA_2000 is a helper function to compenstate for census 2000
#'
#' Census 2000 did not include MSA home value data but can generate those values from census tract data
#'
#' @param ct_data data.frame of census tract data
#' @param percentiles vector of percentiles
#' @return percentiles values vector
#' @export
percs_MSA_2000 <- function(ct_data, percentiles=c(0.2, 0.8)){
    buckets = ct_data %>% select(HC01_VC63:HC01_VC72) %>% colSums %>% t %>% as.data.frame.ts
    return(histo_histbin(buckets, percentiles=percentiles))
}


################################################################################
##                          HarryPotter.r                                      #
## Harry Potter and RSiena                                                     #
##                                                                             #
## Data prepared by Goele Bossaert and Nadine Meidert.                         #
## Script prepared by Tom Snijders.                                            #
## Date: May 27, 2013                                                          #
## See Goele Bossaert and Nadine Meidert (2013).                               #
## 'We are only as strong as we are united, as weak as we are divided'.        #
## A dynamic analysis of the peer support networks in the Harry Potter books.  #
## Open Journal of Applied Sciences, in press.                                 #
## https://lirias.kuleuven.be/bitstream/123456789/389499/1/Bossaert+%26+Meidert+2013.pdf #
##                                                                             #
################################################################################

# Data available from the Siena website,
# http://www.stats.ox.ac.uk/~snijders/siena/siena_datasets.htm

# Read data
book1 <- as.matrix(read.table("hpbook1.txt"))
book2 <- as.matrix(read.table("hpbook2.txt"))
book3 <- as.matrix(read.table("hpbook3.txt"))
book4 <- as.matrix(read.table("hpbook4.txt"))
book5 <- as.matrix(read.table("hpbook5.txt"))
book6 <- as.matrix(read.table("hpbook6.txt"))
hp.attributes <- as.matrix(read.table("hpattributes.txt", header=TRUE))

# Define basic data and model.
library(RSienaTest)
support <- sienaDependent(array(c(book1, book2, book3, book4, book5, book6),
                               dim=c(64, 64, 6)))
# Attributes:
schoolyear <- coCovar(hp.attributes[,2])
gender     <- coCovar(hp.attributes[,3])
house      <- coCovar(hp.attributes[,4])

# Composition change:
cc <- read.table("compositionchange.dat")
# This file really is for books 1 to 7, but we have no book 7 available here:
cc[cc==7] <- 6
write.table(cc,"compositionchange1to6.dat", row.names = FALSE,
            col.names = FALSE)
inAndOut <- sienaCompositionChangeFromFile("compositionchange1to6.dat")

Hogwarts  <- sienaDataCreate(support, schoolyear, gender, house, inAndOut)
Hogwarts
Rowling <- getEffects(Hogwarts)
print01Report(Hogwarts, Rowling, "Hogwarts")
# The report shows a large heterogeneity in degrees between waves.

# Model specification:
Rowling <- includeEffects(Rowling, transTies, transRecTrip)
Rowling <- includeEffects(Rowling, egoX, altX, simX, interaction1="gender")
Rowling <- includeEffects(Rowling, simX, interaction1="schoolyear")
Rowling <- includeEffects(Rowling, sameX, interaction1="house")

EstAlgorithm <- sienaAlgorithmCreate(projname="Hogwarts", cond=FALSE)
supportResults1 <- siena07(EstAlgorithm, data=Hogwarts, effects=Rowling, verbose=TRUE)

tt1 <- sienaTimeTest(supportResults1)
summary(tt1)

# The heterogeneity is excessive. Further analyze only from book 2 to book 4.
# Who are the actors (characters) in books 2-3-4?
use <- (cc[,1] <= 2) & (cc[,2] >= 4)
sum(use)

# Define data restricted to books 2-4.
schoolyear.24 <- coCovar(hp.attributes[use,2])
gender.24     <- coCovar(hp.attributes[use,3])
house.24      <- coCovar(hp.attributes[use,4])
# Make available a variable to represent time heterogeneity.
times <- cbind(rep(1,46), rep(2, 46), rep(3, 46))
time.24 <- varCovar(times)

support.24 <- sienaDependent(array(c(book2[use,use], book3[use,use], book4[use,use]),
                               dim=c(46, 46, 3)))
# And for the composition change:
cc.24 <- cc[use,]-1
cc.24[cc.24 < 1] <- 1
cc.24[cc.24 > 3] <- 3
range(cc.24)
# No composition change for books 2 to 4.

Hogwarts.24  <- sienaDataCreate(support.24, schoolyear.24, gender.24, house.24, time.24)
Hogwarts.24
Rowling.24 <- getEffects(Hogwarts.24)
print01Report(Hogwarts.24, Rowling.24, "Hogwarts.24")

# Model specification, and a progressive series of model fits.
Rowling.24 <- includeEffects(Rowling.24, transTies)
Rowling.24 <- includeEffects(Rowling.24, egoX, altX, simX, interaction1="gender.24")
Rowling.24 <- includeEffects(Rowling.24, simX, interaction1="schoolyear.24")
Rowling.24 <- includeEffects(Rowling.24, sameX, interaction1="house.24")
Rowling.24 <- includeEffects(Rowling.24, egoX, interaction1="time.24")

EstAlgorithm <- sienaAlgorithmCreate(projname="Hogwarts24")
supportResults1.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24)
supportResults1.24
# In my case, convergence was not perfect: try again.
supportResults2.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24,
						prevAns=supportResults1.24)
supportResults2.24

Rowling.24 <- includeEffects(Rowling.24, transTrip, cycle3)
(supportResults3.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24,
						prevAns=supportResults2.24))

Rowling.24 <- includeEffects(Rowling.24, transRecTrip, include=FALSE)
Rowling.24 <- includeEffects(Rowling.24, sameX, interaction1="house.24", include=FALSE)
supportResults4.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24,
						prevAns=supportResults3.24)
tt4.24 <- sienaTimeTest(supportResults4.24)
summary(tt4.24)

Rowling.24 <- includeInteraction(Rowling.24, simX, egoX,
						interaction1=c("schoolyear.24", "time.24"))
Rowling.24 <- includeInteraction(Rowling.24, simX, egoX,
						interaction1=c("gender.24", "time.24"))
supportResults5.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24,
						prevAns=supportResults4.24)
tt5.24 <- sienaTimeTest(supportResults5.24)
summary(tt5.24)

Rowling.24 <- includeEffects(Rowling.24, egoX, altX, interaction1="gender.24",
								include=FALSE)
Rowling.24 <- includeEffects(Rowling.24, simX, interaction1="gender.24")
(supportResults6.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24,
						prevAns=supportResults5.24))
tt6.24 <- sienaTimeTest(supportResults6.24)
summary(tt6.24)
# OK

# And now some goodness-of-fit testing.
# This requires RSiena(Test) version 1.1-231 or higher.
supportResults0.24 <- siena07(EstAlgorithm, data=Hogwarts.24, effects=Rowling.24,
                      returnDeps=TRUE)

(gof0.24id <- sienaGOF(supportResults0.24, verbose=TRUE, levls=(1:15),
					varName="support.24", IndegreeDistribution))
plot(gof0.24id)
# The outlying Harry Potter (indegrees 18, 15, 10) is not represented very well.

(gof0.24od <- sienaGOF(supportResults0.24, verbose=TRUE, varName="support.24",
				levls=(1:10), OutdegreeDistribution))
plot(gof0.24od)
# good.

library(sna)
# Take the GeodesicDistribution and the TriadCensus from the help page
# sienaGOF-auxiliary in RSiena(Test) version 1.1-231 or higher.

(gof0.24gd <- sienaGOF(supportResults0.24, verbose=TRUE,
					varName="support.24", GeodesicDistribution))
plot(gof0.24gd)

(gof0.24tc <- sienaGOF(supportResults0.24, verbose=TRUE,
					varName="support.24", TriadCensus))
plot(gof0.24tc, scale=TRUE, center=TRUE)

# Further possibilities: test if Harry Potter is different from the rest,
# by making a dummy variable for actor 25 = HJP and testing e.g. the altX effect.
# See above for the somewhat poor goodness of fit for the indegree distribution.