# Estructuras de repetición

# --------------------------------------------------------------------------------
# for
for (i in 1:3) print(i^2)

for (letra in letters[1:3]) print(letra)

lista <- list(matrix(1:6, 2, 3), 1:2)
for (i in lista) print(i)

# El ciclo se puede interrumpir en cualquier momento usando break, next o return.
# Esta última opción está asociada a funciones.

for (i in 1:5) if (i %% 2 == 0) print(i) else next

set.seed(1)
x <- runif(100)
suma <- 0

for (i in 1:100) {
    suma <- suma + x[i]
    if (suma > 0.5) {
        print(paste("Me paro en i=", i, "porque la suma supera 0.5"))
        break
    }
}

f <- function(x) {
    suma <- 0
    for (i in seq_along(x)) {
        suma <- suma + x[i]
        if (suma > 0.5) {
            return(paste("Me paro en i=", i, "porque la suma supera 0.5"))
        }
    }
    return(paste("He completado el ciclo y la suma es", suma))
}

f(rep(0.1, 4))
f(rep(0.1, 10))

# --------------------------------------------------------------------------------
# while

set.seed(1)
i <- suma <- 0
x <- numeric()
while (suma < 0.5) {
    i <- i + 1
    x[i] <- runif(1, 0, 0.1) # uniforme en (0,0.1)
    suma <- suma + x[i]
}
print(round(x, 4))
# --------------------------------------------------------------------------------

# repeat: bucle infinito
set.seed(1)
i <- suma <- 0
x <- numeric()
repeat{
    i <- i + 1
    x[i] <- runif(1, 0, 0.1) # uniforme en (0,0.1)
    suma <- suma + x[i]
    if (suma >= 0.5) break
}
print(round(x, 4))

# --------------------------------------------------------------------------------
# Equivalencia entre bucles

# Es posible reescribir cualquier ciclo for usando while. También, cualquier ciclo while
# se puede escribir usando repeat. Esto signica que while es más exible que for, y que
# repeat es más exible que while. Una buena práctica en la programación en R es usar
# siempre la solución menos exible a un problema, lo que nos lleva a elegir for siempre
# que sea posible.

# La misma regla anterior nos llevará a evitar ciclos for cuando podamos resolver el
# problema usando funciones vectoriales, o adecuadas para la estructura de datos concreta
# que estemos trabajando

# 1
x <- 1:5
suma <- 0
for (i in seq_along(x)) suma <- suma + x[i]
suma / length(x)

# 2. En R es más conveniente y seguro
sum(x) / length(x)

# Otro ejemplo:
A <- matrix(1:6, 2, 3)
sumas.filas <- numeric(nrow(A))
for (i in seq_lenght(nrow(A))) { # seq_length === 1:
    for (j in seq_length(ncol(A))) sumas.filas[i] <- sumas.filas[i] + A[i, j]
}
sumas.filas

# Alternativa mejorada:
rowSums(A)

# --------------------------------------------------------------------------------
# La misma idea:
#
# --- FAMILIA APPLY --------------------------------------------------------------
#
# Funciones lapply y sapply

lista <- list(v1 = 1:10, v2 = factor(), v3 = letters[1:4])
lapply(lista, length)

df <- data.frame(matrix(1:6, 2, 3))
lapply(df, mean)

sapply(lista, length)

# Función apply
# MARGIN especicaría la
# dimensión donde vamos a operar. Si X es una matriz entonces MARGIN=1 operaría por filas,
# MARGIN=2 por columnas, y MARGIN=c(1,2) lo haría por filas y columnas.

A <- cbind(1:4, seq(0, 1, length.out = 4), (1:4)^2)
apply(A, 1, median) # mediana por filas

apply(A, 2, var) # cuasivarianza por columnas
apply(A, c(1, 2), sqrt)

# --------------------------------------------------------------------------------
# Función split

# Esta función permite clasicar datos consistentes en vectores, matrices o data frames
# de acuerdo a un criterio de clasicación.
help("split")

Orange
arboles <- split(Orange, Orange$Tree)
lapply(arboles, head, n = 2)

# Como segundo ejemplo consideramos la tarea consistente primero en obtener y mostrar
# las diagonales de una matriz cuadrada, y después calcular sus sumas.
A <- matrix(1:9, 3, 3)
diagonales <- split(A, col(A) + row(A)) # TODO: add to cheatsheet
diagonales
sapply(diagonales, sum)

# --------------------------------------------------------------------------------
# Funciones de clasificación y agrupación: by, aggregate y tapply

aggregate(Orange$age, by = list(Orange$Tree), summary)

by(Orange$age, Orange$Tree, summary)

tapply(Orange$age, Orange$Tree, summary)

# --------------------------------------------------------------------------------
# Recursividad
# Una función pueda hacer referencia a la propia función.
# Esto permite crear estructuras definidas fácilmente por recursividad.
# Consume muchos recursos por lo que deben siempre valorarse otras alternativas.

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

log.natural <- function(x) {
    if (missing(x) || !is.numeric(x)) {
        stop("Debe proporcionar un argumento 'x' numérico")
    } else if (any(x <= 0)) {
        x <- x[x > 0]
        warning("Se han eliminado los valores negativos o cero")
    }
    return(log(x))
}

log.natural()
log.natural(-1:5)

#
# --- DEPURACION DE ERRORES: DEBUGGING -------------------------------------------

# traceback, browser y debug.
# --------------------------------------------------------------------------------
# traceback

f <- function(x) {
    n <- round(x)
    set.seed(n)
    u <- runif(n)
    return(u)
}

mean(f(-2))
traceback()

# --------------------------------------------------------------------------------
# browser

f <- function(x) {
    browser()
    n <- round(x)
    set.seed(n)
    u <- runif(n)
    return(u)
}

mean(f(-2))

# --------------------------------------------------------------------------------
# debug

f <- function(x) {
    n <- round(x)
    set.seed(n)
    u <- runif(n)
    return(u)
}

debug(f)
debug(mean)
mean(f(2))
undebug(f)
undebug(mean)

# debugonce es debug pero sin necesidad de undebug: sólo se hace interactivo una vez

factorial.d <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    fact <- 1
    if (n > 1) for (i in 1:n) fact <- fact * i
    return(fact)
}
factorial.d(5)
factorial.d(0)
factorial.d(100)
factorial.d(5000)

factorial.r <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    if (n > 1) fact <- n * factorial.r(n - 1) else fact <- 1
    return(fact)
}
factorial.r(5)
factorial.r(100)
factorial.r(5000)
factorial.v <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    if (n > 1) fact <- prod(n:1) else fact <- 1
    return(fact)
}
factorial.v(5)
factorial.v(100)
factorial.v(5000)

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

# benchmarking

factorial.d <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    t1 <- Sys.time() # tiempo inicial
    fact <- 1
    if (n > 1) for (i in 1:n) fact <- fact * i
    t2 <- Sys.time() # tiempo final
    return(list(factorial = fact, tiempo = t2 - t1))
}

factorial.v <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    t1 <- Sys.time() # tiempo inicial
    if (n > 1) fact <- prod(n:1) else fact <- 1
    t2 <- Sys.time() # tiempo final
    return(list(factorial = fact, tiempo = t2 - t1))
}

factorial.d(10000000)
factorial.v(10000000)
#
# --- SUCESION DE FIBONNACI ------------------------------------------------------
#
# Recursivo
Fibonacci.r <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    if (n == 0) {
        return(0)
    } else if (n <= 2) {
        return(1)
    } else {
        return(Fibonacci.r(n - 1) + Fibonacci.r(n - 2))
    }
}

Fibonacci.r(5)
Fibonacci.r(20)

# Constructivo, construyendo una tabla
Fibonacci.v <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    v <- integer(n)
    v[1:2] <- 1
    for (i in 3:n) v[i] <- v[i - 1] + v[i - 2]
    return(v[n])
}

Fibonacci.v(5)

# benchmarking
t1 <- Sys.time()
Fibonacci.r(30)
t2 <- Sys.time()
print(t2 - t1)
# Nota: tarda unos 2 <-> 3 segundos.
# La complejidad algorítmica exponencial (para n + 1 hace aproximadamente el doble de cálculos)
# de esta implementación llevaría a que  Fibonacci.r(300) tardase
# el mismo tiempo (2.5 segundos) multiplicado por 2^(300-30) == 2^270 ~= 10^81 s ~= 10^67 millones de años
# si lees esto, me daba curiosidad bro, viva la algorítmica
t1 <- Sys.time()
Fibonacci.v(200)
t2 <- Sys.time()
print(t2 - t1)

# --------------------------------------------------------------------------------
# Ejercicio 4
Fibonacci.v.mod <- function(n) {
    if (missing(n) || !is.numeric(n)) {
        return(NA)
    }
    n <- as.integer(n)
    v <- integer(n)
    v[1:2] <- 1
    for (i in 3:n) v[i] <- v[i - 1] + v[i - 2]

    ret <- list()
    ret[[1]] <- v[n]
    ret[[2]] <- v
    ret[[3]] <- sum(v)
    return(ret)
}

Fibonacci.v.mod(20)
# ────────────────────────────────────────────────────────────────────────────────

# Fibonacci recursivo eficiente. Esto ya no es parte de la clase.
Fibonacci.r.mod <- function(n) {
    cache <- c(1, 1)
    # Comprobaciones ...
    #
    fib <- function(n) {
        if (n <= length(cache)) {
            return(cache[[n]])
        } else {
            cache[[n]] <<- fib(n - 1) + fib(n - 2)
            return(cache[[n]])
        }
    }
    return(fib(n))
}

t1 <- Sys.time()
Fibonacci.r.mod(300)
t2 <- Sys.time()
print(t2 - t1)


#install.packages("nlrwr")
#install.packages("minpack.lm")
#install.packages("leaps")
#install.packages("mgcv")

library("minpack.lm")
require("foreign")
require("data.table")
require("MASS")

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Fitting a logistic function similar to that of Preston (1976)  a/(1+exp(B+exp(lnC*GDP))
# output: alpha, beta & C [model: alpha/(1+exp(beta + exp(ln(C)*dgp))) ], BIC and AIC
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
logfnS<-function(gdp.pc,alpha,beta,C){
  alpha / (1 + exp( beta + exp(log(C) * gdp.pc )))
 }

 # Logistic fitting
log.fnS<-function(data){
  datos<-na.omit(data)
 # estimating starting values for the parameters. Assume alpha=1, then estimate logit(yvar)=beta+gamma^GDP
   yvar <- datos$yvar/(1.05 * max(datos$yvar)) # scale to within unit height
   datos$z <- log(yvar/(1 - yvar))             # logit transformation
	 pars<- nls(z ~ beta+exp(log(C)*gdp.pc),
      data=datos,
      start=list(beta=1,C=1))
   nlsFormula <- "yvar ~ logfnS(gdp.pc,alpha,beta,C)"
   nlsInitial <- c(alpha=max(datos$yvar),coef(pars)[1],coef(pars)[2])
   mod1<-nlsLM(formula = nlsFormula,
     data=datos,
     start=nlsInitial,
     control=nls.lm.control(maxiter=1000))
     #,lower=c(30,-1000,-1000),upper=c(90,1000,1000))
     MSE.p <- mean(residuals(mod1)^2)
   return(data.frame(
     alpha=coef(mod1)[1],
     beta=coef(mod1)[2],
     C=coef(mod1)[3],
     alpha.se=summary(mod1)$coefficients[1,2],
     beta.se=summary(mod1)$coefficients[2,2],
     C.se=summary(mod1)$coefficients[3,2],
     MSE=MSE.p))
}
# foo<-datos[,c("gdp.pc","year","median")];setnames(foo,colnames(foo),c("gdp.pc","year","yvar"))
# foo<-subset(foo,year>1950)
#example: log.fnS(data=foo)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Predicting values from a logistic function
# pars: alpha,gamma,beta [model: alpha/(1+exp((dgp-gamma)*beta)) ]
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
pred.log.fnS<-function(pars,newX){
	alpha<-pars[1]
	beta<-pars[2]
	C<-pars[3]
	out<-unlist(apply(rbind(newX),2,FUN=function(x) alpha/(1 + exp(beta+exp(log(C)*x)))))
  return(out)
}
#example:
# pred.log.fnS(pars=log.fnS(data=dat2),newX=quantile(dat2$gdp.pc,probs=seq(0,1,0.25),na.rm=T))

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Fitting a logistic function
# output: alpha, gamma & beta [model: alpha/(1+exp((dgp-gamma)*beta)) ], BIC and AIC
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
logfn<-function(gdp.pc,alpha,gamma,beta){
  alpha/(1 + exp((gdp.pc-gamma)*beta))
 }
 # Logistic fitting
log.fn<-function(data){
 datos<-na.omit(data)
 nlsFormula <- "yvar ~ logfn(gdp.pc,alpha,gamma,beta)"
 nlsInitial <- c(alpha=max(datos$yvar),gamma=mean(datos$gdp.pc),beta=1/mean(datos$year))
 mod1<-nlsLM(formula = nlsFormula, data=datos,start=nlsInitial,control=nls.lm.control(maxiter=1000))
 MSE.p <- mean(residuals(mod1)^2)
 return(data.frame(alpha=coef(mod1)[1],gamma=coef(mod1)[2],beta=coef(mod1)[3],
 	                 alpha.se=summary(mod1)$coefficients[1,2],gamma.se=summary(mod1)$coefficients[2,2],beta.se=summary(mod1)$coefficients[3,2],
 	                 MSE=MSE.p))
}
# foo<-datos[,c("gdp.pc","year","median")];setnames(foo,colnames(foo),c("gdp.pc","year","yvar"))
# foo<-subset(foo,year>1950)
#example: log.fn(data=foo)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Predicting values from a logistic function
# pars: alpha,gamma,beta [model: alpha/(1+exp((dgp-gamma)*beta)) ]
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
pred.log.fn<-function(pars,newX){
	alpha<-pars[1]
	gamma<-pars[2]
	beta<-pars[3]
	out<-unlist(apply(rbind(newX),2,FUN=function(x) alpha/(1 + exp((x-gamma)*beta))))
  return(out)
}
#example:
# pred.log.fn(pars=log.fn(datos=dat2),newX=quantile(dat2$gdp.pc,probs=seq(0,1,0.25),na.rm=T))

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Fitting a Box-Cox function
# output: lambda (for Box-Cox), alpha & beta [model: Box-Cox(Y) = alpha+beta*log(dgp)], BIC and AIC
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
# Box-Cox with free lambda, lambda -> (0,3), if lambda=0 --> log(yvar)= alpha + beta*log(gdp)
free.bx.fn<-function(datos){
foo<-boxcox(yvar~log(gdp.pc),data=datos,plotit=F,lambda=seq(0,3,0.01))
 lambda1<-foo$x[foo$y==max(foo$y)]
 if(lambda1==0) datos$yvar2<-log(datos$yvar)
 if(lambda1>0) datos$yvar2<-(datos$yvar^lambda1 -1)/lambda1
  mod1<-lm(yvar2~log(gdp.pc),data=datos)
	pred<-pred.free.bx.fn(pars=data.frame(lambda=lambda1,alpha=coef(mod1)[1],beta=coef(mod1)[2]),newX=datos$gdp.pc)
	MSE.p<-sum((datos$yvar-pred)^2,na.rm=T)/dim(datos)[1]
return(data.frame(lambda=lambda1,alpha=coef(mod1)[1],beta=coef(mod1)[2],alpha.se=summary(mod1)$coefficients[1,2],beta.se=summary(mod1)$coefficients[2,2],
       MSE=MSE.p))
}
#example: free.bx.fn(datos=foo)

# Box-Cox with lambda=0 so the model is log(yvar)= alpha + beta*log(gdp)
bx.fn<-function(datos){
  mod1<-lm(log(yvar)~log(gdp.pc),data=datos)
	pred<-pred.bx.fn(pars=data.frame(alpha=coef(mod1)[1],beta=coef(mod1)[2]),newX=datos$gdp.pc)
	MSE.p<-sum((datos$yvar-pred)^2,na.rm=T)/dim(datos)[1]
 return(data.frame(alpha=coef(mod1)[1],beta=coef(mod1)[2],alpha.se=summary(mod1)$coefficients[1,2],beta.se=summary(mod1)$coefficients[2,2],
	    MSE=MSE.p))
}
#example: bx.fn(datos=foo)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Predicting values from a linear model using Box-Cox transformation
# pars: lambda [Box-Cox], alpha,beta [model: alpha+beta*log(dgp) ]
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
# Box-Cox with free lambda, if lambda=0 --> log(yvar)= alpha + beta*log(gdp)
pred.free.bx.fn<-function(pars,newX){#pars=coeff1,newX=q1
	lambda<-pars[1]
	alpha<-pars[2]
	beta<-pars[3]
	bxcx.y<-unlist(tapply(as.vector(newX),1:length(newX),FUN=function(x) alpha+beta*log(x)))
	if(lambda==0) out<-unlist(tapply(as.vector(bxcx.y),1:length(bxcx.y),FUN=function(x) exp(x)))
	if(lambda>0)  out<-unlist(tapply(as.vector(bxcx.y),1:length(bxcx.y),FUN=function(x) (x*lambda + 1)^(1/lambda)))
  return(out)
}

# Box-Cox with lambda=0
pred.bx.fn<-function(pars,newX){
	alpha<-pars[1]
	beta<-pars[2]
	bxcx.y<-unlist(tapply(as.vector(newX),1:length(newX),FUN=function(x) alpha+beta*log(x)))
	out<-unlist(tapply(as.vector(bxcx.y),1:length(bxcx.y),FUN=function(x) exp(x)))
  return(out)
}
#example:
# pred.bx.fn(pars=bx.fn(datos=dat1),newX=quantile(dat1$gdp.pc,probs=seq(0,1,0.25),na.rm=T))

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes predicts life exp between the lowest and highest quartile of income
# with respect to the median. It uses a logistic or free Box-Cox fitting
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
ex.pred<-function(data,fitting,indices){
	tmp<-data
	tmp<-tmp[indices,]
	q1<-quantile(tmp$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
  if(fitting=="logistic") {
 	coeff1<-log.fn(data=tmp)#;print(coeff1)
 	p1<-pred.log.fn(pars=coeff1,newX=q1)
  diff1<-p1[2]-p1[1]
  diff2<-p1[3]-p1[2]
  out<-c(diff1,diff2); names(out)<-c("median.minus.q1","q3.minus.median")
 }
  if(fitting=="free-boxcox") {
 	coeff1<-free.bx.fn(datos=tmp)#;print(coeff1)
 	p1<-pred.free.bx.fn(pars=coeff1,newX=q1)
  diff1<-p1[2]-p1[1]
  diff2<-p1[3]-p1[2]
  out<-c(diff1,diff2); names(out)<-c("median.minus.q1","q3.minus.median")
 }
 return(out)
}
#example: tmp<-datos[,c("year","gdp.pc","median")]
#nms<-colnames(tmp);nms[nms=="median"]<-"yvar";colnames(tmp)<-nms
#ex.pred(data=subset(tmp,year>=1950),fitting="free-boxcox")
#tmp<-boot(data=subset(tmp,year<1950),fitting="free-boxcox",statistic=ex.pred,R=5)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes a dataset and estimates a logistic or Box-Cox, it then selects the best model as min(MSE)
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
best.fit<-function(data){
 bx1<-free.bx.fn(datos=data);bxn<-c("lambda","alpha","beta","MSE") #BX:   lambda, alpha, beta
 log1<-log.fn(data=data)   ;lon<-c("alpha","gamma","beta","MSE")  #log:  alpha, gamma, beta
 log1S<-log.fnS(data=data) ;lsn<-c("alpha","beta","C","MSE")     #logS: alpha, beta, C
 coef<-rep(NA,length(bxn)+length(lon)+length(lsn)); names(coef)<-c(paste("FB",bxn,sep="."),paste("Lg",lon,sep="."),paste("LS",lsn,sep="."))
 min1<-min(bx1$MSE,log1$MSE,log1S$MSE)
  if(bx1$MSE==min1)   { coef[1:4]<-bx1[bxn] }
	if(log1$MSE==min1)  { coef[5:8]<-log1[lon] }
  if(log1S$MSE==min1) { coef[9:12]<-log1S[lsn] }
 return(unlist(coef))
}
#example: best.fit(data=dat1)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes the two datasets and estimates \Delta(i) using a logistic or Box-Cox fitting
# fitting: logistic, Sam.logistic, free-boxcox, constraint-boxcox
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
Delta.fn<-function(datos1,datos2,yvar,fitting){
	dat1<-datos1
	dat2<-datos2
  nms<-colnames(dat1);nms[nms==yvar]<-"yvar";setnames(dat1,colnames(dat1),nms)
  nms<-colnames(dat2);nms[nms==yvar]<-"yvar";setnames(dat2,colnames(dat2),nms)
  q1<-quantile(dat1$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
  q2<-quantile(dat2$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
 if(fitting=="logistic") {
 	coeff1<-log.fn(data=dat1)#;print(coeff1)
 	coeff2<-log.fn(data=dat2)#;print(coeff2)
 	p1<-pred.log.fn(pars=coeff1,newX=q1)
  p2<-pred.log.fn(pars=coeff2,newX=q2)
	pi1<-pred.log.fn(pars=coeff2,newX=q1)
	pi2<-pred.log.fn(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
	setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
 if(fitting=="Sam.logistic") {
 	coeff1<-log.fnS(data=dat1)#;print(coeff1)
 	coeff2<-log.fnS(data=dat2)#;print(coeff2)
 	p1<-pred.log.fnS(pars=coeff1,newX=q1)
  p2<-pred.log.fnS(pars=coeff2,newX=q2)
	pi1<-pred.log.fnS(pars=coeff2,newX=q1)
	pi2<-pred.log.fnS(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
	setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
 if(fitting=="constraint-boxcox") {
 	coeff1<-bx.fn(datos=dat1)
 	coeff2<-bx.fn(datos=dat2)
 	p1<-pred.bx.fn(pars=coeff1,newX=q1)
  p2<-pred.bx.fn(pars=coeff2,newX=q2)
	pi1<-pred.bx.fn(pars=coeff2,newX=q1)
	pi2<-pred.bx.fn(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
  setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
 if(fitting=="free-boxcox") {
  coeff1<-free.bx.fn(datos=dat1)
 	coeff2<-free.bx.fn(datos=dat2)
 	p1<-pred.free.bx.fn(pars=coeff1,newX=q1)
  p2<-pred.free.bx.fn(pars=coeff2,newX=q2)
	pi1<-pred.free.bx.fn(pars=coeff2,newX=q1)
	pi2<-pred.free.bx.fn(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
  setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
return(out)
}

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes the best fitting model in terms of lowest MSE in each period, <1950, 1950+ and then
# estimates \Delta(i) using the best model in each period
# fitting: logistic or boxcox
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
Delta.best.fn<-function(coef1,coef2,p1,p2,pi1,pi2,q1){
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2)); names(Delta)<-"Delta"
	return(unlist(c(Delta,as.vector(coef1),as.vector(coef2))))
}

#DeltaK.fn<-function(dattos,indices){	#
DeltaK.fn<-function(dattos){	#
	tmp<-na.omit(dattos)
#	tmp<-tmp[indices,]#these indices are used for the bootstrap
  dat1<-tmp[tmp$year<1950,]; dat2<-tmp[tmp$year>=1950,]

	q1<-quantile(dat1$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
  q2<-quantile(dat2$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)

  log1<-log.fn(data=dat1); log1S<-log.fnS(data=dat1); bx12<-free.bx.fn(datos=dat1); bx1<-bx.fn(datos=dat1)
  log2<-log.fn(data=dat2); log2S<-log.fnS(data=dat2); bx22<-free.bx.fn(datos=dat2); bx2<-bx.fn(datos=dat2)
  if(log1$MSE>100) log1$MSE<-100;if(log1S$MSE>100) log1S$MSE<-100;if(bx1$MSE>100) bx1$MSE<-100;if(bx12$MSE>100) bx12$MSE<-100
  if(log2$MSE>100) log2$MSE<-100;if(log2S$MSE>100) log2S$MSE<-100;if(bx2$MSE>100) bx2$MSE<-100;if(bx22$MSE>100) bx22$MSE<-100

  min1<-min(log1$MSE,log1S$MSE,bx1$MSE,bx12$MSE)#
  min2<-min(log2$MSE,log2S$MSE,bx2$MSE,bx22$MSE)#

	bxn<-c("lambda","alpha","beta","MSE");lon<-c("alpha","gamma","beta","MSE");lsn<-c("alpha","beta","C","MSE"); cont.bx<-c("alpha","beta","MSE")
	coef1<-rep(NA,length(bxn)+length(lon)+length(lsn));coef2<-rep(NA,length(bxn)+length(lon)+length(lsn))
	names(coef1)<-names(coef2)<-c(paste("FB",bxn,sep="."),paste("Lg",lon,sep="."),paste("LS",lsn,sep="."))

  if(log1$MSE==min1)  { coeff1<-log1; coef1[5:8]<-coeff1[lon];  p1<-pred.log.fn(pars=coeff1,newX=q1);    pi2<-pred.log.fn(pars=coeff1,newX=q2) }
  if(log1S$MSE==min1) { coeff1<-log1S;coef1[9:12]<-coeff1[lsn]; p1<-pred.log.fnS(pars=coeff1,newX=q1);   pi2<-pred.log.fnS(pars=coeff1,newX=q2) }
	if(bx12$MSE==min1)  { coeff1<-bx12; coef1[1:4]<-coeff1[bxn]; p1<-pred.free.bx.fn(pars=coeff1,newX=q1);pi2<-pred.free.bx.fn(pars=coeff1,newX=q2) }
  if(bx1$MSE==min1)   { coeff1<-bx1;  coef1[1:4]<-c(0,coeff1[cont.bx]);  p1<-pred.bx.fn(pars=coeff1,newX=q1);     pi2<-pred.bx.fn(pars=coeff1,newX=q2) }

	if(log2$MSE==min2)  { coeff2<-log2; coef2[5:8]<-coeff2[lon];  p2<-pred.log.fn(pars=coeff2,newX=q2);    pi1<-pred.log.fn(pars=coeff2,newX=q1) }
  if(log2S$MSE==min2) { coeff2<-log2S;coef2[9:12]<-coeff2[lsn]; p2<-pred.log.fnS(pars=coeff2,newX=q2);   pi1<-pred.log.fnS(pars=coeff2,newX=q1) }
  if(bx22$MSE==min1)  { coeff2<-bx12; coef2[1:4]<-coeff2[bxn];  p2<-pred.free.bx.fn(pars=coeff2,newX=q2);pi1<-pred.free.bx.fn(pars=coeff2,newX=q1) }
  if(bx2$MSE==min2)   { coeff2<-bx2;  coef2[1:4]<-c(0,coeff2[cont.bx]);   p2<-pred.bx.fn(pars=coeff2,newX=q2);     pi1<-pred.bx.fn(pars=coeff2,newX=q1) }

  #setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep="."));setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep="."))
	names(coef1)<-paste(names(coef1),1,sep=".")
  names(coef2)<-paste(names(coef2),2,sep=".")
	return(Delta.best.fn(coef1=coef1,coef2=coef2,p1=p1,p2=p2,pi1=pi1,pi2=pi2,q1=q1))
}
# example:
#foo<-na.omit(data.frame(yvar=N.samples[[1]],gdp.pc=datos$gdp.pc,year=datos$year))
# DeltaK.fn(dattos=foo)


tanimoto_traits <- function(resource_x, resource_y, trait_x, trait_y, trait_weight) {
    # The Tanimoto similarity with traits measures the similarity between vectors of traits as well as similarity between vectors of resources
    # tanimotot(x; y;wt) = wttanimoto(xt; yt) + (1 􀀀 wt)tanimoto(xi; yi);
    # If trait_weight == 1, only traits are used for similarity measurement
    # If trait_weight == 0, only shared resources measures the similarity between species

    # !!! Does it make sense to measure taxonomic proximity linearly like this? I need to look into taxonomic proximity measurements in packages like rphylo !!!

    return(trait_weight * tanimoto(trait_x, trait_y) + (1 - trait_weight) * tanimoto(resource_x, resource_y))
}


##Corrected 114/117 ratio=ROUND(((A114-0.02*A115)/(A117-0.049* A116)),3)
##Corrected 115/117 ratio=ROUND(((A115-0.03*A116-0.063*A114)/(A117-0.049* A116)),3)
##Corrected 116/117 ratio=ROUND(((A116-0.04*A117-0.06*A115)/(A117-0.049* A116)),3)

sourceFileName = "Q_4p_S2_for_quantitation_noMis.txt"
outputFileName = paste(
                    paste(
                            strsplit(sourceFileName, "\\.")[[1]][1],
                            "_IC",
                            sep=""
                         ),
                            strsplit(sourceFileName, "\\.")[[1]][2],
                            sep="."
                      )

# read source table
sourceData = read.delim( sourceFileName, check.names = F)

# 114 ratio
A114 = sourceData[,4]
A115 = sourceData[,5]
A116 = sourceData[,6]
A117 = sourceData[,7]
sourceData[,4] = round(((A114-0.02*A115)/(A117-0.049* A116)),3)
sourceData[,5] = round(((A115-0.03*A116-0.063*A114)/(A117-0.049* A116)),3)
sourceData[,6] = round(((A116-0.04*A117-0.06*A115)/(A117-0.049* A116)),3)
sourceData[,7] = 1

write.table( sourceData, file= outputFileName, quote=F, sep='\t', na="", row.names=F)


# Returning values from a function

# A. Returning values from functions
# 1. Returning early
# Should a result occur earlier in the function then a result can be returned early without having to run the entire function
is_leap_year <- function(year) {
  # If year is div. by 400 return TRUE
  if(year %% 400 == 0) {
    return(TRUE)
  }
  # If year is div. by 100 return FALSE
  if(year %% 100 == 0) {
    return(FALSE)
  }
  # If year is div. by 4 return TRUE
  if(year %% 4 == 0) {
    return(TRUE)
  }

  # Otherwise return FALSE
  return(FALSE)
}

# 2. Return invisibly
# Define a pipeable plot fn with data and formula args
pipeable_plot <- function(data, formula) {
  # Call plot() with the formula interface
  plot(formula, data = data)
  # Invisibly return the input dataset
  invisible(data)
}

# Draw the scatter plot of dist vs. speed again
plt_dist_vs_speed <- cars %>%
  pipeable_plot(dist ~ speed)

# Now the plot object has a value
plt_dist_vs_speed

# B. Returning multiple values from functions
# 1. Returning many things
# If users want to have the list items as separate variables, they can assign each list element to its own variable using zeallot's multi-assignment operator, %<-%.
# Look at the structure of model (it's a mess!)
str(model)

# Use broom tools to get a list of 3 data frames. Each of the methods are taken from the broom package
list(
  # Get model-level values
  model = glance(model),
  # Get coefficient-level values
  coefficients = tidy(model),
  # Get observation-level values
  observations = augment(model)
)

# Wrap this code into a function, groom_model
groom_model <- function(model) {
  list(
    model = glance(model),
    coefficients = tidy(model),
    observations = augment(model)
  )
}

# Call groom_model on model, assigning to 3 variables
c(mdl, cff, obs) %<-% groom_model(model)

# See these individual variables
mdl; cff; obs

# 2. Returning metadata
pipeable_plot <- function(data, formula) {
  plot(formula, data)
  # Add a "formula" attribute to data. Syntax to assign attributes; attr(object, "attribute_name") <- attribute_value
  attr(data, "formula") <- formula
  invisible(data)
}

# From previous exercise
plt_dist_vs_speed <- cars %>%
  pipeable_plot(dist ~ speed)

# Examine the structure of the result
plt_dist_vs_speed

# C. Environments
# Environments are used to store other variables. Environments interact similar to family structures, whereby, if the parent does not have the answer
# then the grandparent will be asked and so forth.
# 1. Creating and exploring environments
# Add capitals, national_parks, & population to a named list
rsa_lst <- list(
  capitals = capitals,
  national_parks = national_parks,
  population = population
)

# List the structure of each element of rsa_lst
ls.str(rsa_lst)

# convert list to environment
rsa_env <- list2env(rsa_lst)

# Find the parent environment of rsa_env
parent <- parent.env(rsa_env)

# Print its name
environmentName(parent)

# 2. Do variables exist
# Compare the contents of the global environment and rsa_env
ls.str(globalenv())
ls.str(rsa_env)

# Does population exist in rsa_env?
exists("population", envir = rsa_env)

# Does population exist in rsa_env, ignoring inheritance?
exists("population", envir = rsa_env, inherit = FALSE)


args = commandArgs(trailingOnly=TRUE)

primeNumberCount = 100;
if (length(args) == 1) {
    primeNumberCount = as.numeric(args[1]);
}

number = 0;
while (primeNumberCount > 0) {
    number = number + 1;

    j = 0;
    for (i in 1:number) {
        if (number %% i == 0) {
            j = j + 1;
        }
    }

    if (j == 2) {
        primeNumberCount = primeNumberCount - 1;
    }
}

paste('The latest prime number: ', number);


allele.imbalance<- function(rna, dna, rna.err, dna.err){

   #Step1
   # estimate sequencing error, dispersion DNA counts and dispersion RNA counts
   # optimization function 1
   mtmp <- function(par, dna.x, dna.n, rna.x, rna.n, ge, rna.err, dna.err){

      # define parameters
      # seq.err  <- par[1]
      disp.dna <- par[1]
      disp.rna <- par[2]

      # likelihood given genotype err (not actually het)
      term1<- 0.5 * dbetabinom(dna.x, dna.n, m= dna.err/3, s= disp.dna) * dbetabinom(rna.x, rna.n, m= rna.err/3, s= disp.rna)
      term2<- 0.5 * dbetabinom(dna.n-dna.x, dna.n, m= dna.err/3, s= disp.dna) * dbetabinom(rna.n-rna.x, rna.n, m= rna.err/3, s= disp.rna)
      err.like <- (ge)*(term1 + term2)

      # likelihood given het sites (actually het)
      het.like = (1-ge)*(dbetabinom(dna.x, dna.n, m= 0.5, s= disp.dna)) *  dbetabinom(rna.x, rna.n, m= 0.5, s= disp.rna)

      # log likelihood
      ll<- -sum(log(err.like + het.like))

      return(ll)
   }

   # optimize
   m0<- optim(par= c(1, 1), mtmp,
              dna.x=dna$ref.matches, dna.n= dna$N,
              rna.x= rna$ref.matches, rna.n = rna$N,
              ge= dna$genotype.error,dna.err= dna.err, rna.err= rna.err,
              method="L-BFGS-B",lower = c(1e-5, 1e-5),
              upper = c(100, 100))

   # get parameter
   disp.dna = m0$par[1]
   disp.rna = m0$par[2]

   # get genes
   genes= as.character(unique(rna$gene))

   # allelic.imbalance  is how far proportion is away from 0.5
   # first site : L( x | allelic.imbalance)=het.like* P( x | 0.5 + allelic.imbalance) + err.like
   # subsequent sites : L( x | allelic.imbalance) = het.like(0.5 * Pr(x | 0.5 - d) + 0.5 * Pr( x | 0.5 + d))) + err.like
   # chi-square test against null hypothesis of allelic.imbalance = 0

   myfunc<- function(i){
      #Step 1 subset by gene
      # rna
      rna= rna[rna$gene %in% genes[i],]
      rna= rna[order(rna$start),]

      # dna
      dna= dna[(dna$rsID %in% rna$rsID) & (dna$gene %in% genes[i]),]
      dna= dna[order(dna$start),]

      # step 2 likelihood estimate
      # likelihood function estimate for ase
      ll<- function(allelic.imbalance,  dna.x, dna.n, rna.x, rna.n, ge, dna.err, rna.err, disp.dna, disp.rna){

         # for 1st site
         # likelihood of allelic imbalance (d1)
         d1= dbetabinom(rna.x[1], rna.n[1], m= 0.5+ allelic.imbalance, s= disp.rna)

         # likelihood given genotype err (not actually het)
         term1<- 0.5 * dbetabinom(dna.x[1], dna.n[1], m= dna.err/3, s= disp.dna) * dbetabinom(rna.x[1], rna.n[1], m= rna.err/3, s= disp.rna)
         term2<- 0.5 * dbetabinom(dna.n[1]-dna.x[1], dna.n[1], m= dna.err/3, s= disp.dna) * dbetabinom(rna.n[1]-rna.x[1], rna.n[1], m= rna.err/3, s= disp.rna)
         err.like <- (ge[1])*(term1 + term2)

         # likelihood given het sites (actually het)
         het.like= (1-ge[1])*(dbetabinom(dna.x[1], dna.n[1], m= 0.5, s= disp.dna))

         # likelihood of 1st sites
         p1= het.like*d1+ err.like

         # for subsequent sites
         len= nrow(rna)

         if(len >1){

            # likelihood of allelic imbalance of n+1, n+2....n+k sites
            d2= 0.5 * dbetabinom(rna.x[2:len], rna.n[2:len], 0.5+ allelic.imbalance, disp.rna)
            d3= 0.5 * dbetabinom(rna.x[2:len], rna.n[2:len], 0.5- allelic.imbalance, disp.rna)

            # likelihood given genotype err (not actually het)
            term1<- 0.5 * dbetabinom(dna.x[2:len], dna.n[2:len], m= dna.err/3, s= disp.dna) *
               dbetabinom(rna.x[2:len], rna.n[2:len], m= rna.err/3, s= disp.rna)

            term2<- 0.5 * dbetabinom(dna.n[2:len]-dna.x[2:len], dna.n[2:len], m= dna.err, s= disp.dna) *
               dbetabinom(rna.n[2:len]-rna.x[2:len], rna.n[2:len], m= rna.err, s= disp.rna)

            err.like <- (ge[2:len])*(term1 + term2)

            # likelihood given het sites (actually het)
            het.like= (1-ge[2:len])*(dbetabinom(dna.x[2:len], dna.n[2:len], m= 0.5, s= disp.dna))

            p2= het.like*(d2 + d3) + err.like

            return(-sum(log(c(p1,p2))))}else{
               return(-sum(log(p1)))
            }}

      # optimize allelic.imbalance
      m1= optimize(ll, c(-0.5, 0.5),
                   rna.x= rna$ref.matches, rna.n= rna$N,
                   dna.x= dna$ref.matches, dna.n= dna$N, ge= dna$genotype.error,
                   dna.err= dna.err, rna.err= rna.err, disp.dna= disp.dna, disp.rna= disp.rna)

      # estimates of allelic.imbalance
      alt.ll <- m1$objective
      estimate <- m1$minimum

      # NULL hypothesis
      null.ll= ll(allelic.imbalance = 0,
                  rna.x= rna$ref.matches, rna.n= rna$N,
                  dna.x= dna$ref.matches, dna.n= dna$N,
                  ge= dna$genotype.error, dna.err= dna.err, rna.err= rna.err,
                  disp.dna= disp.dna, disp.rna= disp.rna)

      # likelihood ratio test
      lrt.stat <- 2 * (null.ll - alt.ll)
      pval <- pchisq(lrt.stat, df=1, lower.tail=F)
      result= data.frame(gene= genes[i], pval =pval, d= estimate)
      return(result)
   }
   rlist= llply(1:length(genes), myfunc)
   res= do.call(rbind,rlist)
   res$fdr= p.adjust(res$pval, "fdr")
   return(res)
}


#' Plot annual SPR targets
#'
#' Computes and plots SPR targets using selectivity, M, WAA, and maturity by year.
#' @param asap name of the variable that read in the asap.rdat file
#' @param pspr user defined value(s) of spr, e.g. 0.4 or c(0.4, 0.43, 0.46); if empty (default), calculated at seq(0.2, 0.5, by=0.1)
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotAnnualSPRtargets <- function(asap, pspr=c(), save.plots,od,plotf){

  if(length(pspr)>0) spr.targ.values <- pspr
  if(length(pspr)==0) spr.targ.values <- seq(0.2, 0.5, by=0.1)
  n.spr <- length(spr.targ.values)
  nages<- asap$parms$nages
  nyears <- asap$parms$nyears
  years <- seq(asap$parms$styr,asap$parms$endyr)
  fec.age <- asap$WAA.mats$WAA.ssb
  mat.age <- asap$maturity
  wgt.age <- asap$WAA.mats$WAA.catch.all
  M.age <- asap$M.age
  sel.age <- asap$F.age/apply(asap$F.age,1,max)

  spawn.time <- asap$options$frac.yr.spawn

  spr0.vals<- asap$SR.annual.parms$s.per.r.vec
  F.start <-0.11  # starting guess for optimization routine to find F_SPR%

  f.spr.vals <- matrix(NA, nyears, n.spr)
  ypr.spr.vals <- matrix(NA, nyears, n.spr)
  conv.vals <- matrix(NA, nyears, n.spr)

  for (i in 1:n.spr) {
    for (j in 1:nyears) {
      t.spr <- spr.targ.values[i]

      spr.f <- function(F.start) {
        abs(s.per.recr(nages=nages, fec.age=fec.age[j,], mat.age=mat.age[j,], M.age= M.age[j,], F.mult=F.start, sel.age=sel.age[j,], spawn.time=spawn.time)/spr0.vals[j] - t.spr )
      }
      yyy <- nlminb(start=F.start, objective=spr.f, lower=0, upper=3)
      f.spr.vals[j,i] <- yyy$par
      ypr.spr.vals[j,i] <- ypr(nages, wgt.age=wgt.age[j,], M.age=M.age[j,],  F.mult=f.spr.vals[j,i], sel.age=sel.age[j,] )
      conv.vals[j,i] <- ifelse(yyy$convergence==0, TRUE, FALSE)
    }  # end j-loop over nyears
  }  #end i-loop over SPR values

 # if(length(pspr)==0) {
  par(mfrow=c(1,1), mar=c(4,4,2,4) )
  nrepltyseq <- ceiling(n.spr/4) # allows more than 4 line types by repeats
  lty.seq=rep(c(1,2,4,6), nrepltyseq)
  plot(years, f.spr.vals[,1], type='n', xlab="Year", ylab="Full F (%SPR)", lwd=2,
       col="blue3", ylim=c(0,1.2*max(f.spr.vals)) )
  for (i in 1:n.spr) {
    lines(years, f.spr.vals[,i], lwd=2, col=i, lty=lty.seq[i] )
  }
  legend('top', legend=c(paste0("F", round(100*spr.targ.values,0), "%")), col=seq(1,n.spr), lty=lty.seq, horiz=T,lwd=2, cex=0.9)

  title (main="Annual F(%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.FSPR.", plotf), type=plotf)

  plot(years, ypr.spr.vals[,1], type='n', xlab="Year", ylab="YPR (%SPR)", lwd=2,
       col="blue3", ylim=c(0,1.2*max(ypr.spr.vals)) )
  for (i in 1:n.spr) {
    lines(years, ypr.spr.vals[,i], lwd=2, col=i, lty=lty.seq[i] )
  }
  legend('top', legend=c(paste0("YPR", round(100*spr.targ.values,0), "%")), col=seq(1,n.spr), lty=lty.seq, horiz=T,lwd=2, cex=0.9)

  title (main="Annual YPR(%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.YPR.", plotf), type=plotf)

  f.hist.list <- list()
  for (i in 1:n.spr){
    f.hist.list[[i]] <- hist(f.spr.vals[,i], plot=FALSE)
  }

  mynrows <- ceiling(n.spr/2)
  par(mfrow=c(mynrows,2), mar=c(4,4,2,2), oma=c(0,0,2,0) )

  for (i in 1:n.spr){
    myxlab <- paste0("Full F", round(spr.targ.values[i]*100, 0), "%")
    plot(f.hist.list[[i]]$mids, f.hist.list[[i]]$counts, xlab=myxlab, ylab="Frequency", type='h', lwd=2, ylim=c(0, max(f.hist.list[[i]]$counts)), col='blue4')
    lines(f.hist.list[[i]]$mids, f.hist.list[[i]]$counts, lwd=2, col='blue4')
  }

  title (main="Annual F (%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.F_SPR.4panel.hist.", plotf), type=plotf)

  ypr.hist.list <- list()
  for (i in 1:n.spr){
    ypr.hist.list[[i]] <- hist(ypr.spr.vals[,i], plot = FALSE)
  }

  par(mfrow=c(mynrows,2), mar=c(4,4,2,2), oma=c(0,0,2,0) )

  for (i in 1:n.spr){
    myxlab <- paste0("YPR(", round(spr.targ.values[i]*100, 0), "%)")
    plot(ypr.hist.list[[i]]$mids, ypr.hist.list[[i]]$counts, xlab=myxlab, ylab="Frequency", type='h', lwd=2, ylim=c(0, max(ypr.hist.list[[i]]$counts)), col='blue4'  )
    lines(ypr.hist.list[[i]]$mids, ypr.hist.list[[i]]$counts, lwd=2, col='blue4')
  }

  title (main="Annual YPR (%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.YPR_SPR.4panel.hist.", plotf), type=plotf)

  par(mfrow=c(1,1), mar=c(5.1,4.1,4.1,2.1), oma=c(0,0,0,0))

  spr.list <- list(f.spr.vals=f.spr.vals, ypr.spr.vals=ypr.spr.vals, conv.vals=conv.vals)
  return(spr.list)
} # end function


# CS422 Data Mining
# Vijay K. Gurbani, Ph.D.
# Illinois Institute of Technology
#
# Demonstration of k-means clustering.  Algorithm below is for demonstration
# purpose only; lot's of hard-coded stuff. Don't assume it will work for all
# sorts of data and clustering strategies!!

rm(list=ls())

# Main entry point.  To run, give the coordinates of the cluster centroids.
#
# > kmeans.demo.main(data.frame(x=c(9,10,11), y=c(2,3,4)))
# or
# > kmeans.demo.main(data.frame(x=c(1,6,10), y=c(10,6,8)))
#
# The following cluster centroid will result in only 2 clusters: red and black.
# (Some warnings are thrown as the code does not handle corner cases
# approriately.)
#
# > kmeans.demo.main(data.frame(x=c(1,2,3), y=c(10,10,10)))
#
# Other centroids: data.frame(x=c(1,12,6), y=c(1,10,6))

kmeans.demo.main <- function(centroids) {

  x <- c(4,7,4,6,3,2,5,10,12,11,9,12)
  y <- c(10,10,8,8,4,2,2,5,6,4,3,3)
  df <- data.frame(x,y)

  cluster.centroids <- centroids

  old.cluster.centroids <- cluster.centroids
  for (i in 1:100) {
    kmeans.demo.plot(df, cluster.centroids)
    readline(prompt="Press <enter> to continue")
    cluster.centroids <- kmeans.demo.training(df, cluster.centroids)
    readline(prompt="Press <enter> to continue")
    if (identical(cluster.centroids, old.cluster.centroids)) { break }
    old.cluster.centroids <- cluster.centroids
  }
  cat(paste("Iterations to converge: ", i, "\n"))
}

# Plot the data points and the centroids
kmeans.demo.plot <- function(df, cluster.centroids) {
  plot(df, xlim=c(0,13), ylim=c(0,11), cex=3)
  points(cluster.centroids[1,1], cluster.centroids[1,2], col="green", pch=8, cex=3)
  points(cluster.centroids[2,1], cluster.centroids[2,2], col="red", pch=8, cex=3)
  points(cluster.centroids[3,1], cluster.centroids[3,2], col="black", pch=8, cex=3)
}

# "Train" the dataset by seeing which points belong to which cluster
kmeans.demo.training <- function(df, cluster.centroids)  {
  green.df <- data.frame();
  red.df <- data.frame();
  black.df <- data.frame();
    for (i in 1:dim(df)[1])  {
     paint <- kmeans.demo.which.cluster(df[i,1], df[i,2], cluster.centroids)
     points(df[i,1], df[i,2], col=paint, pch=20, cex=4)
     if (paint == "green") { green.df <- rbind(green.df, df[i,])}
     if (paint == "red")   { red.df   <- rbind(red.df, df[i,])}
     if (paint == "black") { black.df <- rbind(black.df, df[i,])}
  }
  cluster.centroids <- kmeans.demo.update.centroids(green.df,
                                                    red.df,
                                                    black.df,
                                                    cluster.centroids)
  cluster.centroids
}

# Determine which point to paint with which color
kmeans.demo.which.cluster <- function(x, y, cluster.centroids)  {
  df <- data.frame(c(x, cluster.centroids[1,1]), c(y, cluster.centroids[1,2]))
  d1 <- dist(df) # green
  df <- data.frame(c(x, cluster.centroids[2,1]), c(y, cluster.centroids[2,2]))
  d2 <- dist(df) # red
  df <- data.frame(c(x, cluster.centroids[3,1]), c(y, cluster.centroids[3,2]))
  d3 <- dist(df) # black
  indx <- which.min(c(d1,d2,d3))
  if (indx == 1) {
    paint = "green"
  } else if (indx == 2){
    paint = "red"
  } else {
    paint = "black"
  }
  paint
}

# Update the centroids to their new location.
kmeans.demo.update.centroids <- function(green.df,
                                         red.df,
                                         black.df,
                                         cluster.centroids) {

  cluster.centroids <- data.frame(x = c(mean(green.df$x),
                                        mean(red.df$x),
                                        mean(black.df$x)),
                                  y = c(mean(green.df$y),
                                        mean(red.df$y),
                                        mean(black.df$y)))
  cluster.centroids
}


library(effects)
library(gplots)

fn.st = file.path(PROJECT_DIR, "generated_data/brown-module-leading-genes-low-mid-high-eigengene/st.rds")
st = readRDS(fn.st) %>%
  dplyr::rename(subject = Sample, CD38 = CD38_score) %>%
  mutate(Response = factor(Response), Study = factor(Study))

# CHI IFN26
fn.chi = file.path(PROJECT_DIR, "generated_data", "IFN26", "CHI_IFN26_ge_sig_score.txt")
df.chi = fread(fn.chi) %>%
  dplyr::filter(day == "day 0") %>%
  dplyr::select(subject, IFN26 = score)

# HIPC IFN26
fn.hipc = file.path(PROJECT_DIR, "generated_data", "IFN26", "HIPC_IFN26_ge_sig_score.txt")
df.hipc = fread(fn.hipc) %>%
  dplyr::select(subject, IFN26 = score)

# CHI TGSig
fn.cd38 = file.path(PROJECT_DIR, "generated_data/CHI/CHI_cd38_ge_sig_score_day0.txt")
df.cd38 = fread(fn.cd38)

df = rbind(df.chi, df.hipc)

DF = st %>%
  inner_join(df, by="subject")

dn.fig = file.path(PROJECT_DIR, "figure_generation/IFN26")

### logstic regression - 1 predictor

fit1 = glm(Response ~ IFN26 + Study, family="binomial", data=DF)
summary(fit1)

fn.fig = file.path(dn.fig, "4flu-logistic-regression-1pred_effects-IFN26-bars")
p = summary(fit1)$coef[2,4]
main=sprintf("p = %0.3g", p)
ylab = "Probability of high responder"
eff = Effect("IFN26", fit1, xlevels=list(IFN26=seq(-1,1,0.5)))

pdf(paste0(fn.fig, ".pdf"))
with(summary(eff), {
  barplot(effect, main=main,  width=1, space=0, ylim=c(0,1), las=1,
          xlab="IFN-I-DCact score", ylab=ylab)
  plotCI(seq(0.5,4.5,1), effect, uiw=upper-effect, liw=effect-lower, add=T, gap=0, type="p", pch=NA)
})
dev.off()

### logstic regression - 2 predictors

fit1 = glm(Response ~ CD38 + IFN26 + Study, family="binomial", data=DF)
summary(fit1)

fn.fig = file.path(dn.fig, "4flu-logistic-regression-2pred_effects-CD38-bars")
p = summary(fit1)$coef[2,4]
main=sprintf("p = %0.3g", p)
ylab = "Probability of high responder"
eff = Effect("CD38", fit1, xlevels=list(CD38=seq(-1,1,0.5)))
pdf(paste0(fn.fig, ".pdf"))
with(summary(eff), {
  barplot(effect, main=main,  width=1, space=0, ylim=c(0,1), las=1,
          xlab="TGSig score", ylab=ylab)
  plotCI(seq(0.5,4.5,1), effect, uiw=upper-effect, liw=effect-lower, add=T, gap=0, type="p", pch=NA)
})
dev.off()

fn.fig = file.path(dn.fig, "4flu-logistic-regression-2pred_effects-IFN26-bars")
p = summary(fit1)$coef[3,4]
main=sprintf("p = %0.3g", p)
ylab = "Probability of high responder"
eff = Effect("IFN26", fit1, xlevels=list(IFN26=seq(-1,1,0.5)))
pdf(paste0(fn.fig, ".pdf"))
with(summary(eff), {
  barplot(effect, main=main,  width=1, space=0, ylim=c(0,1), las=1,
          xlab="IFN-I-DCact score", ylab=ylab)
  plotCI(seq(0.5,4.5,1), effect, uiw=upper-effect, liw=effect-lower, add=T, gap=0, type="p", pch=NA)
})
dev.off()


print( sum( 1/seq(1000)^2 ) )


### Generate data base simulations
## Use: Generate data for four functional forms
## Author: Mark Verhagen

library(tidyverse)
library(randomForest)
library(xgboost)

set.seed(1704)

## Set n and X variable
n <- 100
X <- runif(n, -4, 4)

## Generate y outcome based on four functional forms
y0 <- -1 + .9 * X
y1 <- -2 * ifelse(X < -3, 1, 0) + 2.55 * ifelse(X > -2, 1, 0) -
    2 * ifelse(X > 0, 1, 0) + 4 * ifelse(X > 2, 1, 0) - 1 * ifelse(X > 3, 1, 0)
y2 <- 6 + 0.4 * X - 0.36 * X^2 + 0.005 * X^3
y3 <- 2.83 * sin(pi / 2 * X)

## Generate white noise such that overall variance is fixed
var0 <- 5 - var(y0)
var1 <- 5 - var(y1)
var2 <- 5 - var(y2)
var3 <- 5 - var(y3)

epsilon0 <- rnorm(n, 0, sqrt(var0))
epsilon1 <- rnorm(n, 0, sqrt(var1))
epsilon2 <- rnorm(n, 0, sqrt(var2))
epsilon3 <- rnorm(n, 0, sqrt(var3))

## Generate outcome plus noise and store in dataframe
df <- data.frame(
    X = X,
    y_0 = y0 + epsilon0,
    y_1 = y1 + epsilon1,
    y_2 = y2 + epsilon2,
    y_3 = y3 + epsilon3
)

return_oos_r2 <- function(actual, predict) {
    return(1 - sum((actual - predict)^2) / sum((actual - mean(actual))^2))
}

## Generate ids for every row
df_analysis <- df %>%
    mutate(id = 1:n())

train_set <- df_analysis

obs_vars <- c("y_0", "y_1", "y_2", "y_3")

## Obtian outcome value per functional form for trainset
train_ys <- lapply(obs_vars, FUN = function(x) {
    train_set[, x]
})

## Obtain train and test version of feature set
X_train <- train_set %>%
    select(X)

## Estimate true linear effects
true_vars <- list(y0, y1, y2, y3)
lms <- lapply(true_vars, FUN = function(x) {
    lm(y ~ 1 + X, data = df_analysis %>% mutate(y = x))
})

## Estimate random forest models on train set
rfs <- lapply(train_ys, FUN = function(x) {
    randomForest(x = X_train, y = x)
})

## Estimate gradient boosting models
gbs <- lapply(train_ys, FUN = function(x) {
    xgboost(data = as.matrix(X_train), label = x, nrounds = 200)
})

## Plotting
pred_df <- data.frame(X = seq(-4, 4, 8 / 100))

## True association
pred_df$lm_0 <- predict(lms[[1]], pred_df)
pred_df$lm_1 <- predict(lms[[2]], pred_df)
pred_df$lm_2 <- predict(lms[[3]], pred_df)
pred_df$lm_3 <- predict(lms[[4]], pred_df)

## Implied association
pred_df$rf_0 <- predict(gbs[[1]], as.matrix(pred_df$X))
pred_df$rf_1 <- predict(rfs[[2]], as.matrix(pred_df$X))
pred_df$rf_2 <- predict(rfs[[3]], as.matrix(pred_df$X))
pred_df$rf_3 <- predict(rfs[[4]], as.matrix(pred_df$X))

pred_df$gb_0 <- predict(gbs[[1]], as.matrix(pred_df$X))
pred_df$gb_1 <- predict(gbs[[2]], as.matrix(pred_df$X))
pred_df$gb_2 <- predict(gbs[[3]], as.matrix(pred_df$X))
pred_df$gb_3 <- predict(gbs[[4]], as.matrix(pred_df$X))

melt_pred_df <- reshape2::melt(pred_df, id.vars = c("X")) %>%
    mutate(model = ifelse(grepl("rf", variable), "RF",
        ifelse(grepl("gb", variable), "GB",
            ifelse(grepl("lm", variable), "LM", NA)
        )
    ), data = gsub("rf_|gb_|lm_", "", variable))

melt_observed <- df %>%
    reshape2::melt(id.vars = ("X")) %>%
    mutate(model = "Simulated", data = gsub("y_", "", variable))

df_true <- data.frame(
    X = X, y_0 = y0, y_1 = y1,
    y_2 = y2, y_3 = y3
)

melt_true <- df_true %>%
    reshape2::melt(id.vars = ("X")) %>%
    mutate(model = "True", data = gsub("y_", "", variable))

total_melt <- rbind(melt_pred_df, melt_observed, melt_true) %>%
    mutate(data = ifelse(data == "0", "Linear",
        ifelse(data == "1", "Step",
            ifelse(data == "2", "Quadratic",
                ifelse(data == "3", "Sine", NA)
            )
        )
    ))

ggplot(total_melt, aes(y = value, x = X)) +
    geom_point(data = total_melt %>% filter(!(model %in% c("True", "LM", "GB", "RF"))), alpha = 0.3, aes(color = model)) +
    geom_line(data = total_melt %>% filter(model == "True"), aes(linetype = model)) +
    geom_line(data = total_melt %>% filter(model == "LM"), aes(linetype = model)) +
    facet_wrap(~data) +
    xlab("X") +
    ylab("Y") +
    scale_color_manual(
        name = "", values = c(ggsci::pal_aaas("default")(3)[3:1], ggsci::pal_aaas("default")(10)[10]),
        labels = c("Simulated data")
    ) +
    scale_linetype_manual(name = "", values = c("dashed", "solid"), labels = c("Linear Model", "True effect")) +
    cowplot::theme_cowplot() +
    theme(
        # panel.grid.minor.y = element_line(size = 0.25, linetype = "dotted"),
        # panel.grid.major.y = element_line(size = 0.25, linetype = "dotted"),
        strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
        strip.background = element_rect(fill = NA, color = "black", size = 1.5),
        legend.position = "top",
        panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
        text = element_text(size = 20)
    ) +
    guides(color = guide_legend(override.aes = list(fill = NA)))

ggsave("../tex/figs/fig1_base.pdf", last_plot(), width = 10, height = 8)

ggplot(total_melt, aes(y = value, x = X)) +
    geom_point(data = total_melt %>% filter(!(model %in% c("True", "LM"))), alpha = 0.3, aes(color = model)) +
    geom_line(data = total_melt %>% filter(model == "True"), aes(linetype = model)) +
    facet_wrap(~data) +
    xlab("X") +
    ylab("Y") +
    scale_color_manual(
        name = "", values = c(ggsci::pal_aaas("default")(3)[1:3], ggsci::pal_aaas("default")(10)[10]),
        labels = c("Gradient Boosting", "Random Forest", "Simulated data")
    ) +
    scale_linetype_manual(name = "", values = c("solid"), labels = c("True effect")) +
    cowplot::theme_cowplot() +
    theme(
        # panel.grid.minor.y = element_line(size = 0.25, linetype = "dotted"),
        # panel.grid.major.y = element_line(size = 0.25, linetype = "dotted"),
        strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
        strip.background = element_rect(fill = NA, color = "black", size = 1.5),
        legend.position = "top",
        panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
        text = element_text(size = 20)
    ) +
    guides(color = guide_legend(override.aes = list(fill = NA)))

ggsave("../tex/figs/fig1_base2.pdf", last_plot(), width = 10, height = 8)


library(dplyr)
library(vcd)
library(tidyr)
samplesize <- 300000
sex <- factor(floor(runif(n = samplesize, min = 0, max = 3)), labels = c("male", "female", "other"))
agegroup <- factor(floor(runif(n = samplesize, min = 0, max = 5)), labels = c("10s", "20s", "30s", "40s", "50s"))
d <- data.frame(sex, agegroup)

# 偏りのないデータ
ad_click1 <- d %>% mutate(
  click = factor(case_when(
    TRUE ~ rbinom(n(), 1, 0.003)
  )
  , labels = c('no', 'yes')
  )
)
# 偏りのあるデータ(交互作用なし)
ad_click2 <- d %>% mutate(
  click = factor(case_when(
    sex == 'female' ~ rbinom(n(), 1, 0.005)
    , TRUE ~ rbinom(n(), 1, 0.003)
  )
  , labels = c('no', 'yes')
  )
)
# 偏りのあるデータ(交互作用あり)
ad_click3 <- d %>% mutate(
  click = factor(case_when(
    sex == 'female' & agegroup == '20s' ~ rbinom(n(), 1, 0.005)
    , TRUE ~ rbinom(n(), 1, 0.003)
  )
  , labels = c('no', 'yes')
  )
)
# 偏りのあるデータ(単純作用+交互作用)
ad_click4 <- d %>% mutate(
  click = factor(case_when(
    sex == 'female' & agegroup == '20s' ~ rbinom(n(), 1, 0.005)
    , agegroup == '30s' ~ rbinom(n(), 1, 0.005)
    , TRUE ~ rbinom(n(), 1, 0.003)
  )
  , labels = c('no', 'yes')
  )
)

chisq_p.values <- function (d) {
  x <- d %>% group_by(sex, agegroup, click)　%>% summarise(count=n()) %>% spread(click, count)
  colnames(x) <- c('sex', 'agegroup', 'nonclick', 'click')
  x <- x %>% mutate(ctr = (click/(nonclick + click)))

  p.values <- c()
  p_sex <- c()
  p_agegroup <- c()
  p_nonclick <- c()
  p_click <- c()
  ctr <- c()
  for (i in 1:nrow(x)) {
    y <- rbind(x[i,3:4], x[-i,3:4] %>% summarize(nonclick=sum(nonclick), click=sum(click)))
    p_sex <- append(p_sex, sapply(x[i, 1], as.character))
    p_agegroup <- append(p_agegroup, sapply(x[i, 2], as.character))
    ctr <- append(ctr, sapply(x[i, 5], as.double))
    p.values <- append(p.values, chisq.test(y)$p.value)
    p_nonclick <- append(p_nonclick, x[i, 3])
    p_click <- append(p_click, x[i, 4])
  }
  x <- d %>% group_by(sex, click) %>% summarise(count=n()) %>% spread(click, count)
  colnames(x) <- c('sex', 'nonclick', 'click')
  x <- x %>% mutate(ctr = (click/(nonclick + click)))
  for (i in 1:nrow(x)) {
    y <- rbind(x[i,2:3], x[-i,2:3] %>% summarize(nonclick=sum(nonclick), click=sum(click)))
    p_sex <- append(p_sex, sapply(x[i, 1], as.character))
    p_agegroup <- append(p_agegroup, '*')
    p.values <- append(p.values, chisq.test(y)$p.value)
    ctr <- append(ctr, sapply(x[i, 4], as.double))
    p_nonclick <- append(p_nonclick, x[i, 2])
    p_click <- append(p_click, x[i, 3])
  }

  x <- d %>% group_by(agegroup, click) %>% summarise(count=n()) %>% spread(click, count)
  colnames(x) <- c('sex', 'nonclick', 'click')
  x <- x %>% mutate(ctr = (click/(nonclick + click)))
  for (i in 1:nrow(x)) {
    y <- rbind(x[i,2:3], x[-i,2:3] %>% summarize(nonclick=sum(nonclick), click=sum(click)))
    p_sex <- append(p_sex, "*")
    p_agegroup <- append(p_agegroup, sapply(x[i, 1], as.character))
    p.values <- append(p.values, chisq.test(y)$p.value)
    ctr <- append(ctr, sapply(x[i, 4], as.double))
    p_nonclick <- append(p_nonclick, x[i, 2])
    p_click <- append(p_click, x[i, 3])
  }

  return(data.frame(sex=p_sex, agegroup=p_agegroup, p.values, click=p_click, ctr) %>% mutate(
    mark=case_when(p.values < 0.01 ~ '**'
                   , p.values < 0.05 ~ '*'
                   , p.values < 0.01 ~ '+'
                   , TRUE ~ '')
  ))
}

chisq_p.values(ad_click1)
chisq_p.values(ad_click2)
chisq_p.values(ad_click3)
chisq_p.values(ad_click4)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(xts)
library(Quandl)
library(quantmod)

## Get risk-free rates
rf.tickers <- c("FRED/DGS3MO", "BOC/V39065", "BUNDESBANK/BBK01_WT3210",
                "SNB/RENDOBLID", "RBA/F17_0", "MOFJ/INTEREST_RATE_JAPAN")
rf.columns <- c(1,1,1,1,2,1)
rf.ids <- c("USD3M", "CAD3M","EUR6M","CHF1Y","AUD3M","JPY1Y","HKD3M")
## loop through tickers and columns
rf <- Quandl(rf.tickers[1], type="xts")[,rf.columns[1]]/100
for (i in 2:length(rf.tickers)) {
    rf.tmp <- Quandl(rf.tickers[i], type="xts")[,rf.columns[i]]/100
    rf <- cbind(rf, rf.tmp)
}

## Getting HKMA data is not straightforward, so...
## ...these are from the Hong Kong Monetary Authority
hkma.exfund.3M.rates <-
    c(0.09,0.10,0.10,0.11,0.26,0.62,0.27,0.18,0.24,0.25,0.30,0.28, # 2010
      0.16,0.19,0.20,0.11,0.13,0.06,0.07,0.10,0.11,0.10,0.17,0.22, # 2011
      0.18,0.11,0.10,0.12,0.10,0.08,0.15,0.17,0.23,0.09,0.07,0.05, # 2012
      0.11,0.08,0.06,0.08,0.09,0.15,0.16,0.15,0.17,0.13,0.12,0.11, # 2013
      0.14,0.14,0.14,0.10,0.07,0.09,0.07,0.04,0.09,0.03,0.03,0.04, # 2014
      0.03,0.01,0.02,0.01,0.01,0.00,0.01,-0.01,-0.01,0.00,-0.01,0.04, # 2015
      0.24,0.07,0.07,0.06,0.20,0.17,0.28,0.30,0.31,0.30,0.28,0.67, # 2016
      0.54,0.41,0.27,0.40,0.29,0.31,0.35,0.28,0.45,0.85,0.75,1.02, # 2017
      0.66,0.56) # 2018
rf.subset <- rf["201001/201802"]
hkma.3M <- xts(hkma.exfund.3M.rates,
               order.by = index(rf.subset[xts:::startof(rf.subset, "months")]))
rf <- cbind(rf, hkma.3M)
rf <- na.locf(rf)
colnames(rf) <- rf.ids

# Get indices and stock prices
adj.close <- 6  # 6th field is adjusted close
equity.tickers <- c("^GSPC","^GSPTSE","^STOXX50E","^SSMI","^AORD","^HSI","^N225",
                    "CTC-A.TO","F","HSBC","PFE","SVNDY","TM","EDF.PA","NOVN.VX",
                    "SIE.DE","VOW.DE","BRG.AX","MQG.AX","J36.SI","0019.HK")
equity.ids <- c("SPX","TSXCOMP","ESX50","SMI","AORD","HS","N225",
                "CATIRE","FORD","HSBC","PFIZER","SEVENANDI","TOY","EDF","NOVARTIS",
                "SIEMENS","VW","BREVILLE","MACQUARIE","JARDINES","SWIRE")
prices <- getSymbols(equity.tickers[1], source="yahoo", auto.assign=FALSE,
                         return.class="xts")[,adj.close]
for (i in 2:length(equity.tickers)) {
  prices.tmp <- getSymbols(equity.tickers[i], source="yahoo",
                         auto.assign=FALSE, return.class="xts")[,adj.close]
  prices <- cbind(prices, prices.tmp)
}
## We often get errors here since international stocks are not always
## traded on our home days, so there are some NAs.  No worries; fill
## forward and returns will be zero on non-trading days.  (Might be a
## minor bias on volatility estimates; we will probably survive.
prices <- na.locf(prices)
colnames(prices) <- equity.ids
returns <- diff(log(prices))

## Now we join all of the datasets together and trim to recent
alldata <- cbind(rf, returns)["2010/"]

## create excess returns
equity.names.xs <- paste(equity.names, ".xs", sep="")
## now in a for loop subtract off a daily risk-free rate, FOR EXAMPLE:
alldata$SPX.xs <- alldata$SPX - alldata$T3M/250
## Only oddity: use HKD rf for Jardines.

# If your ticker were DAL and you wanted to model returns
# (not excess returns) using ESTOX and SMI, you would do like so:
simple.wrong.model <- lm(DAL ~ ESTOX + SMI, data=alldata)
summary(simple.wrong.model)
# NOTE that this is not the model you are supposed to do


#!/bin/bash
exec R --vanilla -q --slave -e "source(file=pipe(\"tail -n +4 $0\"))" --args $@
#debug: exec R --vanilla --verbose -e "source(file=pipe(\"tail -n +6 $0\"))" --args $@
#
#gen.r : an R script to generate a large data set with known structure

N = 50

au = 5
as = 4
ad=rnorm(N, mean=au, sd=as)

bu = 6
bs = 3
bd=rnorm(N, mean=bu, sd=bs)

cu = 10
cs = 30
cd = rnorm(N, mean=cu, sd=cs)

du = 0
ds = 100
dd = rnorm(N, mean=du, sd=ds)

eu = ad + bd
es = 45
ed = eu + rnorm(N, mean=0, sd=es)

g1 = bd + rgamma(N, shape=100, rate=1)

g2 = ed + 50*rgamma(N, shape=1, rate=1) + rnorm(N, mean=0, sd=2000)

g3 = (g1 - g2) + rnorm(N, mean=0, sd=2)
w=is.infinite(g3)
g3[w]=0

df=data.frame(ad,bd,cd,dd,ed,g1,g2,g3)

p0=proc.time()
cat(file="bigger.dat", c("n", colnames(df)),"\n")
write.table(df, file="bigger.dat", quote=F, col.names=F, row.names=T, append=T)
elap = proc.time() - p0
print(paste("time to write out data: ", elap["elapsed"], " sec"))

p1=proc.time()
sm=summary(lm(g3 ~ ., data=df))
elap = proc.time() - p1
print(paste("time to compute regression: ", elap["elapsed"], " sec"))

sink(file="bigger.fit")
sm
sink()

sm


# If you use this code or parts of it, please cite the following paper
# Bruhin A., E. Fehr, D. Schunk (2018): "The Many Faces of Human Sociality: Uncovering the Distribution and Stability of Social Preferences",
# Journal of the European Economic Association, forthcoming.
# ===========================================================================================================================================

library(compiler)

# Log Likelihood
fdummy.ll <- function(v,y,self_x, other_x, self_y, other_y,indicators_x, indicators_y) {
	beta  <- v[1:(length(v)-1)]
	gamma <- exp(v[length(v)])

	lli    <- indicators_x%*%beta
	rli    <- indicators_y%*%beta
	uleft  <- gamma*((1-lli)*self_x+lli*other_x)
	uright <- gamma*((1-rli)*self_y+rli*other_y)

	probs  <- (exp(uleft)/(exp(uleft)+exp(uright)))^y * (exp(uright)/(exp(uleft)+exp(uright)))^(1-y)

	sum(log(probs))
}
f.ll <- cmpfun(fdummy.ll)

# Log Likelihood of a model without indicators
fdummy.ll.nopar <- function(v,y,self_x,self_y) {
	gamma <- exp(v)

	uleft  <- gamma*self_x
	uright <- gamma*self_y

	probs  <- (exp(uleft)/(exp(uleft)+exp(uright)))^y * (exp(uright)/(exp(uleft)+exp(uright)))^(1-y)

	sum(log(probs))
}
f.ll.nopar <- cmpfun(fdummy.ll.nopar)

# Gradient of Log Likelihood
fdummy.ll.gr <- function(v, y, self_x, other_x, self_y, other_y, indicators_x, indicators_y) {
	beta  <- v[1:(length(v)-1)]
	gamma <- exp(v[length(v)])

	lli <- indicators_x%*%beta
	rli <- indicators_y%*%beta
	utl <- gamma*((1-lli)*self_x+lli*other_x)
	utr <- gamma*((1-rli)*self_y+rli*other_y)
	probs  <- (exp(utl)/(exp(utl)+exp(utr)))^y * (exp(utr)/(exp(utl)+exp(utr)))^(1-y)
	probsm <- matrix(probs, nrow(indicators_x), ncol(indicators_x))

	u   <- matrix(exp(utl)            , nrow(indicators_x), ncol(indicators_x))
	w   <- matrix(exp(utl) + exp(utr) , nrow(indicators_x), ncol(indicators_x))
	up  <- gamma * indicators_x * matrix(other_x-self_x, nrow(indicators_x), ncol(indicators_x)) * u
	wp  <- up + gamma * indicators_y * matrix((other_y-self_y)*exp(utr), nrow(indicators_x), ncol(indicators_x))

	prebgrad <- (-1)^(1-y)*((up*w - u*wp)/w^2)/probsm
	bgrad    <- colSums(prebgrad)

	up2   <- utl * u[,1]
	wp2   <- up2 + utr * exp(utr)

	ggrad <- sum((-1)^(1-y) * (((up2*w[,1] - u[,1]*wp2)/w[,1]^2)/probs))

	c(bgrad, ggrad)
}
f.ll.gr <- cmpfun(fdummy.ll.gr)

# Gradient of Log Likelihood of a model without indicators
fdummy.ll.gr.nopar <- function(v, y, self_x,self_y) {
	gamma <- exp(v)

	utl <- gamma*self_x
	utr <- gamma*self_y
	probs  <- (exp(utl)/(exp(utl)+exp(utr)))^y * (exp(utr)/(exp(utl)+exp(utr)))^(1-y)

	u   <- exp(utl)
	w   <- exp(utl) + exp(utr)
	up2   <- utl * u
	wp2   <- up2 + utr * exp(utr)

	ggrad <- sum((-1)^(1-y) * (((up2*w - u*wp2)/w^2)/probs))
	ggrad
}
f.ll.gr.nopar <- cmpfun(fdummy.ll.gr.nopar)

# Function to compute cluster robust standard errors
f.clusterse <- function(estobj, dat, label_choice_x, label_self_x, label_other_x, label_self_y, label_other_y, label_indicators_x, label_indicators_y, clustervar) {
	y         <- as.vector(dat[,label_choice_x])
	self_x    <- as.matrix(dat[,label_self_x])
	other_x   <- as.matrix(dat[,label_other_x])
	self_y    <- as.matrix(dat[,label_self_y])
	other_y   <- as.matrix(dat[,label_other_y])
	indicators_x <- as.matrix(dat[,label_indicators_x])
	indicators_y <- as.matrix(dat[,label_indicators_y])
	clusters  <- as.vector(dat[,clustervar])

	ll1 <- f.ll(estobj$retobj$par, y, self_x, other_x, self_y, other_y, indicators_x, indicators_y)
	if (abs(ll1 - estobj$retobj$value)>0.001) stop(paste("Saved loglik", ll1, "and computed loglik", estobj$retobj$value, "differ"))

	sandwich <- f.sandwich(estobj$retobj$par, y, self_x, other_x, self_y, other_y,indicators_x, indicators_y, clusters) # sandwich part; see function below

	k <- length(estobj$retobj$par)

	vcm <- solve(-estobj$retobj$hessian)
	vcm <- sandwich$qc * (vcm %*% sandwich$sandwich %*% vcm)

	se <- sqrt(diag(vcm))
	se[k] <- sqrt( exp(estobj$retobj$par[k])^2 * se[k]^2 )

	pe <- estobj$retobj$par
	pe[k] <- exp(pe[k])
	out <- matrix(c(pe, se, pe/se, 2*(1-pnorm(abs(pe)/se))), k, 4, dimnames=list(c(paste(label_indicators_x,"label_idicators_y"),"choicesens"),c("point_estimates","se_cluster","z-stat_cluster","p-val_cluster")));

	cat("\nNumber of clusters", sandwich$j,"\n")
	print(round(out,3))

	list(out=out, vcm=vcm[1:(k-1), 1:(k-1)])
}

# Sandwitch part for calculating cluster robust standard errors
f.sandwich <- function(v, y, self_x, other_x, self_y, other_y,indicators_x, indicators_y, clusters) {

	#compute individual gradient contributions
	beta  <- v[1:(length(v)-1)]
	gamma <- exp(v[length(v)])

	lli <- indicators_x%*%beta;
	rli <- indicators_y%*%beta;
	utl <- gamma*((1-lli)*self_x+lli*other_x)
	utr <- gamma*((1-rli)*self_y+rli*other_y)
	probs  <- (exp(utl)/(exp(utl)+exp(utr)))^y * (exp(utr)/(exp(utl)+exp(utr)))^(1-y);
	probsm <- matrix(probs, nrow(indicators_x), ncol(indicators_x))

	u   <- matrix(exp(utl)            , nrow(indicators_x), ncol(indicators_x))
	w   <- matrix(exp(utl) + exp(utr) , nrow(indicators_x), ncol(indicators_x))
	up  <- gamma * indicators_x * matrix(other_x-self_x, nrow(indicators_x), ncol(indicators_x)) * u
	wp  <- up + gamma * indicators_y * matrix((other_y-self_y)*exp(utr), nrow(indicators_x), ncol(indicators_x))

	bgradi <- (-1)^(1-y)*((up*w - u*wp)/w^2)/probsm

	up2   <- utl * u[,1]
	wp2   <- up2 + utr * exp(utr)

	ggradi <- (-1)^(1-y) * (((up2*w[,1] - u[,1]*wp2)/w[,1]^2)/probs)

	gradi <- cbind(bgradi, ggradi)

	#Sandwich part of the sandwich VC estimator
	cl <- unique(clusters)
	j  <- length(cl)
	k  <- ncol(gradi)

	sandwich <- matrix(0, k, k)
	for (i in 1:j) {
		sel <- clusters == cl[i]
		gradsel <- colSums(gradi[sel, ])
		sandwich <- sandwich + (gradsel %o% gradsel)
	}

	qc <- (length(y)-1) / (length(y)-k) * j/(j-1) #df adjustment

	list(qc=qc, sandwich=sandwich, j=j)
}

# Estimation Function (to be called directly for aggregate estimations and by f.indivest for individual estimations)
fdummy.estim <- function(dat, label_choice_x, label_indicators_x, label_indicators_y, label_self_x, label_other_x, label_self_y, label_other_y, silent=F, comp.se=T, v0=NULL) {
	y         <- as.vector(dat[,label_choice_x])
	self_x    <- as.matrix(dat[,label_self_x])
	other_x   <- as.matrix(dat[,label_other_x])
	self_y    <- as.matrix(dat[,label_self_y])
	other_y   <- as.matrix(dat[,label_other_y])
	indicators_x <- as.matrix(dat[,label_indicators_x])
	indicators_y <- as.matrix(dat[,label_indicators_y])

	k <- length(label_indicators_x)+1

	if (is.null(v0)) {v0  <- c(rep(0,k-1), log(runif(1,.05,.8)/mean(c(mean(self_x),mean(other_x),mean(self_y),mean(other_y)))))} # Random start values if start values are not provided
	ret <- optim(v0, f.ll, f.ll.gr, method="BFGS", control=list(maxit=100000,trace=as.numeric(silent==F),REPORT=50, fnscale=-1), hessian=comp.se, y=y, self_x=self_x, other_x=other_x, self_y=self_y, other_y=other_y, indicators_x=indicators_x, indicators_y=indicators_y)

	rawpe <- ret$par
	pe    <- rawpe
	pe[k] <- exp(rawpe[k]) # Choice sensitivity > 0

	se <- rep(NA, k)
	overall.pval <- NA
	if(comp.se) {
		rawse <- sqrt(diag( solve(-ret$hessian) ))
		se    <- rawse
		se[k] <- sqrt( exp(rawpe[k])^2 * rawse[k]^2 ) #Delta method

		ret2 <- optim(log(0.5/1000), f.ll.nopar, f.ll.gr.nopar, method="BFGS", control=list(maxit=100000,trace=F,REPORT=50, fnscale=-1), hessian=F, y=y, self_x=self_x, self_y=self_y)
		overall.pval <- 1-pchisq(2*(ret$value-ret2$value),4)
	}

	out <- matrix(c(pe, se, pe/se, 2*(1-pnorm(abs(pe)/se))), k, 4, dimnames=list(c(paste(label_indicators_x,label_indicators_y),"choicesens"),c("point_estimates","se_noCluster","z-stat_noCluster","p-val_noCluster")))

	if (silent==F) {
		print(paste("LogLik:",ret$value), quote=F)
		print(round(out,4))
	}

	list(out=out, retobj=ret, overall.pval=overall.pval)
}
f.estim <- cmpfun(fdummy.estim)

# Function for running individual estimations
f.indivest <- function(dat){

	# Set up grid of start values (individual estimations are more fragile than pooled ones => test a lot of start values for each subject)
	v01   <- c(0,0,0,0)
	v02   <- c(.1,-.1,0,0)
	v03   <- c(.1,-.1,.01,-.01)
	v04   <- c(.1,-.1,-.01,.01)
	v05   <- c(-.1,.1,0,0)
	v06   <- c(-.1,.1,.01,-.01)
	v07   <- c(-.1,.1,-.01,.01)
	v00   <- matrix(c(v01,v02,v03,v04,v05,v06,v07),7,4,byrow=T)
	errv0 <- log(seq(0.0001, .001, length.out=20))
	irps  <- 7*20 #140 estimation per subject with varying start values

	ids <- sort(unique(dat$sid)) #Individual IDs
	j   <- length(ids)           #Number of individuals

	parset <- c("beta", "alpha", "gamma", "delta", "choicesens")
	parmatrix    <- matrix(NA, j,    length(parset)+2, dimnames=list(ids, c(parset, "loglik", "success"))) # Matrix for saving the final estimation results for every subject
	parsubmatrix <- matrix(NA, irps, length(parset)+2, dimnames=list(NULL,c(parset, "loglik", "success"))) # Matrix for saving the estimation results for every start value combination in the grid of start values

	# Run the individual Estimations including all irps subreplications
	for (i in 1:j) {
		idat <- dat[dat$sid == ids[i], ]
		cat("\nEstimating individual:", i,"/",j)

		# Cycle through all 140 start value combinations
		for (s in 1:irps) {
			verr <- errv0[((s-1) %% 20) + 1] #start values for the choice sensitivity
			v    <- v00[((s-1) %/% 20) +1,] #start values of the parameters

			#estimtion
			pe <- f.estim(idat, "choice_x", c("r_x","s_x","q","v"), c("r_y","s_y","q","v"), "self_x", "other_x", "self_y", "other_y", silent=T, comp.se=F, v0=c(v,verr))
			ipar <- pe$out[,1]
			ill  <- pe$retobj$value
			isuc <- as.numeric(pe$retobj$convergence == 0)
			parsubmatrix[s,] <- c(ipar, ill, isuc)
		}

		# Extract start values that led to the best estimation (i.e. the estimation with the highest log likelihood)
		v0 <- as.matrix(parsubmatrix[order(parsubmatrix[,"loglik"], decreasing=T),])[1,1:length(parset)]
		v0[length(v0)] <- log(v0[length(v0)]) # Choice sensitivty (last parameter in v0) is > 0

		# Redo best estimation
		pe <- f.estim(idat, "choice_x", c("r_x","s_x","q","v"), c("r_y","s_y","q","v"), "self_x", "other_x", "self_y", "other_y", silent=T, comp.se=F, v0=v0)

		parmatrix[i, 1:length(parset)] <- pe$out[,1] # save point estimates
		parmatrix[i, length(parset)+1] <- pe$retobj$value # save log likelihood
		parmatrix[i, length(parset)+2] <- as.numeric(pe$retobj$convergence == 0) # save success indicator
	}

	parmatrix
}

# Funtion that identifies subjects that behaved erraticly and exhibit individual parameter estimates outside the identifiable range
f.droperratic <- function(par1, par2) {

	range <- c(-3,1) # Identifiable parameter range

	drop <- matrix(NA, nrow(par1), 4, dimnames=list(rownames(par1),c()))
	for (i in 1:4) {
		drop[,i] <- (par1[,i] < range[1]) | (par1[,i] > range[2]) | (par2[,i] < range[1]) | (par2[,i] > range[2])
	}

	rowSums(drop)
}


# seasonality and spatial gradients on land and ocean (SD of monthly means)

library(raster)
library(reshape2)
library(RColorBrewer)
library(maps)

source('analysis/image.scale.r') # for plotting color bar on image

load('data/udel/udel1986_2005.rdata') # tempsarray lst 0.5x0.5°
	lstarray <- tempsarray
#load('data/ersstv4/ersst1986_2005.rdata') # tempsarray sst
load('data/oisst/oisst0.5deg_1986_2005.rdata') # tempsarray sst 0.5x0.5°
	sstarray <- tempsarray
	rm(tempsarray)

lstar <- lstarray
sstar <- sstarray

# calculate mean annual climatology (for comparison against variability)
	lstclim <- apply(lstar, MARGIN=c(1,2), FUN=mean) # mean through time
	sstclim <- apply(sstar, MARGIN=c(1,2), FUN=mean)

	# reformat sst to start at date line (-180 to 180) to match lstclim
	sstlons <- as.numeric(colnames(sstclim))
	sstclim <- sstclim[, c(which(sstlons > 180), which(sstlons < 180))]
	newlons <- sstlons[c(which(sstlons > 180), which(sstlons < 180))]
	newlons[newlons >180] <- newlons[newlons >180] - 360
	colnames(sstclim) <- newlons

# analyze seasonal variability
	lstseason <- apply(lstar, MARGIN=c(1,2), FUN=sd) # SD through time
	sstseason <- apply(sstar, MARGIN=c(1,2), FUN=sd)

		# reformat sst to start at date line (-180 to 180), to match lst
		lons <- as.numeric(colnames(sstseason))
		neworder <- c(lons[lons>180], lons[lons<180])
		sstseason_reformat <- sstseason[,as.character(neworder)]
		lons2 <- neworder
		lons2[lons2>180] <- lons2[lons2>180] - 360
		colnames(sstseason_reformat) <- lons2

		# plot spatial patterns on one map
		cols <- colorRampPalette(brewer.pal(9, "OrRd"))(100)
		zlims <- range(c(lstseason, sstseason), na.rm=TRUE)
		image(t(sstseason_reformat), col=cols, zlim=zlims, main='Seasonality (°C)')
		image(t(lstseason), col=cols, zlim=zlims, add=TRUE)

		#copy to original
		sstseason <- sstseason_reformat

	mean(lstseason, na.rm=TRUE) # 9.01 °C
	mean(sstseason, na.rm=TRUE) # 1.48 °C
	mean(lstseason, na.rm=TRUE)/mean(sstseason, na.rm=TRUE) # 6.1x

	# write out arrays
	save(lstseason, file='temp/lstseason.rdata')
	save(sstseason, file='temp/sstseason.rdata')

	# lat means
	lstseasonlat <- apply(lstseason, MARGIN=1, FUN=mean, na.rm=TRUE) # mean within lats
	sstseasonlat <- apply(sstseason, MARGIN=1, FUN=mean, na.rm=TRUE)

	lstseasonlatsd <- apply(lstseason, MARGIN=1, FUN=sd, na.rm=TRUE) # sd within lat bands
	sstseasonlatsd <- apply(sstseason, MARGIN=1, FUN=sd, na.rm=TRUE)

	lstlats <- as.numeric(names(lstseasonlat))
	sstlats <- as.numeric(names(sstseasonlat))

	# examine lat gradients
	i <- !is.na(lstseasonlat)
	lstseasonlat2 <- lstseasonlat[i]
	lstseasonlatsd2 <- lstseasonlatsd[i]
	lstseasonlatsd2[is.na(lstseasonlatsd2)] <- 0
	lstlats2 <- lstlats[i]

	i <- !is.na(sstseasonlat)
	sstseasonlat2 <- sstseasonlat[i]
	sstseasonlatsd2 <- sstseasonlatsd[i]
	sstseasonlatsd2[is.na(sstseasonlatsd2)] <- 0
	sstlats2 <- sstlats[i]

	plot(-200,0, xlim=c(-90,90), ylim=c(-2,18), xlab='lat', ylab='Seasonality (°C)')
	polygon(c(lstlats2, rev(lstlats2)), c(lstseasonlat2 - lstseasonlatsd2, rev(lstseasonlat2 + lstseasonlatsd2)), col='light green', border=NA)
	lines(lstlats2, lstseasonlat2, col='dark green')
	polygon(c(sstlats2, rev(sstlats2)), c(sstseasonlat2 - sstseasonlatsd2, rev(sstseasonlat2 + sstseasonlatsd2)), col='light blue', border=NA)
	lines(sstlats2, sstseasonlat2, col='dark blue')

	# write out lat means
	write.csv(data.frame(lat=lstlats, season=as.numeric(lstseasonlat), sd=lstseasonlatsd), file='temp/lstseasonlat.csv', row.names=FALSE)
	write.csv(data.frame(lat=sstlats, season=as.numeric(sstseasonlat), sd=sstseasonlatsd), file='temp/sstseasonlat.csv', row.names=FALSE)

# analyze seasonal ranges
	# function to calculate average annual range
	aveannrng <- function(x, yrs){
		annrngs <- aggregate(list(rng=x), by=list(year=yrs), FUN= function(x) diff(range(x))) # calc range for each year
		return(mean(annrngs$rng)) # return average annual range
	}

	yrs <- as.numeric(gsub('_[[:digit:]]+', '', gsub('X', '', dimnames(lstar)[[3]]))) # extract year from array names
	lstrng <- apply(lstar, MARGIN=c(1,2), FUN=aveannrng, yrs=yrs) # average annual range
	yrs <- as.numeric(gsub('_[[:digit:]]+', '', gsub('X', '', dimnames(sstar)[[3]])))
	sstrng <- apply(sstar, MARGIN=c(1,2), FUN=aveannrng, yrs=yrs)

		# image(t(lstrng), col=rainbow(100))
		# image(t(sstrng), col=rainbow(100))

	# reformat sst to start at date line (-180 to 180), to match lst
	lons <- as.numeric(colnames(sstrng))
	neworder <- c(lons[lons>180], lons[lons<180])
	sstrng_reformat <- sstrng[,as.character(neworder)]
	lons2 <- neworder
	lons2[lons2>180] <- lons2[lons2>180] - 360
	colnames(sstrng_reformat) <- lons2

		# plot spatial patterns
		cols <- colorRampPalette(brewer.pal(9, "OrRd"))(100)
		zlims <- range(c(lstrng, sstrng), na.rm=TRUE)
		image(t(sstrng_reformat), col=cols, zlim=zlims, main='Range (°C)')
		image(t(lstrng), col=cols, zlim=zlims, add=TRUE)

		#copy to original
		sstrng <- sstrng_reformat

	mean(lstrng, na.rm=TRUE) # 26.2
	mean(sstrng, na.rm=TRUE) # 4.14
	mean(lstrng, na.rm=TRUE)/mean(sstrng, na.rm=TRUE) # 6.3

	# write out arrays
	save(lstrng, file='temp/lstrng.rdata')
	save(sstrng, file='temp/sstrng.rdata')

	# mean within lats
	lstrnglat <- apply(lstrng, MARGIN=1, FUN=mean, na.rm=TRUE)
	sstrnglat <- apply(sstrng, MARGIN=1, FUN=mean, na.rm=TRUE)

	# examine
	plot(as.numeric(names(lstrnglat)), lstrnglat, type='l', col='green', xlab='lat', ylab='range', ylim=c(0,50))
	lines(as.numeric(names(sstrnglat)), sstrnglat, col='blue')

	# write out
	write.csv(data.frame(lat=as.numeric(names(lstrnglat)), range=as.numeric(lstrnglat)), file='temp/lstrnglat.csv', row.names=FALSE)
	write.csv(data.frame(lat=as.numeric(names(sstrnglat)), range=as.numeric(sstrnglat)), file='temp/sstrnglat.csv', row.names=FALSE)

# spatial gradients
	lstclima <- apply(lstar, MARGIN=c(1,2), FUN=mean) # average over time
	lstclimr <- raster(lstclima[nrow(lstclima):1,], xmn=-180, xmx=180, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84') # make a raster from the climatology
	lstterr <- terrain(lstclimr, opt='slope', unit='tangent', neighbors=8) # returns °C/m
	lstgrad <- as.matrix(lstterr)

	sstclima <- apply(sstar, MARGIN=c(1,2), FUN=mean) # average over time
	sstclimr <- raster(sstclima[nrow(sstclima):1,], xmn=-180, xmx=180, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84') # make a raster from the climatology
	sstterr <- terrain(sstclimr, opt='slope', unit='tangent', neighbors=8) # returns °C/m
	sstgrad <- as.matrix(sstterr)

		# plot
		cols <- colorRampPalette(brewer.pal(9, "OrRd"))(100)
		image(lstgrad, col=cols)
		image(sstgrad, col=cols)

	# latitudinal means
	lstgradlat <- apply(lstgrad, MARGIN=1, FUN=mean, na.rm=TRUE)
	lstgradlatsd <- apply(lstgrad, MARGIN=1, FUN=sd, na.rm=TRUE)

	sstgradlat <- apply(sstgrad, MARGIN=1, FUN=mean, na.rm=TRUE)
	sstgradlatsd <- apply(sstgrad, MARGIN=1, FUN=sd, na.rm=TRUE)

	lats <- yFromRow(lstterr) # same for sst and lst, so this works
	lstgradlat <- data.frame(lat=lats, grad=lstgradlat*1000, sd=lstgradlatsd*1000) # convert so units of °C/km
	sstgradlat <- data.frame(lat=lats, grad=sstgradlat*1000, sd=sstgradlatsd*1000)

	# plot
	i <- complete.cases(lstgradlat)
	i2 <- complete.cases(sstgradlat)

	quartz(w=4,h=4)
	plot(-200,0, xlim=c(-90,90), ylim=c(-0.03,0.14), xlab='lat', ylab='Gradients (°C)')
	with(lstgradlat[i,], polygon(c(lat, rev(lat)), c(grad - sd, rev(grad + sd)), col='light green', border=NA))
	with(lstgradlat[i,], lines(lat, grad, col='dark green'))
	with(sstgradlat[i2,], polygon(c(lat, rev(lat)), c(grad - sd, rev(grad + sd)), col='light blue', border=NA))
	with(sstgradlat[i2,], lines(lat, grad, col='dark blue'))

	# write out
	write.csv(lstgradlat, file='temp/lstgradlat.csv', row.names=FALSE)
	write.csv(sstgradlat, file='temp/sstgradlat.csv', row.names=FALSE)

### Plots
	# Climatology map (for comparison)
	zlims <- range(c(lstclim, sstclim), na.rm=TRUE)
	bks <- seq(zlims[1], zlims[2],length.out=101)
	cols <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks)-1)

	quartz(width=5, height=5)
	# png('figures/climatology_mar_vs_terr_map.png', width=5, height=5, units='in', res=300)
	layout(matrix(c(1,2), nrow=2, ncol=1), heights=c(4,1))

	par(mar=c(3,3,1,1), las=1, mgp=c(1.6,0.5,0), tck=-0.015, cex.axis=0.8)
	image(y=seq(-89.75, 89.75, by=0.5), x=seq(-179.75, 179.75, by=0.5), z=t(lstclim), col=cols, breaks=bks, main='', xlab='Longitude', ylab='Latitude')
	image(y=seq(-89.75, 89.75, by=0.5), x=seq(-179.75, 179.75, by=0.5), z=t(sstclim), col=cols, zlim=zlims, add=TRUE)
	map(add=TRUE, interior=FALSE, col='dark grey')

		# scale bar
	par(mar=c(3,1,1,1), mgp=c(1.4, 0.1, 0))
	image.scale(zlim=zlims, col=cols, breaks=bks, horiz=TRUE, xlab='Mean annual temperature (°C)')

	dev.off()

	# Seasonality map
	zlims <- range(c(lstseason, sstseason), na.rm=TRUE)
	bks <- seq(zlims[1], zlims[2],length.out=101)
	cols <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks)-1)

	quartz(width=5, height=5)
	# png('figures/seasonality_mar_vs_terr_map.png', width=5, height=5, units='in', res=300)
	layout(matrix(c(1,2), nrow=2, ncol=1), heights=c(4,1))

	par(mar=c(3,3,1,1), las=1, mgp=c(1.6,0.5,0), tck=-0.015, cex.axis=0.8)
	image(y=seq(-89.75, 89.75, by=0.5), x=seq(-179.75, 179.75, by=0.5), z=t(lstseason), col=cols, breaks=bks, main='', xlab='Longitude', ylab='Latitude')
	image(y=seq(-89.75, 89.75, by=0.5), x=seq(-179.75, 179.75, by=0.5), z=t(sstseason), col=cols, zlim=zlims, add=TRUE)
	map(add=TRUE, interior=FALSE, col='dark grey')

		# scale bar
	par(mar=c(3,1,1,1), mgp=c(1.4, 0.1, 0))
	image.scale(zlim=zlims, col=cols, breaks=bks, horiz=TRUE, xlab='Seasonality (°C)')

	dev.off()

	# Seasonality by latitude
	cols <- c('#b2df8a', '#1f78b4')
	lw <- 3 # line width
	quartz(width=4,height=4)
	# pdf('analysis/figures/seasonality_mar_vs_terr.pdf', width=3, height=3)
	par(mfrow=c(1,1), mai=c(0.6, 0.6, 0.1, 0.1), mgp=c(2,0.4,0), las=1, tcl=-0.2)
	with(lstseasonlat, plot(lat, season, col=cols[1], ylab='Seasonality (°C)', xlab='Latitude (°)', lwd=lw, type='l', ylim=c(0,14), xlim=c(-90,90)))
	with(sstseasonlat, lines(lat, season, col=cols[2], lwd=lw))

	legend('topleft', legend=c('terrestrial', 'marine'), col=cols, lty=c(1,1), bty='n', cex=0.7)

	dev.off()

	# Range map
	zlims <- range(c(lstrng, sstrng), na.rm=TRUE)
	bks <- seq(zlims[1], zlims[2],length.out=101)
	cols <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks)-1)

	quartz(width=5, height=5)
	# png('figures/range_mar_vs_terr_map.png', width=5, height=5, units='in', res=300)
	layout(matrix(c(1,2), nrow=2, ncol=1), heights=c(4,1))

	par(mar=c(3,3,1,1), las=1, mgp=c(1.6,0.5,0), tck=-0.015, cex.axis=0.8)
	image(y=seq(-89.75, 89.75, by=0.5), x=seq(-179.75, 179.75, by=0.5), z=t(sstrng), col=cols, breaks=bks, main='', xlab='Longitude', ylab='Latitude')
	image(y=seq(-89.75, 89.75, by=0.5), x=seq(-179.75, 179.75, by=0.5), z=t(lstrng), col=cols, zlim=zlims, add=TRUE)
	map(add=TRUE, interior=FALSE, col='dark grey')

		# scale bar
	par(mar=c(3,1,1,1), mgp=c(1.4, 0.1, 0))
	image.scale(zlim=zlims, col=cols, breaks=bks, horiz=TRUE, xlab='Range (°C)')

	dev.off()

	# Spatial gradients by latitude
	cols <- c('#b2df8a', '#1f78b4')
	lw <- 3 # line width
	quartz(width=4,height=4)
	# pdf('figures/spatialgrads_mar_vs_terr.pdf', width=3, height=3)
	par(mfrow=c(1,1), mai=c(0.6, 0.6, 0.1, 0.1), mgp=c(2,0.4,0), las=1, tcl=-0.2)
	with(lstgradlat, plot(lat, grad*1000, col=cols[1], xlab='Latitude (°)', ylab='Spatial gradients (°C/km)', lwd=lw, type='l', ylim=c(0,0.06), xlim=c(-90,90)))
	with(sstgradlat, lines(lat, grad*1000, col=cols[2], lwd=lw))

	legend('topleft', legend=c('terrestrial', 'marine'), col=cols, lty=c(1,1), bty='n', cex=0.7)

	dev.off()

	# Seasonality vs. mean annual
		# option 1: two plots with longitude
	colramp <- colorRamp(brewer.pal(9, "OrRd"))

		# matrix of longitudes for plotting
	longrd <- matrix(as.numeric(colnames(lstclim)), nrow=1)
	longrd <- longrd[rep(1, nrow(lstclim)),]
	longrd.sc <- (longrd - min(longrd))/diff(range(longrd))

	quartz(width=10, height=5)
	# jpeg('figures/seasonality_vs_mean_annual_mar_and_terr_withlon.jpg', width=5, height=5, units='in', res=300)

	par(mfrow=c(1,2), mai=c(0.7,0.7,0.5, 0.1), las=1, mgp=c(2,0.7,0), cex.axis=0.8)

	plot(sstclim, sstseason, xlab='Mean annual temperature (°C)', ylab='Seasonality (°C)', main='Sea surface', col=rgb(colramp(longrd.sc), maxColorValue=255), pch=16, cex=0.5)

	legend('topleft', pch=16, col=rgb(colramp(c(0,0.5,1)), maxColorValue=255), legend=c('-180°', '0°', '180°'), title='Longitude')

	plot(lstclim, lstseason, xlab='Mean annual temperature (°C)', ylab='Seasonality (°C)', main='Land surface', col=rgb(colramp(longrd.sc), maxColorValue=255), pch=16, cex=0.5)

	dev.off()

		# option 2: two plots with latgitude
	colramp <- colorRamp(brewer.pal(9, "OrRd"))

		# matrix of latitudes for plotting
	latgrd <- matrix(as.numeric(rownames(lstclim)), ncol=1)
	latgrd <- latgrd[,rep(1, ncol(lstclim))]
	latgrd.sc <- (latgrd - min(latgrd))/diff(range(latgrd))

	quartz(width=10, height=5)
	# jpeg('figures/seasonality_vs_mean_annual_mar_and_terr_withlat.jpg', width=10, height=5, units='in', res=300)

	par(mfrow=c(1,2), mai=c(0.7,0.7,0.5, 0.1), las=1, mgp=c(2,0.7,0), cex.axis=0.8)

	plot(sstclim, sstseason, xlab='Mean annual temperature (°C)', ylab='Seasonality (°C)', main='Sea surface', col=rgb(colramp(latgrd.sc), maxColorValue=255), pch=16, cex=0.5)

	legend('topleft', pch=16, col=rgb(colramp(c(0,0.5,1)), maxColorValue=255), legend=c('-90°', '0°', '90°'), title='Latitude')

	plot(lstclim, lstseason, xlab='Mean annual temperature (°C)', ylab='Seasonality (°C)', main='Land surface', col=rgb(colramp(latgrd.sc), maxColorValue=255), pch=16, cex=0.5)

	dev.off()

		# option 2: on one plot
	cols <- c('#b2df8a11', '#1f78b40b') # land, ocean

	quartz(width=5, height=5)
	# jpeg('figures/seasonality_vs_mean_annual_mar_and_terr.jpg', width=5, height=5, units='in', res=300)
	# pdf('figures/seasonality_vs_mean_annual_mar_and_terr.pdf', width=5, height=5)
	par(mai=c(0.7,0.7,0.5, 0.1), las=1, mgp=c(2,0.7,0), cex.axis=0.8, tcl=-0.2)

	plot(lstclim, lstseason, xlab='Mean annual temperature (°C)', ylab='Seasonality (°C)', main='', col=cols[1], pch=16, cex=0.5)

	points(sstclim, sstseason, col=cols[2], pch=16, cex=0.5)

	legend('topright', pch=16, col=c('#b2df8a', '#1f78b4'), legend=c('land surface', 'sea surface'))

	dev.off()


# Pull PWT into dataframe
data("pwt9.1")

p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$lnpop <- round(log(p$pop),digits=2) # create log population
p$ky <- round(p$rnna/p$rgdpna,digits=2) # create K/Y ratio
p$phil <- round(p$labsh*p$rgdpna/(p$labsh*p$rgdpna+.05*p$rnna),digits=2) # create kludge cost share of labor
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.lngdppc = dplyr::lag(lngdppc, n = 10, default = NA))
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.lnpop = dplyr::lag(lnpop, n = 10, default = NA))
p$g10.lngdppc <- (p$lngdppc - p$lag10.lngdppc)/10
p$g10.lnpop <- (p$lnpop - p$lag10.lnpop)/10
p$lagyear <- p$year-10
p$csh_trade <- p$csh_x - p$csh_m
p$csh_mabs <- -1*p$csh_m

# subset PWT into stable and catchup groups
stable <- p[which(p$isocode %in% c("USA", "CAN", "MEX", "GBR", "AUS")),]
catchup <- p[which(p$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]
test <- p[which(p$isocode %in% c("ETH", "ZAF","BWA")),]
usa <- p[which(p$isocode %in% c("USA")),]
all <- p[which(p$isocode %in% c("USA", "MEX", "DEU","JPN","KOR","CHN")),]

fig <- plot_ly(usa, x = ~lagyear, y = ~g10.lnpop, color = ~country, type = 'scatter', mode='lines+markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Population growth rate', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = '10-year population growth rate', range=c(0,.02)))
api_create(fig, filename = "pwt-usa-pop-growth")

fig <- plot_ly(all, x = ~csh_g, y = ~g10.lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Government and growth', x=0),
              xaxis = list(title = 'Gov. spending share of GDP'),
              yaxis = list (title = '10-year growth rate'))
api_create(fig, filename = "pwt-all-cshg-growth")

fig <- plot_ly(all, x = ~csh_g, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Government and level of GDP per capita', x=0),
              xaxis = list(title = 'Gov. spending share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-test-chsg-level")

us <- p[which(p$isocode %in% c("USA")),]
fig <- plot_ly(us, x = ~lagyear, y = ~g10.lngdppc, type = 'scatter', mode='lines+markers', colors = "Set1")
fig <- layout(fig, title = list(text = '10-year growth rate', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = '10-year growth rate', range=c(0,.04)))
api_create(fig, filename = "pwt-usa-growth-rate")

fig <- plot_ly(all, x = ~csh_trade, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Trade and level of GDP per capita', x=0),
              xaxis = list(title = '(Exports+Imports) as share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-all-trade-level")

fig <- plot_ly(all, x = ~csh_x, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Exports and level of GDP per capita', x=0),
              xaxis = list(title = 'Exports as share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-all-export-level")

fig <- plot_ly(all, x = ~csh_mabs, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Imports and level of GDP per capita', x=0),
              xaxis = list(title = 'Imports as share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-all-imports-level")

############################
# Figures for log GDP per capita
############################
fig <- plot_ly(test, x = ~year, y = ~lngdppc, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-test-lngdppc")

fig <- plot_ly(stable, x = ~year, y = ~lngdppc, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita for stable growth countries', x=0),
               xaxis = list(title = 'Year'),
               yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
               hovermode="x unified")
api_create(fig, filename = "pwt-stable-lngdppc")

fig <- plot_ly(catchup, x = ~year, y = ~lngdppc, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita for catch-up growth countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-lngdppc")

############################
# Figures of labor share
############################

fig <- plot_ly(stable, x = ~year, y = ~labsh, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/GDP for stable growth countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Compensation share of GDP', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-labsh")

fig <- plot_ly(catchup, x = ~year, y = ~labsh, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/GDP for catch-up growth countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Compensation share of GDP', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-labsh")

############################
# Figures of labor cost share
############################

fig <- plot_ly(stable, x = ~year, y = ~phil, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/Total Costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'W/(W+RK)', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-phil")

fig <- plot_ly(catchup, x = ~year, y = ~phil, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/Total Costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'W/(W+RK)', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-phil")

############################
# Figures of convergence
############################
# get 10-year lagged value of log gdppc, by country
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.lngdppc = dplyr::lag(lngdppc, n = 10, default = NA))
p$g10.lngdppc <- (p$lngdppc - p$lag10.lngdppc)/10

# just need the catchup group
catchup <- p[ which(p$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]

pal <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00','#ffff33')
pal <- setNames(pal, c("CHN", "DEU", "JPN","KOR","NGA","USA"))
fig <- plot_ly(catchup, x = ~lag10.lngdppc, y = ~g10.lngdppc, text=~year,
               color = ~isocode,
               colors = pal,
               type = 'scatter',
               mode = 'markers',
               hovertemplate = paste("%{text}
",
                                     "%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
"),
               marker = list(size = 7)
               )
fig <- layout(fig, title=list(text = 'Convergence and non-convergence', x= 0),
              xaxis = list(title = 'Initial log GDP per capita',range=c(6,11)),
              yaxis = list (title = '10-year growth rate')
              )
api_create(fig, filename = "pwt-catchup-convergence")

############################
# Figures of K/Y ratio
############################
p1960 <- p[which(p$year >1959),] # drop 50-59 b/c of PWT initial ky guess
stable <- p1960[ which(p1960$isocode %in% c("USA", "CAN", "MEX", "GBR", "AUS")),]
catchup <- p1960[ which(p1960$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]

fig <- plot_ly(stable, x = ~year, y = ~ky, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output ratio for stable countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio',range=c(0,7)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-ky")

fig <- plot_ly(catchup, x = ~year, y = ~ky, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output ratio for catch-up countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio',range=c(0,7)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-ky")


data(trees)
View(trees)
cor.test(trees$Girth,trees$Volume)

R Community/R Stats_Basics Part 1/Assignment1.r