#弯月面Meniscus的高度和角度随流量，极间距离，电压变化而变化
#针头三种液体，ethanol，acetone， isoproply
#height高度和angle角度，在一张图上，分为上下部分
#三张图，分别对应三种x轴，流量，极间距离，电压
#两张大图，分别对应height和angle
#函数名为men_ih & men_ia, men_ih & men_ia，men_ih & men_ia

#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据

men_ih<-read.xlsx("meniscus.xls",sheetName="voltage_h", header=TRUE)
men_ia<-read.xlsx("meniscus.xls",sheetName="voltage_a", header=TRUE)

#规划figure界面
par(mfrow=c(2,1), mar=c(4,4,2,2), oma=c(1,1,1,1))

#############针对voltage极间距离###########

#保存pdf
#pdf("men_voltage.pdf")

################################画图-高度曲线###########################
plot(men_ih$voltage, men_ih$ethanol, col=0, xaxs="i", xlim=c(1.3, 2.6), ylim=c(0, 1.3),
xlab="Voltage (HV)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Height with V in meniscus")

lines(lowess(men_ih$voltage, men_ih$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ih$voltage, men_ih$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ih$voltage, men_ih$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topright", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

##############################画图--角度曲线############################
plot(men_ia$voltage, men_ia$ethanol, col=0, xaxs="i", xlim=c(1.3, 2.6), ylim=c(45, 150),
xlab="Voltage (HV)", cex.lab=1, ylab="Taylor Angle （°）", main="Angle with H in meniscus")

lines(lowess(men_ia$voltage, men_ia$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ia$voltage, men_ia$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ia$voltage, men_ia$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

#dev.off()


# compare speed of aging between diff-t tissues and sexes

# Total: 18 tissues

# Sexes:
# F
# M

# Create df:
# tis | sex | age | pred

# Read:
# Subject-Sample annotation -- fill (Subject | Age)

# Read:
# Confident tissue predictors

# Read:
# Tissue1_data -- use predictors to create RF, predict age, fill (| Age_Tissue1|) column
library(randomForest)
library(ggplot2)
library(gridExtra)
library(lme4)
library(arm)
require(reshape)

# tis = c('Kidney-Cortex')
tis = c(
    "Adipose-Subcutaneous",
    "Adipose-Visceral(Omentum)",
    "Artery-Aorta",
    "Artery-Tibial",
    "Breast-MammaryTissue",
    "Cells-Transformedfibroblasts",
    "Colon-Sigmoid",
    "Colon-Transverse",
    "Esophagus-GastroesophagealJunction",
    "Esophagus-Mucosa",
    "Esophagus-Muscularis",
    "Heart-AtrialAppendage",
    "Heart-LeftVentricle",
    "Lung",
    "Muscle-Skeletal",
    "Nerve-Tibial",
    "Pancreas",
    "Skin-NotSunExposed(Suprapubic)",
    "Skin-SunExposed(Lowerleg)",
    "Stomach",
    "Testis",
    "Thyroid",
    "WholeBlood"
)

sex = c('F', 'M')
conf = read.table('./v7/tested_sign_features(transcript).txt', stringsAsFactors = F, sep ='\t', header = 1, row.names = 1)

subj_samp = read.table('./v7/subj_sample_annot.txt', stringsAsFactors = F, sep = '\t', header = 1, row.names = 1)
subj_samp = subj_samp[substr(rownames(subj_samp),1,1) == 'G',]
subj_samp$Subject.ID = regmatches(rownames(subj_samp),regexpr("^GTEX-\\w+",rownames(subj_samp)))
subj_samp$Prediction = NA
subj_samp$Age = as.numeric(paste0(substr(subj_samp[['Age']], 1, 1),'5'))

subjects = as.data.frame(matrix(ncol = 2, nrow = length(unique(subj_samp$Subject.ID))))
colnames(subjects) = c('Age','ID')
rownames(subjects) = unique(subj_samp$Subject.ID)
for (i in rownames(subjects)){
  subjects[i,1] = subj_samp[subj_samp$Subject.ID == i,'Age'][1]
  subjects[i,2] = i
}

# Downsample
# 53/52/115/235/226/21
n = 40
ages = unique(subj_samp$Age)
downsamp = subj_samp[0,]
for (a in ages){
  ids = subjects[subjects$Age == a,2][1:min(n,length(subjects[subjects$Age == a,2]))]
  downsamp = rbind(downsamp,subj_samp[((subj_samp$Age == a)&(subj_samp$Subject.ID %in% ids)),])
}

subj_samp = downsamp

for (t in tis) {
  set.seed(1238)

  tis_samp = read.table(paste0('./v7/tissue_samples/samples_from_', t,'.txt'), stringsAsFactors = F,
                        check.names=F, header = 1, row.names = 1)

  tis_samp$gene_id <- NULL
  tis_samp = as.data.frame(t(tis_samp))
  tis_samp$Age = subj_samp[rownames(tis_samp),'Age']
  conf_tis = strsplit(conf[t,1], split = ', ')[[1]]
  if (is.na(conf_tis[1])){
    next
  }

  tis_samp = tis_samp[,c(conf_tis,'Age')]
  tis_samp = na.omit(tis_samp)

  rf = randomForest(Age ~ ., data = tis_samp, ntrees = 128)
  rmse = (sum(as.vector(rf$predicted - tis_samp$Age)**2)/length(tis_samp$Age))**0.5
  print(paste0('RMSE for ', t, ' is ', round(rmse,2), 'yrs'))

  subj_samp[names(rf$predicted),'Prediction'] = rf$predicted
}

subj_samp = subj_samp[(!(is.na(subj_samp$Prediction))),]

subj_preds = as.data.frame(matrix(ncol = length(c(unique(subj_samp$Tissue))) + 2, nrow = length(unique(subj_samp$Subject.ID))))
colnames(subj_preds) = c(unique(subj_samp$Tissue), 'Age', 'Prediction')
rownames(subj_preds) = unique(subj_samp$Subject.ID)

for (i in rownames(subj_preds)){
  temp = subj_samp[subj_samp$Subject.ID == i,]
  for (j in rownames(temp)){
    subj_preds[i,temp[j,'Tissue']] = temp[j,'Prediction']
    subj_preds[i,'Sex'] = temp[1,'Sex']
    subj_preds[i,'Age'] = temp[1,'Age']
  }
}
colnames(subj_preds) = make.names(colnames(subj_preds), unique = T)

x = rfImpute(Age ~ ., data = subj_preds[,!(names(subj_preds) %in% c('Rand_age', 'Error','Subject','Sex','Prediction'))], ntree = 128)
y = randomForest(Age ~ ., data = x, ntrees = 128)

subj_preds$Prediction = y$predicted
subj_preds$Rand_age = subj_preds$Age + runif(nrow(subj_preds), -5, 5)

MLexamp <- lmer(Age ~ Prediction + Tissue + (1 + Prediction | Sex), data = subj_samp)
display(MLexamp)
coef(MLexamp)
############
############
############
############
############
############
df = subj_preds
sc_plot <- ggplot(df, aes(df$Prediction, df$Rand_age, color = df$Sex)) +
  geom_point(alpha=.3, size = 3) +
  scale_color_manual(values = c('#109910', '#991010')) +
  theme_classic() +
  theme(legend.position='right') +
  labs(x = 'Prediction', y = 'Age')
sc_plot

# subj_samp$Error = subj_samp$Age - subj_samp$Prediction
# boxplot(subj_samp[subj_samp['Sex'] == 'F','Error'],subj_samp[subj_samp['Sex'] == 'M','Error'])
# subj_samp$Rand_age = subj_samp$Age + runif(nrow(subj_samp), -5, 5)

############
# + Subject.ID

# MLexamp <- glm(Age ~  Prediction + Tissue*Sex, data = subj_samp)
# x = (as.data.frame(MLexamp$coefficients))

############

temp = subj_preds[,!(names(subj_preds) %in% c('Subject','Sex','Rand_age','Error'))]
temp = temp - subj_preds$Age
boxplot(temp)

tis_cor = list()
for (i in colnames(temp)){
  tis_cor[i] = cor(temp[!is.na(temp[i]),c(i,'Prediction')])[1,2]
}

for (i in rownames(x)){
  x[i,] = rank(x[i,])
}

p1 <- ggplot(data = melt(x[x$Age == 25,]), aes(x=variable, y=value)) + geom_boxplot(aes(fill=variable)) +
  theme(legend.position="none") +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  ylim(20,65)
p2 <- ggplot(data = melt(x[x$Age == 35,]), aes(x=variable, y=value)) + geom_boxplot(aes(fill=variable)) +
  theme(legend.position="none") +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  ylim(20,65)
p3 <- ggplot(data = melt(x[x$Age == 45,]), aes(x=variable, y=value)) + geom_boxplot(aes(fill=variable)) +
  theme(legend.position="none") +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  ylim(30,70)
p4 <- ggplot(data = melt(x[x$Age == 55,]), aes(x=variable, y=value)) + geom_boxplot(aes(fill=variable)) +
  theme(legend.position="none") +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  ylim(30,65)
p5 <- ggplot(data = melt(x[x$Age == 65,]), aes(x=variable, y=value)) + geom_boxplot(aes(fill=variable)) +
  theme(legend.position="bottom") +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())
p6 <- ggplot(data = melt(x[x$Age == 75,]), aes(x=variable, y=value)) + geom_boxplot(aes(fill=variable)) +
  theme(legend.position="none") +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())

grid.arrange(p1, p2, p3, p4, p5, p6, ncol = 3, nrow = 2, widths = c(6,10,6), heights = c(4, 4))


#!/usr/local/bin/Rexec
########### set arguments list ###############################
args<-commandArgs();
args_start=grep("--args",args)+1;
if  (length(args_start)>0 && args_start < length(args) ) {
    args<-args[args_start:length(args)]
} else {
    args=c()
}

onset<-function(
                width=4,
                height=6,
                eps=FALSE,
                dt=.001,
                time=10/dt,
                tau1=1,tau2=tau1*2/3,
                k=1,
                start1=ceiling(time/8),
                start2=ceiling(time*2/8)) {

    v = matrix(rep(0,time*2),time,2);
    u = matrix(rep(0,time*2),time,2);
    h = matrix(rep(0,time*2),time,2);
    h[start1,1]=1000;
    h[start2,2]=1000;
    xgap=time/5;
    xlim=c(-xgap,time+xgap)
    ylim=c(-.5,1.5)
    axlim=c(-xgap/2,time)
    aylim=c(-.3,1.3)

    lwd <- 1.5

    # simulation
    for(t in 2:time) {

        # pre-synaptic onset
        v[t,1] = v[t-1,1] + (dt/tau1)*( -v[t-1,1] +k*h[t,1] );
        u[t,1] = u[t-1,1] + (dt/tau1)*( -u[t-1,1] +v[t-1,1] );

        # post-synaptic onset
        v[t,2] = v[t-1,2] + (dt/tau2)*( -v[t-1,2] +k*h[t,2] );
        u[t,2] = u[t-1,2] + (dt/tau2)*( -u[t-1,2] +v[t-1,2] );

    }
        if(eps==TRUE) {
        postscript(
                   'onset.eps',
                   onefile=FALSE,
                   horizontal=FALSE,
                   width=width,height=height,
                   family="times");
    }

    layout(c(4,1,1,1,2,2,2,3,3,3,4),11,1)
    par(mar=c(.01,.01,.01,.01))

    plot(
         h[,1]/1000,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=lwd,
         xlim=xlim,
         ylim=ylim,
         family="serif")

    polygon(c(1:time,time), c(h[,1], h[,1][1]), col='#DDDDDD',border=NA)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=lwd,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(h(t))),cex=2)
    text(start1,-.3,expression(italic(t[i])),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)

    plot(
         1e200,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=1,
         xlim=xlim,
         ylim=ylim)

    polygon(c(1:time,time), c(v[,1], v[,1][1]), col='#DDDDDD',border=NA)
    lines(v[,1], lwd=lwd)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=lwd,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(v(t))),cex=2)
    text(start1,-.3,expression(italic(t[i])),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)

    plot(
         1e200,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=1,
         xlim=xlim,
         ylim=ylim)

    polygon(c(1:time,time), c(u[,1], u[,1][1]), col='#DDDDDD',border=NA)
    lines(u[,1], lwd=lwd)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=lwd,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(u(t))),cex=2)
    text(start1,-.3,expression(italic(t[i])),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(start1+ceiling(tau1/dt),-.3,expression(italic(tau+t[i])),cex=2,adj=c(.2,.5))
    arrows(start1+ceiling(tau1/dt),0,start1+ceiling(tau1/dt),
           u[start1+ceiling(tau1/dt),1],lwd=lwd,length=0,lty=3);

    if(eps==TRUE) {
        graphics.off();
    }

}

derivatives<-function(
                      width=4,
                      height=6,
                      eps=FALSE,
                      name="onset_tau.eps",
                      dt=.001,
                      time=10/dt,
                      tau1=1,tau2=tau1,
                      k=1,
                      start1=ceiling(dt)+1,
                      start2=ceiling(time*2/8)) {

    v = matrix(rep(0,time*2),time,2);
    u = matrix(rep(0,time*2),time,2);
    h = matrix(rep(0,time*2),time,2);
    h[start1:length(h[,1]),1]=1;
    h[start2:length(h[,2]),2]=1;
    xgap=time/5;
    xlim=c(-xgap,time+xgap)
    ylim=c(-.5,1.3)
    axlim=c(-xgap/2,time)
    aylim=c(-.3,1.1)

    # simulation
    for(t in 2:time) {

        # pre-synaptic onset
        v[t,1] = v[t-1,1] + (dt/tau1)*( -v[t-1,1] +k*h[t,1] );
        u[t,1] = u[t-1,1] + (dt/tau1)*( -u[t-1,1] -v[t-1,1] + k*h[t,1] );

        # post-synaptic onset
        v[t,2] = v[t-1,2] + (dt/tau2)*( -v[t-1,2] +k*h[t,2] );
        u[t,2] = u[t-1,2] + (dt/tau2)*( -u[t-1,2] -v[t-1,2] + k*h[t,2] );

    }
        u1=u[,1];
    u2=u[,2];
    timetime=1:time;
    du1=c(0,(u1[2:time]-u1[1:(time-1)])/dt);
    du2=c(0,(u2[2:time]-u2[1:(time-1)])/dt);
    du1p=du1*(du1>0);
    du1n=abs(du1*(du1<0));
    du2p=du2*(du2>0);
    du2n=abs(du2*(du2<0));

    if(eps==TRUE) {
        postscript(
                   name,
                   onefile=FALSE,
                   horizontal=FALSE,
                   width=width,height=height,
                   family="Times");
    }

    layout(seq(1,4,1),4,1)
    par(mar=c(.01,.01,.01,.01))

    plot(
         1e100,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=1,
         xlim=xlim,
         ylim=ylim,
         family="serif")

    polygon(c(1:time,time), c(u1, u1[1]), col='#DDDDDD',border=NA)
    lines(u1,lwd=2);
    polygon(c(1:time,time), c(u2, u2[1]), col='#EEEEEE',border=NA)
    lines(u2,lwd=1);
    #lines(u1,lwd=0.5);
    arrows(4,-.1,start2-start1-4,-.1,code=3,angle=90,length=.02,lwd=.6)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(u(t))),cex=2)
    text(time*(1/16),-.3,expression(paste(Delta,"t")),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(timetime[u1==max(u1)][1],max(u1)+.2,expression(italic(u[1])),cex=2)
    text(timetime[u2==max(u2)][1],max(u2)+.2,expression(italic(u[2])),cex=2)

    plot(
         1e200,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=3,
         xlim=xlim,
         ylim=ylim,
         family="serif")

    polygon(c(1:time,time), c(du1, du1[1]), col='#DDDDDD',border=NA)
    lines(du1,lwd=2);
    polygon(c(1:time,time), c(du2, du2[1]), col='#EEEEEE',border=NA)
    lines(du2,lwd=1);
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(dot(u)(t))),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(timetime[du1==max(du1)]+1000,max(du1),expression(italic(dot(u)[1])),cex=2)
    text(timetime[du2==max(du2)]+1000,max(du2),expression(italic(dot(u)[2])),cex=2)
    taux = ceiling(tau1/dt);
    tau2x = (start2-start1)+ceiling(tau2/dt);

    plot(
         1e200,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=3,
         xlim=xlim,
         ylim=ylim,
         family="serif")

    polygon(c(1:time,time), c(du1p, du1p[1]), col='#DDDDDD',border=NA)
    lines(du1p,lwd=2);
    polygon(c(1:time,time), c(du2p, du2p[1]), col='#EEEEEE',border=NA)
    lines(du2p,lwd=1);
    points(c(taux,tau2x),c(0,0),pch=19)

    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(dot(u)(t))),cex=2)
    text(taux,-.3,expression(italic(tau[1])),cex=2)
    text(tau2x,-.3,expression(italic(tau[2] + paste(Delta,'t'))),adj=c(0.1,.4),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(timetime[du1p==max(du1p)][1]+1400,max(du1p),expression(group("[",italic(dot(u)[1]),"]")^{'+'}),cex=2)
    text(timetime[du2p==max(du2p)][1]+1400,max(du2p),expression(group("[",italic(dot(u)[2]),"]")^{'+'}),cex=2)

    plot(
         1e200,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=3,
         xlim=xlim,
         ylim=ylim,
         family="serif")

    polygon(c(1:time,time), c(du1n, du1n[1]), col='#DDDDDD',border=NA)
    lines(du1n,lwd=2);
    polygon(c(1:time,time), c(du2n, du2n[1]), col='#EEEEEE',border=NA)
    lines(du2n,lwd=1);
    points(c(taux,tau2x),c(0,0),pch=19)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(dot(u)(t))),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(taux,-.3,expression(italic(tau[1])),cex=2)
    text(tau2x,-.3,expression(italic(tau[2] + paste(Delta,'t'))),adj=c(0.1,.4),cex=2)
    text(timetime[du1n==max(du1n)][1][1]-40,max(du1n)+.3,expression(group("[",italic(dot(u)[1]),"]")^{'-'}),cex=2)
    text(timetime[du2n==max(du2n)][1][1],max(du2n)+.3,expression(group("[",italic(dot(u)[2]),"]")^{'-'}),cex=2)

    if(eps==TRUE) {
        graphics.off();
    }

}

hsides<-function(
                 width=4,
                 height=6,
                 ylim=c(-.3,1.5),
                 eps=FALSE,
                 name="hd",
                 dt=.01,
                 time=10/dt,
                 start1=ceiling(time/8),
                 start2=ceiling(time*2/8),
                 co1=1,
                 co2=1)
{

    # init variable s of simulation

    h = matrix(rep(0,time*2),time,2);
    h[start1:length(h[,1]),1]=1;
    h[start2:length(h[,2]),2]=1;

    # define constants for graph limits
    xgap=time/4;
    xlim=c(-xgap*2/3,time+xgap);
    aylim=ylim
    ylimrange= ylim[2]-ylim[1]
    ylim=ylim+c(-ylimrange/20, +ylimrange/5);
    axlim=c(-xgap/2,time);
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))

    # define constants for text positions
    maxlabx=1/4; maxlaby=8/18;
    maxlabx0=-1/12; maxlabx1=-1/12; maxlabx2=-1/12; maxlabx3=-1/12; maxlabx4=-1/12;
    maxlaby0=2/18; maxlaby1=7/18; maxlaby2=10/18; maxlaby3=13/18; maxlaby4=16/18;
    lpx=c(0,1,1,0);  lpy=c(1,1,0,0); bl=.1*time;
    pgap = ylimrange/2; right=.12*time;

    timetime=1:time;

    hd=(h[2:dim(h)[1],]-h[1:(dim(h)[1]-1),]);

    if(eps==TRUE) {
        postscript(
                   paste('onset_',name,'.eps',sep=''),
                   onefile=FALSE,
                   horizontal=FALSE,
                   pointsize=6,
                   width=width,height=height,family="Times");
    }

    par(mar=c(.01,.01,.01,.01))
    plot(
         hd[,2],
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=1,
         col='#ffffff',
         xlim=xlim,
         ylim=ylim,
         family="serif");

    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))

    lines(hd[,1],lwd=2)
    lines(hd[,2],lwd=2)
    hd1=hd[,1]
    hd2=hd[,2]
    text(-xgap*3/6,aylim[2],expression(italic(s(t))),cex=2)

    text(timetime[hd1==max(hd1)][1], max(hd1)+.5*pgap,expression(italic(s[1])),cex=2)
    text(timetime[hd2==max(hd2)][1]+40*pgap, max(hd2)+.5*pgap,expression(italic(s[2])),cex=2)
    text(time+time*0.04,-.2*pgap,expression(italic(t)),cex=2)

    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);

    if(eps==TRUE) {
        graphics.off();
    }
}

componentEvents<-function(
                        width=4, # width of eps figure (inches)
                        height=6, # height of eps figure (inches)
                        ylim=c(-.3,1.5), # range of amplitude shown in the graph
                        eps=FALSE, #  print eps figure intead of screen
                        name="wpp1", # print eps figure intead of screen
                        dt=.01, # integration step
                        time=10/dt, # timesteps of the simulated trial
                        tau1=1, # decay of the pre-synaptic neuron
                        tau2=tau1, # decay of the post-synaptic neuron
                        k=1, # amplification of input
                        start1=ceiling(time/8), # start of the signal to the pre-synaptic neuron
                        start2=ceiling(time*2/8), # start of the signal to the post-synaptic neuron
                        co1=1, # type of the pre-synaptic event (can be
                               # 0:onset,
                               # 1:positive part of derivative of onset,
                               # 2: absolute of negative derivative of onset)
                        co2=1,  # type of the post-synaptic event (can be
                               # 0:onset,
                               # 1:positive part of derivative of onset,
                               # 2: absolute of negative derivative of onset)
                        plot_prod=FALSE
                        ) {

    # init variable s of simulation

    v = matrix(rep(0,time*2),time,2);
    u = matrix(rep(0,time*2),time,2);
    h = matrix(rep(0,time*2),time,2);
    h[start1:length(h[,1]),1]=1;
    h[start2:length(h[,2]),2]=1;

    # define constants for graph limits
    xgap=time/4;
    xlim=c(-xgap*2/3,time+xgap);
    aylim=ylim
    ylimrange= ylim[2]-ylim[1]
    ylim=ylim+c(-ylimrange/20, +ylimrange/20);
    axlim=c(-xgap/2,time);
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))

    # define constants for text positions
    maxlabx=1/4; maxlaby=8/18;
    maxlabx0=-1/12; maxlabx1=-1/12; maxlabx2=-1/12; maxlabx3=-1/12; maxlabx4=-1/12;
    maxlaby0=2/18; maxlaby1=7/18; maxlaby2=10/18; maxlaby3=13/18; maxlaby4=16/18;
    lpx=c(0,1,1,0);  lpy=c(1,1,0,0); bl=.1*time;
    pgap = ylimrange/2; right=.12*time;

    # simulation
    for(t in 2:time) {

        # pre-synaptic onset
        v[t,1] = v[t-1,1] + (dt/tau1)*( -v[t-1,1] +k*h[t,1] );
        u[t,1] = u[t-1,1] + (dt/tau1)*( -u[t-1,1] -v[t-1,1] + k*h[t,1] );

        # post-synaptic onset
        v[t,2] = v[t-1,2] + (dt/tau2)*( -v[t-1,2] +k*h[t,2] );
        u[t,2] = u[t-1,2] + (dt/tau2)*( -u[t-1,2] -v[t-1,2] + k*h[t,2] );

    }

    # standardization of onsets
    u1=u[,1]; u1=u1/max(u1)
    u2=u[,2]; u2=u2/max(u2)

    # derivatives of onsets
    timetime=1:time;
    du1=c(0,(u1[2:time]-u1[1:(time-1)])/dt);du1=du1/max(du1)
    du2=c(0,(u2[2:time]-u2[1:(time-1)])/dt);du2=du2/max(du2)

    # positive and negative parts of derivatives
    du1p=du1*(du1>0);
    du1n=abs(du1*(du1<0));
    du2p=du2*(du2>0);
    du2n=abs(du2*(du2<0));
    dd=t(rbind(du1p,du1n,du2p,du2n));

    # decide if d1 and d2 events will be onsets
    # or positive/negative derivative
    if(co1==0) {
        d1=u1;
        du1=u1;
        d2=dd[,2+co2];
    } else if(co2==0) {
        d2=u2;
        du2=u2;
        d1=dd[,co1];
    } else {
        d2=dd[,2+co2];
        d1=dd[,co1];
    }

    # standardized combination on the two events
    ddd=d1*d2;
    if(max(ddd)!=0) {
        ddd=ddd/max(ddd)
        ddd=ddd*((max(d1)+max(d2))/2)
    }

    # decide if printing the graph on an eps file
    if(eps==TRUE) {
        postscript(
                   paste('onset_',name,'.eps',sep=''),
                   onefile=FALSE,
                   horizontal=FALSE,
                   width=width, height=height,
                   pointsize=6, family="Times");
    }

    #plot first event
    par(mar=c(.01,.01,.01,.01))
    plot(
         d1,
         type='l',
         frame.plot=FALSE,
         axes=FALSE,
         xlab='',
         ylab='',
         lwd=1,
         col='#ffffff',
         xlim=xlim,
         ylim=ylim,
         family="serif");

    #plot composition
    if(plot_prod) {
        polygon(c(1,1:time,time), c(0,ddd, 0), lwd=.01,col='#888888',border=NA)
    }
    #plot first event area
    polygon(c(1,1:time,time), c(0, d1,0), col='#444444',density=20,angle=-45,border=NA)
    #plot second event area
    polygon(c(1,1:time,time), c(0, d2,0), col='#444444',density=20,angle=45,border=NA)

    #plot first event
    lines(d1,lwd=2)
    #plot second event
    lines(d2,lwd=2)
    #plot axes
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    #plot axes'labels
    text(-xgap*3/6,aylim[2],expression(italic(u(t))),cex=2)
    text(time+time*0.04,-.1*pgap,expression(italic(t)),cex=2)

    # compose text to explain envent types in the legend
    if(co2==0) {
        if(co1==1) { first="group('[',dot(u)[1],']')^{'+'}" }
        else if (co1==2) {  first="group('[',dot(u)[1],']')^{'-'}" }
        second="u[2]"
    }else if(co1==0) {
        if(co2==1) { second="group('[',dot(u)[2],']')^{'+'}" }
        else if (co2==2) { second="group('[',dot(u)[2],']')^{'-'}" }
        first="u[1]"
    } else{
        if(co1==1) { first="group('[',dot(u)[1],']')^{'+'}" }
        else if (co1==2) { first="group('[',dot(u)[1],']')^{'-'}" }
        if(co2==1) { second="group('[',dot(u)[2],']')^{'+'}" }
        else if (co2==2) { second="group('[',dot(u)[2],']')^{'-'}" }
    }
    txt_prod = eval(parse(text=paste('expression(',first,'*',second,')')));
    txt_1 = eval(parse(text=paste('expression(',first,')')));
    txt_2 = eval(parse(text=paste('expression(',second,')')));

    #legend
    if(plot_prod) {
        text(time-time*maxlabx0,
             aylim[2]-aylim[2]*maxlaby0,
             txt_prod,cex=7,adj=c(.75,.5));
        if(max(ddd)!=0 )
        {
            polygon(time-time*maxlabx0+right+ceiling(lpx*bl),
                    (lpy*.1*pgap)+(aylim[2]-aylim[2]*maxlaby0-.05*pgap),
                    col='#888888', border=NA);
        }
    }
    else{
        text(time-time*(1/2),
             aylim[2],
             "component:",cex=2,adj=c(.75,.5));

        text(time-time*maxlabx1,
             aylim[2],
             txt_prod,cex=2,adj=c(.75,.5));
    }
    if(co1==1) {first='+'} else if (co1==2) {first='-'}
    text(time - time * maxlabx1, aylim[2] - aylim[2] * maxlaby1, txt_1, cex =
             2)

    polygon(
        time - time * maxlabx1 + right + ceiling(lpx * bl),
        (lpy * .2 * pgap) + (aylim[2] - aylim[2] * maxlaby1 - .05 *
                                 pgap)
        ,
        col = '#444444',
        density = 20,
        angle = -45,
        border = NA
    )

    polygon(
        time - time * maxlabx1 + right + ceiling(lpx * bl),
        (lpy * .2 * pgap) + (aylim[2] - aylim[2] * maxlaby1 - .05 *
                                 pgap)
        ,
        lwd = 2
    )

    if (co2 == 1) {
        first = '+'
    } else if (co2 == 2) {
        first = '-'
    }

    text(time - time * maxlabx2, aylim[2] - aylim[2] * maxlaby2, txt_2, cex =
             2)

    polygon(
        time - time * maxlabx2 + right + ceiling(lpx * bl),
        (lpy * .2 * pgap) + (aylim[2] - aylim[2] * maxlaby2 - .05 *
                                 pgap)
        ,
        col = '#444444',
        density = 20,
        angle = 45,
        border = NA
    )

    polygon(
        time - time * maxlabx2 + right + ceiling(lpx * bl),
        (lpy * .2 * pgap) + (aylim[2] - aylim[2] * maxlaby2 - .05 *
                                 pgap)
        ,
        lwd = 2
    )

    # print the eps file
    if(eps==TRUE) {
        dev.off()
    }

}

allcomponents <-function()  {

    labels1= c('wpp1','wpn1','wnp1','wnn1','wpp2','wpn2','wnp2','wnn2')
    labels2= c('wsp1','wsn1','wps1','wns1','wsp2','wsn2','wps2','wns2')

    tau1=1;
    tau2=1;
    start1=100;
    hh=1;
    l1 = 0; l2 = 0
    lab = 0
    for(start2 in c(50,150)) {
        hsides(eps=TRUE,dt=.01,start1=start1,start2=start2,
               name=paste("hd",hh,sep=''),width=2.5,height=0.5);
        hh=hh+1;
        for(co1 in c(0,1,2)) {
            for(co2 in c(0,1,2)) {
                if ((co1+co2)> 0) {
                    labels=labels1
                    if ( (co1 == 0 || co2 == 0) ) {
                        labels=labels2
                        l2 = l2 + 1
                        lab = l2
                    } else if ( co1 > 0 && co2 > 0 )  {
                        labels=labels1
                        l1 = l1 + 1
                        lab = l1
                    }

                    componentEvents(
                                    co1=co1,
                                    co2=co2,
                                    start1=start1,
                                    start2=start2,
                                    name=labels[lab],
                                    tau1=tau1,
                                    tau2=tau2,
                                    eps=TRUE,
                                    width=2.5,
                                    height=1.375);
                }
            }
        }
    }
}

onset_alpha<-function(
    width=4,
    height=6,
    eps=FALSE,
    dt=.001,
    time=10/dt,
    tau1=1,
    k=1,
    start1=ceiling(time/8)) {

    graphics.off();

    v = rep(0,time);
    u = rep(0,time);
    v = rep(0,time);
    h = rep(0,time);
    h[start1]=1;

    xgap=time/5;
    xlim=c(-xgap,time+xgap)
    ylim=c(-.5,1.5)
    axlim=c(-xgap/2,time)
    aylim=c(-.3,1.3)

    # simulation
    for(t in 2:time) {

        # pre-synaptic onset
        v[t] = v[t-1] + (dt/tau1)*( -v[t-1] +k*h[t] );
        u[t] = u[t-1] + (dt/tau1)*( -u[t-1] +v[t-1] );

    }
    if(eps==TRUE) {
        postscript(
            'onset.eps',
            onefile=FALSE,
            horizontal=FALSE,
            width=width,height=height,
            family="times");
    }

    layout(seq(1,3,1),3,1)
    par(mar=c(.01,.01,.01,.01))

    plot(
        h,
        type='l',
        frame.plot=FALSE,
        axes=FALSE,
        xlab='',
        ylab='',
        lwd=3,
        xlim=xlim,
        ylim=ylim,
        family="serif")

    polygon(c(1:time,time), c(h, h[1]), col='#DDDDDD',border=NA)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(h(t))),cex=2)
    text(start1,-.3,expression(italic(t[i])),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)
    text(time,-.3,expression(italic(t)),cex=2)

    ylim=c(-.0005,0.0015)
    aylim=c(-.0003,0.0013)
    plot(
        v,
        type='l',
        frame.plot=FALSE,
        axes=FALSE,
        xlab='',
        ylab='',
        lwd=3,
        xlim=xlim,
        ylim=ylim)

    polygon(c(1:time,time), c(v, v[1]), col='#DDDDDD',border=NA)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(v(t))),cex=2)
    text(start1,aylim[1],expression(italic(t[i])),cex=2)
    text(time,aylim[1],expression(italic(t)),cex=2)

    plot(
        u,
        type='l',
        frame.plot=FALSE,
        axes=FALSE,
        xlab='',
        ylab='',
        lwd=3,
        xlim=xlim,
        ylim=ylim)

    polygon(c(1:time,time), c(u, u[1]), col='#DDDDDD',border=NA)
    d<-c()
    d<-rbind(d,c(rbind(axlim,aylim*0)))
    d<-rbind(d,c(rbind(axlim*0,aylim)))
    arrows(d[,1],d[,2],d[,3],d[,4],lwd=1,length=.08);
    text(-xgap*2/3,aylim[2],expression(italic(u(t))),cex=2)
    text(start1,aylim[1],expression(italic(t[i])),cex=2)
    text(time,aylim[1],expression(italic(t)),cex=2)
    text(start1+ceiling(tau1/dt),aylim[1],expression(italic(tau+t[i])),cex=2,adj=c(.2,.5))
    arrows(start1+ceiling(tau1/dt),0,start1+ceiling(tau1/dt),u[start1+ceiling(tau1/dt),1],lwd=1,length=0,lty=3);

    if(eps==TRUE) {
        graphics.off();
    }

    v
}

case_study <- function() {
    ##### case study#
    x11()
    componentEvents(
        co1 = 1,
        co2 = 0,
        start1 = 20,    start2 = 16,
        dt = 0.001,
        time = 80,
        tau1 = 0.029999733,
        tau2 = 0.006626032
    )
    axis(
        1,
        outer = FALSE,
        lwd = 0,
        lwd.ticks = .2,
        pos = -.3,
        cex.axis = 1.5,
        at = c(0, 40, 80, 120, 160, 200),
        labels = format(c(0, 40, 80, 120, 160, 200))
    )

    x11()
    componentEvents(
        co1 = 1,
        co2 = 1,
        start1 = 20,
        start2 = 20,
        dt = 0.001,
        time = 80,
        tau1 = 0.029999733,
        tau2 = 0.006626032
    )
    axis(
        1,
        outer = FALSE,
        lwd = 0,        lwd.ticks = .2,
        pos = -.3,
        cex.axis = 1.5,
        at = c(0, 40, 80, 120, 160, 200),
        labels = format(c(0, 40, 80, 120, 160, 200))
    )
}


#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Neville Subproject: Using Random Forestes, Factor Analysis, and Logistic regression to Screen Variables for Imapcts on Public Health
## National Health and Nutrition Examination Survey: The R Project for Statistical Computing Script by DrewC!
# Detecting Prediabetes in those under 65

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

## Import Data
setwd("C:/Users/drewc/GitHub/Data_Club") # Set wd to project repository
df_check = read.csv("_data/health_check_stage.csv") # Import dataset from _data folder

## Verify
dim(df_check)

model_linear <- lm(MSPB~ Case_Mix_Index + Mean_Physician_Income + Percent_For_Profit, data = df_check)
summary(model_linear)

model_linear <- lm(MSPB~ Mean_Physician_Income + Percent_For_Profit, data = df_check)
summary(model_linear)


logmin <- function(x, xmin = 0.00001) {
    x[x < xmin] = xmin
    return(log(x))
}


#' Bass Model
#'
#' Fits the Bass Diffusion model. In particular, fits an observed curve of
#' proportions of adopters to \eqn{F(t)}, the proportion of adopters at time
#' \eqn{t}, finding the corresponding coeficients \eqn{p}, Innovation rate,
#' and \eqn{q}, imitation rate.
#'
#' @param Time Integer vector with values greater than 0. The \eqn{t} parameter.
#' @param p Numeric scalar. Coefficient of innovation.
#' @param q Numeric scalar. Coefficient of imitation.
#' @param dat Either a diffnet object, or a numeric vector.
#' Observed cumulative proportion of adopters.
#' @param x An object of class \code{diffnet_bass}.
#' @param ... Further arguments passed to the method.
#'
#' @details The function fits the bass model with parameters \eqn{[p, q]} for
#' values \eqn{t = 1, 2, \dots, T}, in particular, it fits the following function:
#'
#' \deqn{
#'   F(t) = \frac{1 - \exp{-(p+q)t}}{1 + \frac{q}{p}\exp{-(p+q)t}}
#' }{
#'   F(t) = [1 - exp(-(p + q)*t)]/[1 + exp(-(p + q)*t)*(q/p)]
#' }
#'
#' Which is implemented in the \code{bass_F} function. The proportion of adopters
#' at time \eqn{t}, \eqn{f(t)} is:
#'
#' \deqn{
#'   f(t) = \left\{\begin{array}{ll}
#'   F(t), & t = 1 \\
#'   F(t) - F(t-1), & t > 1
#'   \end{array}\right.
#' }{
#'   f(t) = ifelse(t == 1, F(t), F(t) - F(t-1))
#' }
#'
#' and it's implemented in the \code{bass_f} function.
#'
#' For testing purposes only, the gradient of \eqn{F} with respect to \eqn{p}
#' and \eqn{q} is implemented in \code{bass_dF}.
#'
#' The estimation is done using \code{\link[stats:nls]{nls}}.
#'
#'
#' @return An object of class \code{nls} and \code{diffnet_bass}. For more
#' details, see \code{\link[stats:nls]{nls}} in the \pkg{stats} package.
#'
#' @examples
#' # Fitting the model for the Brazilian Farmers Data --------------------------
#' data(brfarmersDiffNet)
#' ans <- fitbass(brfarmersDiffNet)
#'
#' # All the methods that work for the -nls- object work here
#' ans
#' summary(ans)
#' coef(ans)
#' vcov(ans)
#'
#' # And the plot method returns both, fitted and observed curve
#' plot(ans)
#'
#' @references
#' Bass's Basement Institute Institute. The Bass Model. (2010).
#' Available at: \url{http://www.bassbasement.org/BassModel/Default.aspx}. (Accessed: 29th March 2017)
#' @name bass
#' @author George G. Vega Yon
#' @family statistics
NULL

#' @rdname bass
#' @export
fitbass <- function(dat, ...) UseMethod("fitbass")

#' @export
#' @rdname bass
fitbass.diffnet <- function(dat, ...) {
  .fitbass(cumulative_adopt_count(dat$cumadopt)["prop",], ...)
}

#' @export
#' @rdname bass
fitbass.default <- function(dat, ...) {
  .fitbass(as.vector(dat), ...)
}

.fitbass <- function(dat, ...) {

  # Constants
  Time <- seq_along(dat)

  # # Optimization (Fit nonlinear regression)
  ans <- stats::nls(dat ~ bass_F(Time, p, q), start=list(p = dat[1], q = .5 ),...)

  structure(c(
    ans,
    list(
      q      = stats::coef(ans)[2],
      p      = stats::coef(ans)[1],
      Fvals  = bass_F(Time, stats::coef(ans)[1], stats::coef(ans)[2]),
      fvals  = bass_f(Time, stats::coef(ans)[1], stats::coef(ans)[2]),
      nper   = length(Time),
      dat    = dat,
      Time   = Time
    )
  ), class = c("diffnet_bass", class(ans)))

}

#' @rdname bass
#' @param y Integer vector. Time (label).
#' @param pch Passed to \code{\link[graphics:plot]{matplot}}.
#' @param main Passed to \code{\link[graphics:plot]{matplot}}.
#' @param xlab Character scalar. Label of the \code{x} axis.
#' @param ylab Character scalar. Label of the \code{y} axis.
#' @param type Passed to \code{\link[graphics:plot]{matplot}}.
#' @param lty Passed to \code{\link[graphics:plot]{matplot}}.
#' @param col Passed to \code{\link[graphics:plot]{matplot}}.
#' @param bg Passed to \code{\link[graphics:plot]{matplot}}.
#' @param include.legend Logical scalar. When \code{TRUE}, draws a legend.
#' @param add Passed to \code{\link[graphics:plot]{matplot}}.
#' @export
plot.diffnet_bass <- function(
  x, y=1:length(x$m$lhs()), add=FALSE,
  pch  = c(21,24),
  main = "Bass Diffusion Model",
  ylab = "Proportion of adopters",
  xlab = "Time",
  type = c("b", "b"),
  lty  = c(2,1),
  col  = c("black","black"),
  bg   = c("lightblue","gray"),
  include.legend = TRUE,
  ...) {

  if (length(type) == 1) type <- rep(type,2)
  if (length(pch) == 1)  pch  <- rep(pch,2)
  if (length(lty) == 1)  lty  <- rep(lty,2)
  if (length(col) == 1)  lty  <- rep(col,2)
  if (length(bg) == 1)   bg   <- rep(bg,2)

  mat <- with(x, cbind(m$lhs(), m$fitted()))

  matplot(mat, xlab = xlab, ylab = ylab, main=main,
          ylim = c(0,1), type=type, lty=lty, bg=bg, col=col,
          pch=pch, add=add, ...)

  # Adding legend
  if (!add && include.legend)
    legend(
      "topleft", bty="n",
      legend = c("Observed Cumulative Adopters", "Predicted Cumulative Adopters"),
      col=col, pt.bg=bg, pch=pch
      )

  invisible(x)

}

#' @rdname bass
#' @export
bass_F <- function(Time, p, q) {
  (1 - exp(-(p + q)*Time))/(1 + (q/p)*exp(-(p+q)*Time))
}

#' @rdname bass
#' @export
bass_dF <- function(p, q, Time) {
  expv <- exp((p+q)*Time)

  rbind(
    expv * p^2*Time + q*(expv*(1 + p*Time) - 1)/
      (expv*p + q)^2,
    p * (1 + expv*(p*Time + q*Time - 1)) /
      (expv*p + q)^2
  )
}

#' @rdname bass
#' @export
bass_f <- function(Time, p, q) {
  ifelse(Time==1, bass_F(Time, p, q), bass_F(Time, p, q) - bass_F(Time-1, p, q))
}


library(shiny)
library(shinyWidgets)
library(ggplot2)
library(shinydashboard)
housing <- read.csv("House_Price_data.csv")
year_2006 <- as.data.frame(housing[which(housing$YrSold==2006),])
year_2007 <- as.data.frame(housing[which(housing$YrSold==2007),])
year_2008 <- as.data.frame(housing[which(housing$YrSold==2008),])
year_2009 <- as.data.frame(housing[which(housing$YrSold==2009),])
year_2010 <- as.data.frame(housing[which(housing$YrSold==2010),])
ui <- dashboardPage(
  dashboardHeader(title = "Housing Data Analysis", titleWidth = 250),
  dashboardSidebar(
    sidebarMenu(
      selectInput(
        inputId = "sale",
        label = "Year Sold",
        c("2006", "2007", "2008", "2009", "2010")
      ),
      selectInput(
        inputId = "var_1",
        label = "Housing Data per Year",
        choices = colnames(housing[,-c(1,78)]), selected = "MSZoning"),

      radioButtons(
        inputId = "color",
        label = "Color Of Plot",
        list("Dark Grey", "Black", "Steel Blue")),

      sliderInput(
        inputId = "bin",
        label = "Y limit", min = 0,
        max = 1000000,
        value = 15,
        step = 5),

      sliderInput(
        inputId = "bin_x",
        label = "X limit", min = 1,
        max = 1000,
        value = c(1,2),
        step = 1)

    )
  ),
  dashboardBody(

    fluidRow(
      box(title = "Housing Sales Price", width = 12, valueBoxOutput("approvalBox", width = 6))
    ),
    fluidRow(
      box(title = "Plot", width = 12, plotOutput("plot"))
    )
  )
)

server <- function(input, output) {
  output$approvalBox <- renderValueBox({
    colm <- input$var_1
    k <- eval(as.name(paste("year",input$sale, sep = "_")))
    c <- sum(k$SalePrice)
    c <- paste('$',formatC(c, big.mark=',', format = 'f'))
    c <- unlist(strsplit(c, split='.', fixed=TRUE))[1]
    valueBox(c, paste("Sale value in Year",input$sale), icon = icon("dollar"),
             color = "yellow", width = 120
    )
  })

  output$plot <- renderPlot({
    colm <- input$var_1
    k <- eval(as.name(paste("year",input$sale, sep = "_")))
    c <- table(k[,colm])
    c <- as.data.frame(c)
    ggplot(c, aes(x = Var1, y = Freq)) +
      geom_bar(fill = input$color, color = "grey30", width = 1, stat = "identity") +
      xlab(input$var_1) +
      ylab("Count") +
      ylim(c(0, max(input$bin))) +
      coord_cartesian(xlim = c(min(input$bin_x), max(input$bin_x))) +
      geom_text(aes(x = Var1, y = Freq, label = Freq), vjust=-1) +
      ggtitle("Housing Data",
              subtitle = input$var_1)

  })
}

shinyApp(ui, server)


data1<-read.csv("/Users/gdesvignes/Documents/papers/gregory/GC_Magnetar/data/RM_2.5_3.2GHz.txt", sep=" ",header = FALSE, skip=1, comment.char = "#",col.names=c("MJD","Frequency", "RM","Error","ttt","min2","max2"))
data2<-read.csv("/Users/gdesvignes/Documents/papers/gregory/GC_Magnetar/data/RM_4.8GHz.txt", sep=" ",header = FALSE, skip=1, comment.char = "#",col.names=c("MJD","Frequency", "RM","Error","ttt","min2","max2"))

data<-rbind(data1,data2)

sat <- subset(data, select = c("MJD", "RM"))
error <-c(subset(data,select=c("Error")))
weights = 1/unlist(error)

sat2<-sat[28:40,]
weights2<-weights[28:40]

sat2<-tail(sat,14)
weights2<-tail(weights,14)

fit<-lm(RM~MJD, data=sat2, weights=weights2)
plot(sat, pch=19)
#arrows(data['MJD'], data['RM']-data['Error'], data['MJD'], data['RM']+data['Error'], length=0.05, angle=90, code=3)
arrows(unlist(data['MJD']), unlist(data['RM']-data['Error']), unlist(data['MJD']), unlist(data['RM']+data['Error']), length=0.05, angle=90, code=3)

abline(fit)
fit


library(nloptr)
library(rlist)
library(Rlab)
library(RJSONIO)

source("likelihood_incubation/model_fitting.r")
# load data and initialize parameters
load("CasosAjustados_Diagnostico.Rda")
params = list(
  "lambda" = 2 ^ 20,
  "beta_min" = 0.1,
  "beta_max" = 0.7,
  "gamma_min" = 1 / 3,
  "gamma_max" = 1,
  "tau_min" = 1 / 40,
  "tau_max" = 1 / 4,
  "N0_min" = 0,
  "N0_max" = 5,
  "A0_min" = 0,
  "A0_max" = 5,
  "t0" = 1
)

observed_I = data$`Estimados Totales`
observed_I = c(observed_I[1], 0, tail(observed_I, -1))
observed_I = observed_I[params$t0:length(observed_I)]

for (i in 1:1000) {
  params$beta0 = runif(length(observed_I), params$beta_min, params$beta_max)
  params$gamma0 = runif(1, params$gamma_min, params$gamma_max)
  params$tau0 = runif(1, params$tau_min, params$tau_max)
  params$N00 = runif(1, params$N0_min, params$N0_max)
  params$A00 = runif(1, params$A0_min, params$A0_max)
  params$observed_I = observed_I
  # fit Nicolas's model
  model = fit(observed_I, beta0=params$beta0, beta_min=params$beta_min,
              beta_max=params$beta_max, gamma0=params$gamma0,
              gamma_min=params$gamma_min, gamma_max=params$gamma_max,
              tau0=params$tau0, tau_min=params$tau_min, tau_max=params$tau_max,
              N00=params$N00, N0_min=params$N0_min, N0_max=params$N0_max,
              A00=params$A00, A0_min=params$A0_min, A0_max=params$A0_max,
              lambda=params$lambda, ignore_beta_diff=26)
  # save fitted model and parameters
  timestamp = format(Sys.time(), "%Y%m%d%H%M")
  out_dir = paste("likelihood_incubation", "tuned", timestamp, sep="/")
  dir.create(out_dir, recursive=TRUE)
  write(toJSON(params), paste(out_dir, "params.json", sep="/"))
  write(toJSON(model), paste(out_dir, "model.json", sep="/"))
  # plot reproduction number series
  R = model$beta / model$tau
  png(paste(out_dir, "R(t).png", sep="/"))
  plot(R, xlab="t", ylab="R(t)", type="l")
  dev.off()
  # plot expected new cases with confidence intervals
  expected_I = get_expected(model$beta, model$gamma, model$tau, model$N0,
                            model$A0)$I
  png(paste(out_dir, "I(t).png", sep="/"))
  plot(1:length(expected_I), expected_I, type="l")
  lines(1:length(observed_I), observed_I, col="red")
  dev.off()
}


library(lme4)
library(tidyverse)
library(ordinal)
library(texreg)
library(gridExtra)

load('data/cleanedDataWithLags.RData')

dat <- dat%>%
  group_by(StudyId)%>%
  mutate_at(vars(BirthYear,ends_with('_R'),Site,age),~if(any(!is.na(.))) na.omit(.)[1] else NA)%>%
  mutate(cd4_100=cd4/100,cd4_100_lag=cd4_lag/100,
    depDist=(Date-dep_total_lastObs)/1000,
    adDist=(Date-adhere_lastObs)/1000,
    cd4Dist=(Date-cd4_lastObs)/1000,
    qolDist=(Date-qol1_5_total_lastObs)/1000,
    Race_R=as.factor(Race_R),
    logDepLag=log(dep_total_lag+1)
  )%>%
  ungroup()

dat <- droplevels(dat)

##################################################
### adherence vs depression
##################################################

###### models
AdDep00 <- lmer(adhere~logDepLag+(1|StudyId),data=dat)
AdDep0 <- lmer(adhere~logDepLag+as.factor(adhere_lag)+(1|StudyId),data=dat)
AdDep <- lmer(adhere~logDepLag+depDist+adDist+as.factor(adhere_lag)+(adDist+depDist|StudyId),data=dat)
AdDep2 <- update(AdDep,.~.+age+Site+PresentSex_R+Hispanic_R+Race_R)
AdDep3 <- update(AdDep0,subset=adDist>=depDist)

save(AdDep00,AdDep0,AdDep,AdDep2,AdDep3,file='fittedModels/AdDepModels.RData')
htmlreg(list(AdDep00,AdDep0,AdDep,AdDep2,AdDep3),file='coefTables/adhereVsDepression.html')

###### plots

dat%>%group_by(dep_total_lag)%>%summarize(n=n(),avg.adhere=mean(adhere,na.rm=TRUE))%>%
  ggplot(aes(log(dep_total_lag+1),avg.adhere,size=n))+geom_point(show.legend=FALSE)+
  geom_smooth(method='lm',show.legend=FALSE)+scale_size(range=c(.5,20))+ylim(1,5)+
  xlab('log(Depression+1) (lagged)')+ylab('Avg. Adherence')
ggsave('plots/adhereVsDepression.jpg')

nd <- within(dat,{depDist=0;adhere_lag=3;adDist=0})[rownames(model.frame(AdDep)),]
ppp <- predict(AdDep,nd)
nd%>%
  mutate(adhere=ppp+resid(AdDep))%>%
  group_by(dep_total_lag)%>%summarize(n=n(),avg.adhere=mean(adhere,na.rm=TRUE))%>%
  ggplot(aes(log(dep_total_lag+1),avg.adhere,size=n))+geom_point(show.legend=FALSE)+
  geom_smooth(method='lm',show.legend=FALSE)+scale_size(range=c(.5,5))+ylim(1,5)+
  xlab('log(Depression+1) (lagged)')+ylab('Avg. Adherence (Adjusted)')
ggsave('plots/adhereVsDepressionAdj.jpg')

##################################################
### cd4 vs adherence & depression
##################################################

##### Models
cd4AdDep00 <- lmer(cd4~logDepLag+adhere_lag+(1|StudyId),data=dat)
cd4AdDep0 <- lmer(cd4~logDepLag+adhere_lag+cd4_lag+(1|StudyId),data=dat)
cd4AdDep <- lmer(cd4~logDepLag+depDist+adhere_lag+adDist+cd4_lag+cd4Dist+(depDist+adDist+cd4Dist|StudyId),data=dat)
cd4AdDep2 <- update(cd4AdDep,.~.+age+Site+PresentSex_R+Hispanic_R+Race_R)
cd4AdDep3 <- update(cd4AdDep0,subset=cd4Dist>=adDist&cd4Dist>=depDist)

save(list=grep('cd4AdDep',ls(),value=TRUE),file='fittedModels/cd4AdDepModels.RData')
htmlreg(list(cd4AdDep00,cd4AdDep0,cd4AdDep,cd4AdDep2,cd4AdDep3),file='coefTables/cd4VsadhereAndDepression.html')

##### Plots
dat%>%
  select(cd4,'vs. Adherence (lagged)'=adhere_lag,'vs. Depression (lagged)'=dep_total_lag)%>%
  gather("iv","value",-cd4)%>%
  mutate(bpVal=as.factor(value))%>%
  ggplot(aes(bpVal,cd4))+
  geom_boxplot()+
  geom_smooth(aes(value,cd4),method='lm')+
  facet_wrap(~iv,scale="free_x")+
  labs(x=NULL,y='CD4 Count')+
  scale_x_discrete(na.translate=FALSE)
ggsave('plots/cd4VsadhereAndDepression.jpg')

nd1 <- within(dat,{logDepLag=1.06;depDist=0;adhereDist=0;cd4_lag=531;cd4Dist=0})[rownames(model.frame(cd4AdDep)),]
ppp1 <- predict(cd4AdDep,nd1)
nd2 <- within(dat,{adhere_lag=mean(model.frame(cd4AdDep)$adhere_lag);depDist=0;adhereDist=0;cd4_lag=531;cd4Dist=0})[rownames(model.frame(cd4AdDep)),]
ppp2 <- predict(cd4AdDep,nd2)

dat[rownames(model.frame(cd4AdDep)),]%>%
  select(cd4,'vs. Adherence (lagged)'=adhere_lag,'vs. Depression (lagged)'=dep_total_lag)%>%
  gather("iv","value",-cd4)%>%
  mutate(bpVal=as.factor(value),cd4=ifelse(iv=='vs. Adherence (lagged)',ppp1,ppp2)+resid(cd4AdDep))%>%
  ggplot(aes(bpVal,cd4))+
  geom_boxplot()+
  geom_smooth(aes(value,cd4),method='lm')+
  facet_wrap(~iv,scale="free_x")+
  labs(x=NULL,y='CD4 Count (Adjusted)')+
  scale_x_discrete(na.translate=FALSE)
ggsave('plots/cd4VsadhereAndDepressionAdj.jpg')

##################################################
### qol vs cd4 & adherence & depression
##################################################

##### Models

qolAdDepCd400 <- clmm(factor(qol1_5_total,ordered=TRUE)~log(dep_total_lag+1)+adhere_lag+cd4_100_lag+(1|StudyId),data=dat)
qolAdDepCd40 <- clmm(factor(qol1_5_total,ordered=TRUE)~log(dep_total_lag+1)+adhere_lag+cd4_100_lag+as.factor(qol1_5_total_lag)+(1|StudyId),data=dat)
qolAdDepCd4 <- clmm(factor(qol1_5_total,ordered=TRUE)~log(dep_total_lag+1)+depDist+adhere_lag+adDist+cd4_100_lag+cd4Dist+as.factor(qol1_5_total_lag)+qolDist+(depDist+adDist+cd4Dist+qolDist|StudyId),data=dat)
qolAdDepCd4quad <- clmm(factor(qol1_5_total,ordered=TRUE)~poly(log(dep_total_lag+1),2)+depDist+poly(adhere_lag,2)+adDist+poly(cd4_100_lag,2)+cd4Dist+as.factor(qol1_5_total_lag)+qolDist+(depDist+adDist+cd4Dist+qolDist|StudyId),data=dat[rownames(model.frame(qolAdDepCd4)),])

qolAdDepCd42 <- update(qolAdDepCd4,.~.+age+Site+PresentSex_R+Hispanic_R+Race_R)
qolAdDepCd43 <- update(qolAdDepCd40,subset=qolDist>=adDist&qolDist>=depDist&qolDist>=cd4Dist)

save(list=grep('qolAdDepCd4',ls(),value=TRUE),file='fittedModels/qolAdDepCd4Models.RData')
htmlreg(list(qolAdDepCd400,qolAdDepCd40,qolAdDepCd4,qolAdDepCd4quad,qolAdDepCd42,qolAdDepCd43),file='coefTables/qolVscd4AndadhereAndDepression.html')

dat%>%
  mutate(
    cd4LagCat=round(as.numeric(as.character(cut(dat$cd4_lag,quantile(dat$cd4_lag,seq(0,1,.05),na.rm=TRUE),labels=quantile(dat$cd4_lag,seq(0.05,1,.05)-.025,na.rm=TRUE)))),-1)
  )%>%
  filter(!is.na(dep_total_lag),!is.na(cd4_lag),!is.na(adhere_lag))%>%
  select(qol1_5_total,'vs. Adherence (lagged)'=adhere_lag,'vs. Depression (lagged)'=dep_total_lag,'vs CD4 Count (lagged)'=cd4LagCat)%>%
  gather("predictor","value",-qol1_5_total)%>%
  group_by(predictor,value)%>%
  summarize(n=n(),avg.qol=mean(qol1_5_total,na.rm=TRUE))%>%
  ungroup()%>%
  ggplot(aes(value,avg.qol))+
  geom_point(aes(size=n),show.legend=FALSE)+
  geom_smooth(method='lm',formula=y~poly(x,2))+
  facet_wrap(~predictor,scales="free_x")+
  labs(x=NULL,y='Avg. QOL')+
ggsave('plots/qolByDepCd4Adhere.jpg')

simpQolMod <- lmer(qol1_5_total~poly(logDepLag,2)+poly(adhere_lag,2)+poly(cd4_100_lag,2)+qol1_5_total_lag+(1|StudyId),data=dat[rownames(model.frame(qolAdDepCd40)),])
ndAd <- within(dat[rownames(model.frame(qolAdDepCd40)),],{logDepLag=1.06;cd4_100_lag=5.31;qol1_5_total_lag=13})#[rownames(model.frame(simpQolMod)),]
pppAd <- predict(simpQolMod,ndAd)
ndDep <- within(dat[rownames(model.frame(qolAdDepCd40)),],{adhere_lag=mean(model.frame(cd4AdDep)$adhere_lag);cd4_100_lag=5.31;qol1_5_total_lag=13})#[rownames(model.frame(simpQolMod)),]
pppDep <- predict(simpQolMod,ndDep)
ndCd4 <- within(dat[rownames(model.frame(qolAdDepCd40)),],{adhere_lag=mean(model.frame(cd4AdDep)$adhere_lag);logDepLag=1.06;qol1_5_total_lag=13})#[rownames(model.frame(simpQolMod)),]
pppCd4 <- predict(simpQolMod,ndCd4)

dat[rownames(model.frame(qolAdDepCd40)),]%>%
  mutate(
    cd4LagCat=round(as.numeric(as.character(cut(cd4_lag,quantile(cd4_lag,seq(0,1,.05),na.rm=TRUE),labels=quantile(cd4_lag,seq(0.05,1,.05)-.025,na.rm=TRUE)))),-1)
  )%>%
  select(qol1_5_total,'vs. Adherence (lagged)'=adhere_lag,'vs. Depression (lagged)'=dep_total_lag,'vs CD4 Count (lagged)'=cd4LagCat)%>%
  gather("predictor","value",-qol1_5_total)%>%
  mutate(qol=ifelse(predictor=='vs. Adherence (lagged)',pppAd,ifelse(predictor=='vs. Depression (lagged)',pppDep,pppCd4))+resid(simpQolMod))%>%
  group_by(predictor,value)%>%
  summarize(n=n(),avg.qol=mean(qol,na.rm=TRUE))%>%
  ungroup()%>%
  ggplot(aes(value,avg.qol))+
  geom_point(aes(size=n),show.legend=FALSE)+
  geom_smooth(method='lm',formula=y~poly(x,2))+
  facet_wrap(~predictor,scales="free_x")+
  labs(x=NULL,y='Avg. QOL (adjusted)')+
ggsave('plots/qolByDepCd4AdhereAdj.jpg')

dat2 <- dat%>%mutate(logDepLag=logDepLag-mean(logDepLag,na.rm=TRUE),
  adhere_lag=adhere_lag-mean(adhere_lag,na.rm=TRUE),
  cd4_100_lag=cd4_100_lag-mean(cd4_100_lag,na.rm=TRUE))

qolAdDepCd400l <- lmer(qol1_5_total~logDepLag+adhere_lag+cd4_100_lag+(1|StudyId),data=dat2)
qolAdDepCd40l <- lmer(qol1_5_total~logDepLag+adhere_lag+cd4_100_lag+as.factor(qol1_5_total_lag)+(1|StudyId),data=dat2)
qolAdDepCd4l <- lmer(qol1_5_total~logDepLag+depDist+adhere_lag+adDist+cd4_100_lag+cd4Dist+as.factor(qol1_5_total_lag)+qolDist+(cd4Dist+adDist|StudyId),data=dat2)
qolAdDepCd4quadl <- update(qolAdDepCd4l,.~.+I(logDepLag^2)+I(adhere_lag^2)+I(cd4_100_lag^2))

qolAdDepCd42l <- update(qolAdDepCd4l,.~.+age+Site+PresentSex_R+Hispanic_R+Race_R)
qolAdDepCd43l <- update(qolAdDepCd40l,subset=qolDist>=adDist&qolDist>=depDist&qolDist>=cd4Dist)

htmlreg(list(qolAdDepCd400l,qolAdDepCd40l,qolAdDepCd4l,qolAdDepCd4quadl,qolAdDepCd42l,qolAdDepCd43l),file='coefTables/qolVscd4AndadhereAndDepressionLmer.html')


library("RColorBrewer")
require("ggplot2")

setwd("C:/Code/climData/glaser2019")
spi <- read.csv("csv/spi_1500_2019.csv", sep=",", na = "NA")

precColors = c("#AA6010", "#FCF0C2","#23AB30")

mp <- ggplot(spi, aes())
mp +

  geom_raster(aes(year,12), fill=spi$spi12)+
  geom_raster(aes(year,11), fill=spi$spi11)+
  geom_raster(aes(year,10), fill=spi$spi10)+
  geom_raster(aes(year, 9), fill=spi$spi9)+
  geom_raster(aes(year, 8), fill=spi$spi8)+
  geom_raster(aes(year, 7), fill=spi$spi7)+
  geom_raster(aes(year, 6), fill=spi$spi6)+
  geom_raster(aes(year, 5), fill=spi$spi5)+
  geom_raster(aes(year, 4), fill=spi$spi4)+
  geom_raster(aes(year, 3), fill=spi$spi3)+
  geom_raster(aes(year, 2), fill=spi$spi2)+
  geom_raster(aes(year, 1), fill=spi$spi1)+

  #theme_classic() +
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(12,11,10,9,8,7,6,5,4,3,2,1), lab=c("SPI12","SPI11","SPI10","SPI9","SPI8","SPI7","SPI6","SPI5","SPI4","SPI3","SPI2","SPI1"))+
  scale_x_continuous(limits=c(1500,2020)) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="SPI", reverse = TRUE)) +
  scale_fill_gradientn(colors=precColors)
#+
#geom_line(aes(y=10+0.5*pt1$hhim, x=pt1$time))

mp <- ggplot(spi, aes())
mp +
  geom_raster(aes(year,12, fill=spi$spi12))+
  geom_raster(aes(year,11, fill=spi$spi11))+
  geom_raster(aes(year,10, fill=spi$spi10))+
  geom_raster(aes(year, 9, fill=spi$spi9))+
  geom_raster(aes(year, 8, fill=spi$spi8))+
  geom_raster(aes(year, 7, fill=spi$spi7))+
  geom_raster(aes(year, 6, fill=spi$spi6))+
  geom_raster(aes(year, 5, fill=spi$spi5))+
  geom_raster(aes(year, 4, fill=spi$spi4))+
  geom_raster(aes(year, 3, fill=spi$spi3))+
  geom_raster(aes(year, 2, fill=spi$spi2))+
  geom_raster(aes(year, 1, fill=spi$spi1))+
  #theme_classic() +
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(12,11,10,9,8,7,6,5,4,3,2,1), lab=c("SPI12","SPI11","SPI10","SPI9","SPI8","SPI7","SPI6","SPI5","SPI4","SPI3","SPI2","SPI1"))+
  scale_x_continuous(limits=c(1500,2020)) +
  #scale_fill_gradient2(low="#AA6010", mid="#FCF0C2", high="#23AB30") +
  scale_fill_gradientn(colors=precColors) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="SPI", reverse = TRUE))


# Shiny server function

shiny::shinyServer(function(input, output) {

  output$rtsplot3 <- shiny::renderPlot( {

    N <- input$N
    k <- input$k
    q <- input$q
    sg1 <- input$sg1
    sigmaG2 <- input$sigmaG2
    sigmaGL2 <- input$sigmaGL2
    sigmaGY2 <- input$sigmaGY2
    sigmaGLY2 <- input$sigmaGLY2
    sigmaE2 <- input$sigmaE2

    r <- seq(1, floor(N / sg1 / k / q), 1)
    g <- floor(N / k / q / r)
    alpha <- sg1 / g
    z <- dnorm(qnorm(1 - alpha))
    i <- z / alpha
    rho <- sqrt(sigmaG2 / (sigmaG2 + sigmaGL2 / k + sigmaGY2 / q + sigmaGLY2 / k / q + sigmaE2 / k / q / r))
    R <- i * rho

    # Draw the plot
    plot(r, R, xlab = "Number of replications", ylab = "Response to selection", type = "b")
    points(r[match(max(R), R)], max(R), col = "red", pch = 18)
    mtext(paste("Optimum number of replications = ", r[match(max(R), R)]), line = 2.9)
    mtext(paste("Number of genotypes at optimum = ", g[match(max(R), R)]), line = 1.7)
    mtext(paste("Response to selection at optimum = ", round(max(R), 2)), line = 0.5)
  })

})


F04BAJ Example Program Results

 Solution
             1          2
 1      1.0000     3.0000
 2     -1.0000     2.0000
 3      3.0000     4.0000
 4     -5.0000     1.0000

Estimate of condition number
1.5e+02

Esttimate of error bound for computed solutions
1.7e-14


context("icombinations iterator")

test_that("icombinations matches the output from utils::combn", {
  combn_out <- utils::combn(x=5, m=2, simplify=FALSE)
  it <- icombinations(seq_len(5), 2)

  expect_equal(as.list(it), combn_out)
})

test_that("icombinations matches the output from another utils::combn call", {
  combn_out <- utils::combn(x=3, m=3, simplify=FALSE)
  it <- icombinations(seq_len(3), 3)

  expect_equal(as.list(it), combn_out)
})

test_that("icombinations with replacement works correctly", {
  it <- icombinations(1:4, m=2, replacement=TRUE)

  expect_equal(iterators::nextElem(it), c(1, 1))
  expect_equal(iterators::nextElem(it), c(1, 2))
  expect_equal(iterators::nextElem(it), c(1, 3))
  expect_equal(iterators::nextElem(it), c(1, 4))
  expect_equal(iterators::nextElem(it), c(2, 2))
  expect_equal(iterators::nextElem(it), c(2, 3))
  expect_equal(iterators::nextElem(it), c(2, 4))
  expect_equal(iterators::nextElem(it), c(3, 3))
  expect_equal(iterators::nextElem(it), c(3, 4))
  expect_equal(iterators::nextElem(it), c(4, 4))
})


# Usage of logical operators
number1 <- 10
number2 <- 3

# Element wise logical AND between number1 and number2
number1 & number2

# Logical AND between number1 and number2
number1 && number2

# Element wise logical OR between number1 and number2
number1 | number2

# Element wise logical OR between number1 and number2
number1 || number2

# Not of number1
!number1

# XOR of number1 and number2 (AND > NOR > OR)
xor(number1, number2)

0 - Learn R from scratch/logical_operators.r


# Implementation Considerations

library(ggplot2)
library(graphics)
library(ggplot2)
library(MASS)
library(scales) #scale_x_date()
library(gridExtra)

## Set theme
theme_set(theme_minimal(base_size=18))
th <- theme(panel.grid.minor=element_blank(),
            panel.grid.major=element_blank(),
            axis.title.y=element_blank(),
            axis.text.y=element_blank(),
            axis.title.x=element_blank(),
            axis.text.x=element_blank(),
            strip.background = element_rect(fill = "lightgrey", colour = "lightgrey"),
            panel.background = element_rect(fill = "white", colour = "lightgrey")
)

############################################################
## Simple scatter plot - cause and effect
############################################################
## Cause and effect

# For xy plots display the cause on the x-axis and the effect on the y-axis.
set.seed(12345666)
my_data <- data.frame(
  Bodyweight = 90 + 20*c(-runif(50), runif(50))
)
my_data$AUC <- ((my_data$Bodyweight/90)^-0.75)*exp(0.1*rnorm(length(my_data$Bodyweight)))

ggplot(my_data, aes(x = AUC, y = Bodyweight)) +
  geom_smooth(method = "lm") +
  geom_point() +
  theme_minimal(base_size = 18 ) +
  theme(panel.grid.minor=element_blank(),
        #panel.grid.major=element_blank(),
        legend.position="none",
        axis.ticks = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x=element_blank(),
        panel.background = element_rect(fill = "white", colour = "lightgrey")
  )

ggsave(file="GWImp_a1.png", width = 80, height = 80, units = "mm", dpi = 300)

ggplot(my_data, aes(x = Bodyweight, y = AUC)) +
  geom_smooth(method = "lm")+
  geom_point() + theme_minimal(base_size = 18 ) +
  theme(panel.grid.minor=element_blank(),
        #panel.grid.major=element_blank(),
        legend.position="none",
        axis.ticks = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x=element_blank(),
        panel.background = element_rect(fill = "white", colour = "lightgrey")
  )

ggsave(file="GWImp_a2.png", width = 80, height = 80, units = "mm", dpi = 300)

###################################################################
## Simple scatter plot - Aspect ratio
####################################################################

# The selection of the aspect ratio can influence the interpretation of a line graph.
# Try to display lesser height versus greater length.
# Aim to scale the representation to have approximately a 45 degree angle of change.

set.seed(12345666)
my_data <- data.frame(
  x = 50*rnorm(1000)
)
my_data$y <- (0.2*my_data$x+0.8*50*rnorm(length(my_data$x)))

p <- ggplot(my_data, aes(x = x, y = y)) +
  geom_point() + theme_minimal(base_size = 18 ) +
  theme_bw(base_size=16) +
  theme(panel.grid.minor=element_blank(),
        panel.grid.major=element_blank(),
        legend.position="none",
        axis.title.y=element_blank(),
        axis.title.x = element_blank(),
        axis.ticks = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x=element_blank()
  )
p + coord_fixed(0.5)
ggsave(file="GWImp_b1.png", width = 80, height = 80, units = "mm", dpi = 300)

p + coord_fixed(ratio=3)
ggsave(file="GWImp_b2.png", width = 80, height = 80, units = "mm", dpi = 300)

################################################################
## Simple bar chart and dot plot
################################################################

## Plotting bars on a non-linear axis
## Avoid using comparisons based on length (i.e. a bar chart)
## when displaying data on a non-linear scale (i.e. a log scale or percentage change).
## Instead display comparisons using position (i.e.a dot chart).

ggplot(OrchardSprays,aes(x=treatment,y=decrease)) +
  stat_summary(fun.data=mean_cl_normal,geom="bar") +
  theme_minimal(base_size = 18 )+
  scale_y_log10(limits = c(1, 100), breaks = c(1,10,100)) +
  xlab("Treatment") +
  ylab("Effect")

ggsave(file="GWImp_c1.png", width = 80, height = 80, units = "mm", dpi = 300)

mm1 <- function(...) {
  mean_cl_normal(...,mult=1)
}
mm2 <- function(...) {
  mean_cl_normal(...,mult=2)
}

ggplot(OrchardSprays,aes(x=treatment,y=decrease)) +
  stat_summary(fun.data=mm1,geom="point", color = "black",size=4) +
  theme_minimal(base_size = 18)+
  scale_y_log10(limits = c(1, 100), breaks = c(1,10,100))+
  xlab("Treatment")+
  ylab("Effect")

ggsave(file="GWImp_c2.png", width = 80, height = 80, units = "mm", dpi = 300)

######################################################
## Simple dot plot including uncertainty estimates
######################################################
## Log Scales
## Do not plot log-normally distributed variables on a linear scale
## (e.g. hazards ratio, odds ratio, AUC, CL)

DF <- data.frame(Est = c(1,2,3,4,5),
                 Point = c(-0.7, 0.7, 0.2, 0.1, -0.3),
                 SE = c(0.1,0.1,0.1,0.8,0.9))

gg <- ggplot(data = DF) +
  geom_point(aes(x=Est, y= exp(Point)), size = 3) +
  geom_errorbar(aes(x = Est, ymin = exp(Point-2*SE),
                ymax = exp(Point+2*SE)), width = 0.5) +
  scale_y_continuous(breaks = c(0,1,2,3,4,5,6,7,8)) +
  geom_hline(yintercept = 1, linetype = "dashed", color = rgb(0.5,0.5,0.5)) +
  geom_vline(xintercept = 0, linetype = "solid", color = "black") +
  ylab("Odds Ratio") +
  theme_minimal(base_size = 18 ) +
  theme(panel.grid.minor=element_blank(),
        panel.grid.major=element_blank(),
        legend.position="none",
        axis.ticks.x = element_blank(),
        axis.title.x = element_blank(),
        axis.text.x=element_blank()
        )

gg
ggsave(file="GWImp_d1.png", width = 80, height = 80, units = "mm", dpi = 300)

gg + scale_y_log10(breaks = c(0.125,0.25,0.5,1,2,4,8), labels = c("1/8","1/4","1/2","1","2","4","8")) +
  geom_hline(yintercept = 1, linetype = "dashed", color = rgb(0.5,0.5,0.5))

ggsave(file="GWImp_d2.png", width = 80, height = 80, units = "mm", dpi = 300)

#############################################################################
## Simple panelled line plot
#############################################################################
## Consistent scales

set.seed(12345666)
Time = c(c(0.5,1,2,4,8,12,18,23.99), 3*24 + c(0.5,1,2,4,8,12,18,23.99))
DAY = floor(Time/24)
DOSE = (1+DAY)*100
K1 = 0.2
K2 = 0.8
Concentration = DOSE*(K2*K1/(K2-K1))*(exp(-K1*(Time-DAY*24)) - exp(-K2*(Time-DAY*24)) )
my.data <- data.frame(Time = Time, Concentration = Concentration, DAY = DAY, DOSE = DOSE)

gg <- ggplot(data = my.data, aes(x = Time-DAY*24, y = Concentration)) +
  geom_point(size = 4) +
  geom_line(aes(group = DAY), size = 1) + scale_y_log10() +
  theme_minimal(base_size = 18) +
  theme(panel.grid.minor=element_blank(),
                 panel.grid.major=element_blank(),
                 legend.position="none",
                 axis.title.y=element_blank(),
                 axis.title.x=element_blank(),
                 axis.ticks = element_blank(),
                 strip.background = element_rect(fill = "lightgrey", colour = "grey50"),
                 panel.background = element_rect(fill = "white", colour = "grey50"),
                 axis.text.x=element_blank())

gg + facet_wrap(~DOSE, scales = "free_y")
ggsave(file="GWImp_e1.png", width = 80, height = 80, units = "mm", dpi = 300)

gg + facet_wrap(~DOSE)
ggsave(file="GWImp_e2.png", width = 80, height = 80, units = "mm", dpi = 300)

#########################################################################
## Simple line plot with disconnected trend
#########################################################################
## Disconnected scale

set.seed(12345666)
Time = c(c(0,0.5,1,2,4,8,12,18,23.99), 24 + seq(1,2,1)*24, 3*24 + c(0,0.5,1,2,4,8,12,18,23.99))
DAY = floor(Time/24)
K1 = 0.2
K2 = 0.8
Concentration = 100*(K2*K1/(K2-K1))*(exp(-K1*(Time-DAY*24)) - exp(-K2*(Time-DAY*24)) + 0.25*Time/100/(Time/100 + 1))
my.data <- data.frame(Time = Time, Concentration = Concentration, DAY = DAY)

gg <- ggplot(data = my.data, aes(x = Time, y = Concentration)) +
  geom_point(size = 4) +
  geom_line(aes(group = DAY), size = 1) +
  scale_y_log10(lim = c(0.1,100)) +
  theme_minimal(base_size = 18) +
  theme(panel.grid.minor=element_blank(),
        panel.grid.major=element_blank(),
        panel.background = element_rect(fill = "white", colour = "lightgrey"),
                 legend.position="none",
                 axis.title.y=element_blank(),
                 axis.title.x=element_blank(),
                 axis.ticks = element_blank(),
                 axis.text.y=element_blank(),
                 axis.text.x=element_blank()
)

gg + geom_line(size = 1)
ggsave(file="GWImp_f1.png", width = 80, height = 80, units = "mm", dpi = 300)

gg
ggsave(file="GWImp_f2.png", width = 80, height = 80, units = "mm", dpi = 300)

##############################################################
## Simple line plot with uncertainty intervals and band
##############################################################
## Inferences

set.seed(12345666)
Dose = seq(0,10,0.1)
DAY = floor(Dose/24)
K1 = 0.2
K2 = 0.8
Response = 100*(Dose/1)/(Dose/1 + 1)
my.data <- data.frame(Dose = Dose, Response = Response,
                      ymin = Response - 0.1*Response - 5,
                      ymax = Response + 0.1*Response + 5,
                      obs = Response +
                        5*rnorm(length(Response)) +
                        0.1*rnorm(length(Response))*Response,
                      DAY = DAY)

gg <- ggplot(data = my.data, aes(x = Dose, y = Response)) +
  theme_minimal(base_size = 18) +
  geom_line(size = 1) +
  coord_cartesian(ylim = c(-10,120)) +
  theme(panel.grid.minor=element_blank(),
                 panel.grid.major=element_blank(),
                 legend.position="none",
                 axis.title.y=element_blank(),
                 axis.title.x=element_blank(),
                 axis.ticks = element_blank(),
                 axis.text.y=element_blank(),
                 axis.text.x=element_blank(),
                 panel.background = element_rect(fill = "white", colour = "lightgrey")
        )
gg

ggsave(file="GWImp_g1.png", width = 80, height = 80, units = "mm", dpi = 300)

gg + geom_ribbon(aes(ymin = ymin, ymax=ymax), fill = rgb(0.5,0.5,0.5), alpha = 0.5) +
  geom_point(data = my.data[Dose%in%c(0.1,1,2.5,5,10),],
             aes(x=Dose, y=obs),size = 4) +
  geom_errorbar(data = my.data[Dose%in%c(0.1,1,2.5,5,10),],
                aes(x=Dose, ymin=obs-5-0.1*obs, ymax = obs+5+0.1*obs),size = 1)

ggsave(file="GWImp_g2.png", width = 80, height = 80, units = "mm", dpi = 300)

#############################################################
## Simple boxplots on a linear scale
#############################################################
## Continuous Time Scales

grl <- data.frame(x=rep(c(0,1,2,4,8,12,24),200))
grl$y <- 100*(exp(-0.5*grl$x+0.5*rnorm(length(grl$x)))+0.5*rnorm(length(grl$x)))
ggplot(grl, aes(x=factor(x),y=y)) +
  geom_boxplot(aes(group = factor(x)),size=1, color = "black", outlier.size = 3) +
  theme_minimal(base_size=26) +
  th

ggsave(file="GWImp_h1.png", width = 80, height = 80, units = "mm", dpi = 300)

ggplot(grl, aes(x=x,y=y)) +
  geom_boxplot(aes(group = factor(x)),size=1, color = "black", outlier.size = 3) +
  theme_minimal(base_size=26) +
  th

ggsave(file="GWImp_h2.png", width = 80, height = 80, units = "mm", dpi = 300)


library(pbdSBASE, quietly=TRUE)
library(pbdDMAT, quietly=TRUE)
init()
petsc_init()

m <- 9
n <- 8
x <- matrix(c(
              rep(0, n),
              1, 0, 2, 0, 4, 0, 6, 0,
              rep(0, n),
              20, 0, 22, 0, 24, 0, 26, 0,
              rep(0, n),
              40, 0, 42, 0, 44, 0, 46, 0,
              rep(0, n),
              60, 0, 62, 0, 64, 0, 66, 0,
              rep(0, n)),
            m, n, byrow=T)

comm.print(x)

petsc_matprinter("matlab")

l <- pbdDMAT:::convert_dense_to_csr(x)
petsc_test_rmat(dim(x), dim(x), l$Data, l$row_ptr, l$col_ind)

petsc_finalize()

finalize()


library(tidyverse)
library(viridis)

serengeti = read_csv("http://datadryad.org/bitstream/handle/10255/dryad.86348/consensus_data.csv")
serengeti.behaviours = serengeti[10:11] # a data frame/tibble is a list of columns/variables!
plot_by_species = split(serengeti[10:11], serengeti$Species) #split by species
to_plot = plot_by_species[1:10] #so I don't forget to subset

##############
#
### Q1: apply the summary function to each of the different species
#
###############

typeof(plot_by_species)

lapply(plot_by_species[1:10], summary)

##############
#
### Q2: apply the plot function to the first 10 species
### Pair-intermediate: can you plot the species name as the title of the plot?
#
###############
# and have the names of the species on the given plots

##############
#
#Matt B's answer
#
##############

# the simplest by far... but it doesn't use lapply just good old iteration
# his notes:
##A lot of people suggested the use of function (anonymous and otherwise)
##However, iterating through a very simple for loop does the trick
##The code is easier to learn/write, there's really no need to get fancy
##This for loop works like a dream!!

par(mfrow=c(2,5))
for(i in 1:length(to_plot)){
  plot(to_plot[[i]], main = names(to_plot[i]))
}

##############
#
#Jonathan Kennel's answer
#
###############

plot_by_species = split(serengeti, serengeti$Species) #split by species

par(mfrow=c(2,5))

lapply(plot_by_species[1:10],
		function(x) plot(Standing~Resting, x, main = Species[1]))

##############
#
#Nia's solution
#
###############

# I can follow the solution below better
# we are applying the function to the list of names, where each list of
# names are used to call the particular subset of the serengeti.Species2 list

# the x in function(x) is c('aardvark' 'aardwolf'... etc.) and it is calling the serengeti.Species2
# list member correspnding to the name, and plotting it while applying the label to the plot

#Split dataset on species and extract columns 10 and 11 (behaviours)
serengeti.Species2 = split(serengeti[10:11], serengeti$Species)

#Set up multi-paneled plot

#Plots 1-10 with name
par(mfrow=c(2,5))
lapply( names(serengeti.Species2[1:10]),
		function(x) plot(serengeti.Species2[[x]], main = x))

##############
#
# Cam Solution 1
#
###############

# this is the same as Matt B's but utilizes a function to make the plot
# just abstracted the plot away on preference more then anything. Matt's answer K.i.s.s.

#make a function that plots the data and adds a name
behaviour_name_plot = function(data){
  plot(data[[1]], main=names(data) )
}

#test the function
#passes my unit test and does what I expect
behaviour_name_plot(to_plot[2])

#but when I lapply it... the scope is the level below the names of the list
# which is not expected. It puts the column names as the title!
# so my solution to get the names on the plot is no good with lapply!
par(mfrow=c(2,5))
lapply(to_plot, behaviour_name_plot)

#but if I loop over them it works as I would expect
#so lapply and loops are not as equivalent as I would like

par(mfrow=c(2,5))
for(i in 1:10){
  behaviour_name_plot(to_plot[i])
}

##############
#
# Cam Solution 2
#
###############

# by making the function accept 2 arguments, I can pass
# the names of the plots and the plot data into the function.
# I then use mapply to run the function with the two sets of variables passed in
?mapply

apply_behaviour_name_plot = function(data, name_dat){
  plot(data[[1]], main=name_dat, xlab=names(data)[1], ylab=names(data[2]) )
}

par(mfrow=c(2,5))

mapply(apply_behaviour_name_plot, to_plot, names(to_plot))

#things I don't like:

# mapply is format: mapply(function, data)
# lapply is format: lapply(data, function)
# why are these opposite?

#im making a change to my homework!


##SPAM Example: Data splitting

library(caret); library(kernlab); data(spam)
inTrain <- createDataPartition(y=spam$type,
                               p=0.75, list=FALSE)

training <- spam[inTrain,]
testing <- spam[-inTrain,]
dim(training)

#SPAM Example: K-fold

set.seed(32323)
folds <- createFolds(y=spam$type,k=10,
                     list=TRUE,returnTrain=TRUE)
sapply(folds,length)
folds[[1]][1:10]

#SPAM Example: Return test

set.seed(32323)
folds <- createFolds(y=spam$type,k=10,
                     list=TRUE,returnTrain=FALSE)
sapply(folds,length)
folds[[1]][1:10]

#SPAM Example: Resampling

set.seed(32323)
folds <- createResample(y=spam$type,times=10,
                        list=TRUE)
sapply(folds,length)
folds[[1]][1:10]

#SPAM Example: Time Slices

set.seed(32323)
tme <- 1:1000
folds <- createTimeSlices(y=tme,initialWindow=20,
                          horizon=10)
names(folds)
folds$train[[1]]
folds$test[[1]]


library(ggplot2)

args <- commandArgs(trailingOnly = TRUE)

read.csv(args[1])

#add argument instead of regrex1.csv
regrex1 <- read.csv(args[1])

png("scatter.png")
ggplot(regrex1, aes(x,y)) + geom_point()
dev.off()

#ggplot(regrex1, aes(x,y)) + geom_smooth(method ="lm", se = F)

png("fit.png")
ggplot(regrex1, aes(x,y)) + geom_point() + geom_smooth(method ="lm", se = F)
dev.off()


#' @title calcKristThrustFactor
#'
#' @description Calculate the thrust deduction factor (\code{thrustFactor})
#'(dimensionless) using the Kristensen method.
#'
#' @param shipType Ship type (vector of strings, see \code{\link{calcShipType}}),
#' determined by Stat 5 code, \itemize{
#' \item"container.ship"
#' \item"bulk.carrier"
#' \item"tanker"
#' \item"general.cargo"
#' \item"vehicle.carrier"
#' \item"reefer"
#' \item"ro.ro"
#' \item"passenger"
#' \item"tug"
#' \item"misc"
#'}
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param lwl Waterline Length (vector of numericals, m) (see
#'\code{\link{calclwl}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCbw}})
#'@param propDiam Propeller diameter (vector of numericals, m) (see
#' \code{\link{calcPropDia}})
#'@param M Fineness/slenderness coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcShipM}})
#'@param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#' @param tankerBulkCarrierShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers and bulk carriers vessels
#' (vector of strings)
#'
#' @details
#'Thrust deduction factor is a component of hull efficiency as well as a
#'component of propeller efficiency. It describes the increase in resistance on
#'the hull from water getting sucked back towards the propeller.
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierShipTypes} grouping  parameters to provide these ship
#' type groupings. Any ship types not included in this grouping will be considered
#' as miscellaneous vessels.
#'
#' @return \code{thrustFactor} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcShipM}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcShipType}}
#'}
#'
#' @family Kristensen Calculations
#'
#' @examples
#' calcKristThrustFactor(c("bulk.carrier","container.ship"),
#'                       c(32.25,49),
#'                       c(218.75,400),
#'                       c(0.8,0.75),
#'                       c(6.7,9.6),
#'                       c(5.2,6.7),
#'                       c(1,1))
#'
#' calcKristThrustFactor("bulk.carrier", 32.25, 218.75, 0.8, 6.7,5.2,1)
#'
#' @export

calcKristThrustFactor <- function(shipType, breadth, lwl, Cbw, propDiam,M,nProp,
                                  tankerBulkCarrierShipTypes=c("tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier")
){

  thrustFactor<-ifelse(nProp==1,
                       ifelse(shipType%in%tankerBulkCarrierShipTypes,
                              (#single prop case
                                #t1
                                #d
                          (((0.625*breadth)/lwl)+0.08)+
                            #e
                            (0.165-((0.25*breadth)/lwl))/
                            (#f
                              (825-((8060*breadth)/lwl)+
                                 20300*((breadth/lwl)^2))*
                                (0.98-Cbw)^3+1)+
                            #t2=0 since we assume F_a=0
                            #t3
                            (2*((propDiam/lwl)-0.04))
                        )#thrust correction
                        -0.26+0.04*M,
                        (#single prop case for non bulk carriers non tankers
                          #t1
                          #d
                          (((0.625*breadth)/lwl)+0.08)+
                            #e
                            (0.165-((0.25*breadth)/lwl))/
                            (#f
                              (825-((8060*breadth)/lwl)+
                                 20300*((breadth/lwl)^2))*
                                (0.98-Cbw)^3+1)+
                            #t2=0 since we assume F_a=0
                            #t3
                            (2*((propDiam/lwl)-0.04))
                        )),
                         (#twin prop case
                          0.0665+0.62833*(1.133*(Cbw^2)-0.797*Cbw+0.215)
                        )#end of twin prop case

            )#end elseif

   return(thrustFactor)

}


HIT <- 1
STICK <- 2
BJCard <- function()
  return(sample(10,1))

StateInput <- function () {
  return ( c(sample(10, 1), sample(10, 1), 0))
}
StepFunc <- function (s, a) {
  if(s[3]==1)
    return(list(s, 0))

  NewState <- s
  BJReward <- 0

  if(a==1) {
    NewState[2] <- s[2] + BJCard()
    if (NewState[2]>21 || NewState[2]<1) {
      NewState[3] <- 1
      BJReward <- -1
    }
  }
  else {
    NewState[3] <- 1
    DealerWork <- FALSE
    DealerSum <- s[1]
    while(!DealerWork) {
      DealerSum <- DealerSum + BJCard()
      if (DealerSum>21) {
        DealerWork <- TRUE
        BJReward <- 1
      } else if (DealerSum >= 17) {
        DealerWork <- TRUE
        if(DealerSum==s[2])
          BJReward <- 0
        else
          BJReward <- 2*as.integer(DealerSum<s[2])-1
      }
    }
  }
  return(list(NewState, BJReward))
}

ActionsEpsValGreedy <- function(s, QFunc, EpsVal) {
  if(runif(1)<EpsVal)
    return(sample(1:2, 1))
  else
    return(which.max(QFunc[s[1],s[2],]))
}

library("foreach")

MontecarloFunc <- function(NumEpisode){
  QFunc <- array(0, dim=c(10, 21, 2))
  N <- array(0, c(10,21,2))
  N0=100

  policy <- function(s) {
    ActionsEpsValGreedy(s, QFunc, N0/(sum(N[s[1], s[2],])+N0))
  }

  foreach(i=1:NumEpisode) %do% {
    s <- StateInput()
    SumReturns <- 0
    N.episode <- array(0, c(10,21,2))

    while(s[3]==0) {
      a <- policy(s)
      N.episode[s[1], s[2], a] <- N.episode[s[1], s[2], a] + 1
      StateReward <- StepFunc(s, a)
      s <- StateReward[[1]]
      SumReturns <- SumReturns + StateReward[[2]]
    }
    IndexValue <- which(N.episode!=0)
    N[IndexValue] <- (N[IndexValue]+N.episode[IndexValue])
    QFunc[IndexValue] <- QFunc[IndexValue] + (SumReturns- QFunc[IndexValue]) / N[IndexValue]
  }
  return(list(QFunc=QFunc, N=N))
}

MCModel <- MontecarloFunc(NumEpisode=100000)

StateValueFunc <- apply(MCModel$QFunc, MARGIN=c(1,2), FUN=max)
persp(StateValueFunc, x=1:10, y=1:21, theta=50, phi=35, d=1.9, expand=0.3, border=NULL, ticktype="detailed",
      shade=0.6, xlab="Dealer exposed card", ylab="Player sum", zlab="Value", nticks=10)


#  this script calculates the mean M (=M1+M2) over all years and write it to a file
dat<-Read.summary.data(read.init.function=T)
dat$M<-dat$M1+dat$M2
dat<-droplevels(subset(dat,Species.n>=first.VPA))

if (T) {  # average M over all years
  M<-tapply(dat$M,list(dat$Quarter,dat$Age,dat$Species.n),mean)
  M[is.na(M)]<- -1

  outf<-file.path(data.path,'natmor_avg.in')
  cat('# single species from average multispecies M1+M2 over the full period\n',file=outf)

  for (sp in (first.VPA:nsp)) {
    for (y in (SMS.control@first.year:SMS.control@last.year )) {

    cat(paste('# ',sp.names[sp],y,'\n'),file=outf,append=T)
    write.table(round(M[,,as.character(sp)],3),append=T,file=outf,row.names = F,col.names = F)
  }
  }
}

if (T) { # M by year
  M<-tapply(dat$M,list(dat$Year,dat$Quarter,dat$Age,dat$Species.n),sum)
  M[is.na(M)]<- -1

    outf<-file.path(data.path,'natmor_by_year.in')
  cat('# single species from average multispecies M1+M2\n',file=outf)

  for (sp in (first.VPA:nsp)) {
    for (y in (SMS.control@first.year:SMS.control@last.year )) {

      cat(paste('# ',sp.names[sp],y,'\n'),file=outf,append=T)
      write.table(round(M[as.character(y),,,as.character(sp)],3),append=T,file=outf,row.names = F,col.names = F)
    }}
}
cat(-999," # checksum",file=outf,append=T)


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 10, 2016
# clear; Rscript rfactor.r; rm *~
# ref: http://www.programiz.com/r-programming/factor
# 5 data types in R : vectors, matrix, list, data frame and a factor
setwd("~/Copy/2016Spring/RProgramming/presentation/dataTypes/")

#########################################################################################################
#   FACTORS CREATION
#########################################################################################################
x <- factor(c("single","married","married","single")); x

x <- factor(c("single","married","married","single"), levels=c("single","married","divorced")); x
class(x)
levels(x)
str(x)

#########################################################################################################
#   FACTORS ELEMENT ACCESSING
#########################################################################################################
cat("\n")
x
x[3]           # access 3rd element
x[c(2, 4)]     # access 2nd and 4th element
x[-1]          # access all but 1st element
x[c(TRUE, FALSE, FALSE, TRUE)]  # using logical vectors

#########################################################################################################
#   FACTORS MODIFICATION
#########################################################################################################
cat("\n")
x
cat("\n")
x[2] <- "divorced";x    # modify second element
#x[3] <- "widowed" ;x   # cannot assign values outside levels
levels(x) <- c(levels(x), "widowed")    # add new level
x[3] <- "widowed";x


library(quantmod)
setwd('<workspace directory>')
# must remove all chinese characters manually
# must remove superfluous lines manually

cb_stock <- NULL
for (month in 6:11) {
    if (month < 10) {
        ms <- paste( '0', toString(month), sep='' )
    }
    else {
        ms <- toString(month)
    }
    file_name <- paste('STOCK_DAY_2330_2020', ms, '.csv', sep='')
    stock <- read.csv(file_name, header=TRUE)
    stock[, 2] <- as.numeric( gsub(',', '', stock[, 2]) )
    stock[, 3] <- as.numeric( gsub(',', '', stock[, 3]) )
    stock[, 9] <- as.numeric( gsub(',', '', stock[, 9]) )

    time_char_vector <- paste(stock[, 1])
    time_char_vector <- gsub('/', '-', time_char_vector)
    time_y <- substr(time_char_vector, 1, 3)
    time_y <- as.numeric(time_y) + 1911
    time_char_vector <- paste0( time_y, substr(time_char_vector, 4, 9) )

    time_vector <- strptime(time_char_vector, '%Y-%m-%d', tz=Sys.timezone())
    time_vector <- as.POSIXct(time_vector)

    stock <- as.matrix( stock[, c(4, 5, 6, 7, 9)] )
    stock <- xts(stock, time_vector)
    cb_stock <- rbind(cb_stock, stock)
}

chartSeries(cb_stock)


getwd() # day3 folder

fileName <- 'day3\\input.txt'
fileCon <- file(fileName,'rb')
input <- readChar(fileCon, file.info(fileName)$size)
close(fileCon)
# print(input)

nVisited <- function(input){
    xyMin = 100 # increased until the code dont give errors anymore
    map <- matrix(0, nrow = 2*xyMin, ncol = 2*xyMin)
    currX = 0
    currY = 0
    nInstructions = nchar(input)
    for (i in 1:nInstructions){
        instr = substr(input,i,i)
        if (instr == "<"){
            currX <- currX -1
        } else if (instr=="^"){
            currY <- currY+1
        }else if (instr=="v"){
            currY <- currY-1
        }else if (instr==">"){
            currX <- currX+1
        }
        map[currX+xyMin,currY+xyMin] <- map[currX+xyMin,currY+xyMin] + 1
    }
    return(sum(map>0))
}

stopifnot(nVisited(input)==2572) # solution A

solve.B <- function(input){
    stopifnot(nchar(input)%%2==0) # make sure sanda and RoboSanta get the same amount of presents

    xyMin = 100 # increased until the code dont give errors anymore
    map <- matrix(0, nrow = 2*xyMin, ncol = 2*xyMin)
    currX = 0
    currY = 0
    roboX = 0
    roboY = 0
    map[currX+xyMin,currY+xyMin] <- map[currX+xyMin,currY+xyMin] + 1

    nInstructions = nchar(input)
    for (i in 1:(nInstructions/2)){
        zerosIdxI = i-1
        instrIdx = 2*zerosIdxI +1
        roboInstrIdx = instrIdx +1
        # print(c(i,zerosIdxI,instrIdx,roboInstrIdx))
        instr = substr(input,instrIdx,instrIdx)
        roboInstr = substr(input,roboInstrIdx,roboInstrIdx)
        # print(c(instr,roboInstr))
        if (instr == "<"){
            currX <- currX -1
        } else if (instr=="^"){
            currY <- currY+1
        }else if (instr=="v"){
            currY <- currY-1
        }else if (instr==">"){
            currX <- currX+1
        }
        if (roboInstr == "<"){
            roboX <- roboX -1
        } else if (roboInstr=="^"){
            roboY <- roboY+1
        }else if (roboInstr=="v"){
            roboY <- roboY-1
        }else if (roboInstr==">"){
            roboX <- roboX+1
        }
        map[currX+xyMin,currY+xyMin] <- map[currX+xyMin,currY+xyMin] + 1
        map[roboX+xyMin,roboY+xyMin] <- map[roboX+xyMin,roboY+xyMin] + 1
    }
    ans <- sum(map>0)
    # print(c(currX,currY,roboX,roboY,ans))
    return(ans)
}

stopifnot(solve.B("^v")==3,solve.B("^>v<")==3,solve.B("^v^v^v^v^v")==11,
solve.B(input)==2631 # answer B
)


\name{Jeong}
\alias{Jeong}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Jeong's method for estimating  the preferential attachment function
}
\description{
  This function estimates the preferential attachment function by Jeong's method.
}
\usage{
Jeong(net_object                               ,
      net_stat  = get_statistics(net_object)   ,
      T_0_start = 0                            ,
      T_0_end   = round(net_stat$T * 0.75)     ,
      T_1_start = T_0_end + 1                  ,
      T_1_end   = net_stat$T                   ,
      interpolate = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
 \item{net_object}{
    an object of class \code{PAFit_net} that contains the network.
  }
  \item{net_stat}{
    An object of class \code{PAFit_data} which contains summerized statistics needed in estimation. This object is created by the function \code{\link{get_statistics}}. Default value is \code{ get_statistics(net_object)}.
  }
  \item{T_0_start}{Positive integer. The starting time-step of the \code{T_0_interval}. Default value is \code{0}.}
  \item{T_0_end}{Positive integer. The ending time-step of \code{T_0_interval}. Default value is \code{round(net_stat$T * 0.75)}.}

  \item{T_1_start}{Positive integer. The starting time-step of the \code{T_1_interval}. Default value is \code{T_0_end + 1}.}
  \item{T_1_end}{Positive integer. The ending time-step of \code{T_1_interval}. Default value is \code{net_stat$T}.}

  \item{interpolate}{
    Logical. If \code{TRUE} then all the gaps in the estimated PA function are interpolated by linear interpolating in logarithm scale. Default value is \code{FALSE}.
  }
}
\value{
  Outputs an \code{PA_result} object which contains the estimated attachment function. In particular, it contains the following field:
     \itemize{
    \item \code{k} and \code{A}: a degree vector and the estimated PA function.

    \item \code{center_k} and \code{theta}: when we perform binning, these are the centers of the bins and the estimated PA values for those bins.
    \item \code{g}: the number of bins used.
    \item \code{alpha} and \code{ci}: \code{alpha} is the estimated attachment exponenet \eqn{\alpha} (when assume \eqn{A_k = k^\alpha}), while \code{ci} is the confidence interval.
    \item \code{loglinear_fit}: this is the fitting result when we estimate \eqn{\alpha}.
}
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Jeong, H., \enc{Néda}{Neda}, Z. & \enc{Barabási}{Barabasi}, A. . Measuring preferential attachment in evolving networks. Europhysics Letters. 2003;61(61):567–572. doi: 10.1209/epl/i2003-00166-9 (\url{https://iopscience.iop.org/article/10.1209/epl/i2003-00166-9}).
}
\seealso{

 See \code{\link{get_statistics}} for how to create summerized statistics needed in this function.

See \code{\link{Newman}} and \code{\link{only_A_estimate}} for other methods to estimate the attachment function in isolation.

}

\examples{
  library("PAFit")
  net        <- generate_net(N = 1000 , m = 1 , mode = 1 , alpha = 1 , s = 0)
  net_stats  <- get_statistics(net)
  result     <- Jeong(net, net_stats)
  # true function
  true_A     <- result$center_k
  #plot the estimated attachment function
  plot(result , net_stats)
  lines(result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")
}
\concept{preferential attachment}
\concept{attachment function}


# Fecha:
# Prof. Héctor Bahamonde.
# Ayudante: Gonzalo Barría.
# Fecha entrega: una semana de plazo desde su fecha de publicacion en uCampus (Tareas).

# Contraceptive Use in Indonesia

# Carga los datos: Contraceptive Use in Indonesia
load(url("https://github.com/hbahamonde/MLE/raw/master/Datasets/Contraceptive_Method_Choice.RData"))

# Resumen
summary(dat)

## CODEBOOK
# "wife_age": edad de la esposa.
# "wife_edu": nivel educ de la esposa.
# "husb_edu": nivel educ del marido.
# "num_child": numero de hijos.
# "islam": cree en el islam? (1=si), (0=no)
# "wife_working": la esposa, trabaja?
# "husb_job": categoria de trabajo del esposo.
# "SOL_index": standard-of-living index
# "media_exposure": si, no.
# "cmc": Contraceptive Method Choice

# En este ej pensaremos en la frecuencia en que las mujeres de Indonesia usan metodos anti-conceptivos. Veamos como se ve la variable.
plot(dat$cmc)

##########################################################################################

# 1. Utiliza un modelo multinomial para estimar "dat$cmc".
## 1.1 Que modelo corresponde: multinomial "ordenado" o "desordenado"?
## 1.2 El modelo que debieras haber escogido tiene dos versiones. Cual es la diferencia entre ambos modelos?

# 2. Estimacion.
## 2.1 Estima ambos modelos. Para ello, escoge entre 3-5 variables independientes y justifica el uso de cada una de ellas. No te olvides de usar una tabla ("screenreg").
## 2.2 Cual hace un mejor trabajo ajustando (fit) la varianza de la variable dependiente? Usa al menos  dos criterios para evaluar el fit de cada modelo.

# 3. Interpreta graficamente el modelo cuya especificacion se reviso en clase. Para esto, usa tecnicas graficas de predicted probabilities.


#' @param X matrix. Rows are genes. Columns are samples. Row names are symbols.
#' @param gene_sets list. Each element is a string vector with gene symbols.
#' @param alpha numeric. Parameter for ssGSEA, the default is 0.25
#' @param scale logical. If True, normalize the scores by number of genes in the gene sets.
#' @param norm logical. If True, normalize the scores by the absolute difference between max and min values.
#' @param single logical. If True, use ssGSEA algorithm, otherwise use GSEA.
#'
#' @return matrix containing enrichment scroes. Rows are gene sets, columns are samples.
#'
#' @examples
#' # Create a fake matrix
# m = 100
# n = 100
# set.seed(1)
# X = matrix(rnorm(m*n), m, n)
# # # Assign 'gene symbols' to row names
# rownames(X) = 1:m
# # Create 3 gene sets
# gene_sets = list(a = sample(m, 5), b = sample(m, 5), c = sample(m, 5))
# system.time(assign('a', GSVA::gsva(X, gene_sets, method = 'ssgsea')))
# system.time(assign('b', ssgsea(X, gene_sets, scale = F, norm = T)))
# identical(a, b)
set.seed(1)
ssgsea = function(X, gene_sets, alpha = 0.25, scale = T, norm = F, single = T) {
  row_names = rownames(X)
  num_genes = nrow(X)
  gene_sets = lapply(gene_sets, function(genes) {which(row_names %in% genes)})

  # Ranks for genes
  R = matrixStats::colRanks(X, preserveShape = T, ties.method = 'average')

  # Calculate enrichment score (es) for each sample (column)
  es = apply(R, 2, function(R_col) {
    gene_ranks = order(R_col, decreasing = TRUE)

    # Calc es for each gene set
    es_sample = sapply(gene_sets, function(gene_set_idx) {
      # pos: match (within the gene set)
      # neg: non-match (outside the gene set)
      indicator_pos = gene_ranks %in% gene_set_idx
      indicator_neg = !indicator_pos

      rank_alpha  = (R_col[gene_ranks] * indicator_pos) ^ alpha

      step_cdf_pos = cumsum(rank_alpha)    / sum(rank_alpha)
      step_cdf_neg = cumsum(indicator_neg) / sum(indicator_neg)

      step_cdf_diff = step_cdf_pos - step_cdf_neg

      # Normalize by gene number
      if (scale) step_cdf_diff = step_cdf_diff / num_genes

      # Use ssGSEA or not
      if (single) {
        sum(step_cdf_diff)
      } else {
        step_cdf_diff[which.max(abs(step_cdf_diff))]
      }
    })
    unlist(es_sample)
  })

  if (length(gene_sets) == 1) es = matrix(es, nrow = 1)

  # Normalize by absolute diff between max and min
  if (norm) es = es / diff(range(es))

  # Prepare output
  rownames(es) = names(gene_sets)
  colnames(es) = colnames(X)
  return(es)
}

# setwd("~/github/GSEApy/tests/data")
# comparison with gseapy.ssgsea
X2 = read.table("./data/testSet_rand1200.gct", row.names = 1, header = T,
                comment='#', sep="\t", stringsAsFactors = F)
X3 = as.matrix.data.frame(X2[,-1])
gene_sets = fgsea::gmtPathways("./data/randomSets.gmt")

# test
system.time(assign('a', GSVA::gsva(X3, gene_sets, method = 'ssgsea')))
system.time(assign('b', ssgsea(X3, gene_sets, scale = F, norm = T)))
system.time(assign('b2', ssgsea(X3, gene_sets, scale = T, norm = F)))

identical(a, b)
print("TEST with GSVA::gsva(method='ssgsea')")
print(a)

print("\n\n\n")
print("TEST with ssgsea, NES")
print(b)

print("\n\n\n")
print("TEST with ssgsea, Scaled ES")
print(b2)


#' Fit a vine copula
#'
#' Fit a vine copula density function, using one of the marginal function for the marginal transformations, and using VineCopula::RVineStructureSelect for the vine copula function.
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param marginalfn One of the marginal fitting functions.
#' @param bounds Dx2 matrix of boundaries
#' @param trunclevel Relayed to the VineCopula::RVineStructureSelect
#' @param indeptest Relayed to VineCopula::RVineStructureSelect
#' @param verbose Relayed to VineCopula::RVineStructureSelect
#' @export
fit.vine.copula <- function(x, marginalfn, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), trunclevel = NA, indeptest = F, verbose = F) {
  result <- list()
  result$type <- "vine.copula"
    if (!is.null(marginalfn)) {
        result$marginal <- marginalfn(x, bounds)
        transformed <- mvd.marginal.transform(x, result$marginal)
    } else {
        result$marginal <- NULL
        transformed <- x
    }
  result$RVM <- VineCopula::RVineStructureSelect(transformed, cores = 1, trunclevel = trunclevel, indeptest = indeptest, progress = verbose)
  result$RVM$names <- colnames(x)
  return(structure(result, class = "mvd.density"))
}

#' Evaluate a vine copula
#'
#' description
#' @param fit An mvd.density object obtained from fit.vine.copula
#' @param x Matrix or vector of samples at which to evaluate the vine copula. For matrices, rows are samples and columns are variables.
#' @param log Return log probability density
#' @export
evaluate.vine.copula <- function(fit, x, log = F) {
  if (!is.null(fit$marginal)) {
    transformed <- mvd.marginal.transform(x, fit$marginal)
  } else {
    transformed <- x
  }
  p_vc <- VineCopula::RVineLogLik(transformed, fit$RVM, separate = T)$loglik
  if (!is.null(fit$marginal)) {
    p <- .marginal.correct.p(fit$marginal, x, p_vc, log = T)
  }
  if (log) {
      return(p)
    } else {
      return(exp(p))
    }
}