library(foreach)
#library(doParallel)

# regularized version
cv.tlpreg0 <- function(y, X, b.init = NULL, pen.fac = rep(1,ncol(X)),
                      tau=0.5*sqrt(log(p)/n), gamma=NULL, nfold=10,
                      tol=1e-4, dc.maxit=as.integer(max(5,1+log2(n/log(p)))), cd.maxit=1e+4) {
    #cl <- makeCluster(5)
    #registerDoParallel(cl)

    n <- nrow(X)
    p <- ncol(X)
    if (n < nfold) stop("nfold cannot be larger than n.")

    if(is.null(gamma)) {
        gamma <- exp(seq(from=log(max(abs(crossprod(X, y - mean(y))))/n),
                          to=log(ifelse(p < n, .001, .08)),
                          length.out=100))/tau
    }

    # nfold-cross-validation
    obs.fold <- rep(1:nfold,n)[sample.int(n)]
    cv <- foreach(fold = 1:nfold, .combine = "cbind") %do% {
        #source("tlpreg.r")
        b <- tlpreg0(y=y[obs.fold!=fold], X=X[obs.fold!=fold,], b.init = b.init,
                     tau=tau, gamma = gamma, pen.fac = pen.fac,
                     tol = tol, dc.maxit = dc.maxit, cd.maxit = cd.maxit)$b

        apply(b, 2, function(beta) {
            res <- (y[obs.fold==fold] - X[obs.fold==fold,] %*% beta)
            mean((res - mean(res))^2)
        })
    }

    #stopCluster(cl)

    # output CV graph
    cvm <- rowMeans(cv)
    list(gamma.min=gamma[which.min(cvm)], cvm = cvm, gamma=gamma)
}


#
#

euclidian.distance <- function (a,b)  {
  sqrt (sum((a - b) * (a -b)))
}
log.message <- function (a){
  cat (sprintf ("\n**** %s\n", a))
}

is.multiple <- function  (a ,b) {
  abs(a - round (a / b) * b) < 1e-6
}

error.mat <- function (name, h) {
  tab <- as.matrix (read.table (name))

  dim <- round (0.1 /h )  + 1
  mat = matrix (NA, dim,dim)
  for (p in 1:(length (tab[,1]))) {
    x<-tab[p, 1]
    y<-tab[p,2]
    if (is.multiple (x,h) && is.multiple (y,h))
      {
        x<- round (x/ h ) + 1
        y<- round (y/ h) + 1
        mat[x,y] = tab[p,3]
      }
  }
  mat
}
calc.h <- function (level) {
  0.1/ (2 ^ level)
}

plot.error <- function (mat, h, title) {
  s <- seq (0,0.1,by=h)
  contour (s, s, mat,
           xlab = "x [m]",
           ylab = "y [m]",
           main ='displacement error',
           sub = title)
}

plot3d.error <- function (mat, h, title = "bla")
{
  s <- seq (0,0.1,by=h)
  persp (s, s, mat, scale = TRUE,
         xlab = "x [m]",
         ylab = "y [m]",
         main ='displacement error',
         sub = title,
         zlab = "u error [mm]",
         expand = 0.3,
         phi = 20, theta=30,
#         ltheta = -120,
#         border = "white",
         shade = 0.75, box=TRUE, nticks=5,
         ticktype="detailed"
         )
}

file.mean.max <- function (nm)
{
  mat <-  read.table(nm)
  c(mean(mat[,3]), max(mat[,3]))
}

print.mean.max <- function (nm)
  {
    q <- file.mean.max (nm)
    sprintf ("Avg [mm] : %g, Max [mm]: %g\n", 10^3* q[1], 10^3* q[2])
  }

binary <-  '../needle2d/out-barespeed/needle ' # -odynamic-friction-factor=1.0'

# static.cmd <- paste(binary, ' -Ssynthetic-node-forces -ofix-planes=right -oouter-loop-tolerance=%g ',                    '-oprint-mesh=yes -oinitial-h=%lg -orefinement-h=%g')
static.cmd <- paste(binary, ' -Sangled-forces -ofix-planes=right -oouter-loop-tolerance=%g ',
                    '-oprint-mesh=yes -oinitial-h=%lg -oauto-insert-depth=0.075 -oauto-insert-y=0.0501 -orefinement-h=%g')

my.system <-  function (c) {
  cat (sprintf ("\ninvoking `%s'\n", c))
  st <- system (c)
  if (st) {
    stop (sprintf ("Command failed  (%d)\n", st))
  }
}

plot.error.field <- function (fn, tit, max.level)  {
  mat <- error.mat (fn, calc.h(max.level))
  h <- calc.h (max.level)
  reduced.h  <-  calc.h (min (max.level - 2,
                              7
                              ))
  reduced.mat <-  error.mat (fn, reduced.h)

  cat ("Now processing: ", tit, "\n")

  postscript (file = paste ('needle-', fn, "-3d.eps", sep=""),
              paper="special",
              width = 7.5, height=5,
              horizontal = FALSE)
  plot3d.error (10^3 * reduced.mat, reduced.h, tit)
  dev.off()

  postscript  (file = paste ('needle-', fn, "-cont.eps", sep=""),
               paper="special",
               width = 6, height=4,
               horizontal = FALSE)
  plot.error (10^3 * mat, h, tit)
  dev.off()
}

mat.to.latex.table <- function (m, format="f", digits=2) {
  for (x in 1:length (m[,1])) {
    strvec <- formatC( m[x,], format = format, digits=digits)
    cat (sub ('NA', '   ', strvec),  sep="&");
    cat ("\\\\\n")
  }
}

################################################################
# CG tolerance
################################################################

tolerance.experiment <- function (max.level)  {
  try.tols <- c(0.3, 0.1, 0.03, 0.01, 0.003, 0.001)

  u <- max.level
  r <- max.level
  c <-sprintf (static.cmd, 1e-8, calc.h (u),  calc.h (r))
  my.system (c)
#  my.system ('mv needle-deformation.state static-deformation-reference.state')
  my.system ('mv needle-deformation.state angled-deformation-reference.state')
  for (t in seq (along=try.tols)) {
    c <-sprintf (static.cmd, try.tols[t], calc.h (u),  calc.h (r))
    my.system (c)
    my.system (sprintf ('mv error-plot error-plot-t%d', t))
  }

  avg.max.errs <- matrix (NA, length (try.tols),  3)

  for (t in seq(along=try.tols)) {
    fn <- paste ("error-plot-t",t, sep="")
    tit <- paste ("residual tolerance", try.tols[t])

    plot.error.field(fn,tit,  max.level)

    tab <- read.table (fn)

    avg.max.errs[t,1] <- try.tols[t]
    avg.max.errs[t,2] <- 10^3 * mean (tab[,3])
    avg.max.errs[t,3] <- 10^3 * max (tab[,3])
  }

  cat ("Tolerance dependency, average/maximum error.")
  mat.to.latex.table (avg.max.errs, digits=4)
}

################################################################
# h dependency.
################################################################

calc.static.reference.solution <- function (max.level) {
  cat ("Calculating static reference solution.\n")

  c <-  sprintf (static.cmd, 1e-10, calc.h (max.level),  calc.h (max.level))
  my.system (c)
#  my.system ('mv needle-deformation.state static-deformation-reference.state')
  my.system ('mv needle-deformation.state angled-deformation-reference.state')
}

h.dependency.error.table <- function  (max.level) {
  max.errs = matrix (NA, max.level + 1, max.level + 1)

  for (u in 1:max.level)
    max.errs[1,u+1] = calc.h (u)
  for (r in 1:max.level)
    max.errs[r+1,1] = calc.h (r)
  avg.errs <- max.errs
  iter.counts <- max.errs

  for (u in 1:(max.level -1)) {
    for (r in u:max.level) {
      fn <- sprintf ("error-plot-r%d-u%d",r,u)

      tab <- read.table (fn)
      mat <- tab[,3]

      avg.errs[u+1,r+1] = mean (mat)
      max.errs[u+1,r+1] = max (mat)

      tab <- read.table (sprintf ("iteration-stats-r%d-u%d", r,u))
      iter.counts [u+1,r+1] <- tab[1,1]
    }
  }
  cat ("h_ref/h_initial error estimates\n")

  cat ("Avg errors\n")
  mat.to.latex.table (10^3 * avg.errs)
  cat ("Max errors\n")
  mat.to.latex.table (10^3* max.errs)
  cat ("Iteration counts\n")
  mat.to.latex.table (iter.counts, format = "d")
}

plot.u.r.table <-  function (u,r,max.level)
{
  fn <- paste ("error-plot-r",r, "-u",u, sep="")
  tit <- sprintf ("h-refine = h_%d, h-start = h_%d",r,u)
  plot.error.field(fn,tit,  max.level)
}

static.experiments <-  function (max.level) {
  calc.static.reference.solution (max.level)
  iter.counts = matrix (NA, max.level + 1, max.level + 1)

  tol <- 1e-8
  for (u in 1:(max.level -1)) {
    for (r in u:max.level) {
      c <- sprintf (static.cmd, tol, calc.h (u), calc.h (r))
      my.system (c)
      my.system (sprintf ('mv error-plot error-plot-r%d-u%d', r,u))
      my.system (sprintf ('mv deformed-mesh.eps needle-deformed-mesh-r%d-u%d.eps', r,u))

       my.system (sprintf ('mv iteration-statistics.txt iteration-stats-r%d-u%d', r,u))

    }
  }

  for (u in 1:(max.level -1)) {
    for (r in u:max.level) {
      plot.u.r.table (u,r,max.level)
    }
  }

  h.dependency.error.table (max.level)
}

################################################################
# insertion speed
################################################################

central.insert.y = 0.050001
insertion.tol <- 0.001
insertion.cmd <- sprintf ('%s -oauto-insert-depth=0.08 -Sauto-insert -ofix-planes=right -oauto-insert-y=%g -oouter-loop-tolerance=%g',
                          binary, central.insert.y, insertion.tol)

try.speeds <- c(3.0001, 1.0001, 0.3001, 0.1, 0.03, 0.01)

##
## Computing the  deformation on the fully refined grid is rather expensive. Instead we calc
## force distribution on adaptive grid,  and use that force distr to compute a solution on a full
## grid
##
calc.insert.reference.solution <- function (u, ref) {
  log.message ("Calculating insertion reference solution.\n")
  cmd <-  sprintf ('%s -oauto-insert-speed=%g -orefinement-h=%g',
                   insertion.cmd, 0.005, calc.h (ref))

  my.system (sprintf ('%s -oinitial-h=%g ', cmd, calc.h(u)))

  my.system ('mv graph-needle-forces.txt reference-needle-dump.txt')
  my.system (sprintf ('%s -oinitial-h=%g -Sread-needle-dump ', cmd, calc.h(ref)))

  my.system ('mv needle-deformation.state insert-reference.state')
  my.system (sprintf ('%s -oinitial-h=%g ',
                      cmd, calc.h(u)))
  my.system ('mv error-plot needle-insert-shortcut-error')

  log.message(sprintf ("Shortcut error: %s\n", print.mean.max ('needle-insert-shortcut-error' )))

  plot.error.field ('needle-insert-shortcut-error', "Error caused by shortcutting by refined mesh",
                    ref)

  mat <- 10^3 * read.table ('needle-insert-shortcut-error')

  short.cut.errors <- file.mean.max ('needle-insert-shortcut-error')
  cat (sprintf ("Error caused by short cut: mean %g/max %g\n",  short.cut.errors[1],
                short.cut.errors[2]))

  #
  # we need the 0.0001 epsilon to prevent degeneracies causing endless loops in the needle
  # inserter.
  #
  speed.test.tol <- 0.001

  log.message ("Experimenting with insertion speed.\n")

  speeds <-   try.speeds
  for (i in seq (along =speeds)) {
    s <-  speeds[i]
    c <-  sprintf ("%s -oauto-insert-speed=%e -oinitial-h=%g -orefinement-h=%g",
                   insertion.cmd, s,
                   calc.h (u), calc.h (ref))

    my.system (c)

    my.system (sprintf ('mv error-plot speed-errors-s%d' , i))
    my.system (sprintf ('mv error-plot.xerror speed-errors-s%d.xerror' , i))
  }

  avg.max.errs <- matrix (NA, length (try.speeds), 3)

  for (i in seq (along=try.speeds)) {
    fn <- sprintf ("speed-errors-s%d",i)
    tit <- sprintf ("speed %f h-refine",  try.speeds[i]);

    plot.error.field(fn, tit, ref)
    plot.error.field(paste (fn, ".xerror", sep=""), tit, ref)

    tab <- read.table (fn)

    avg.max.errs[i,1] <- try.speeds [i]
    avg.max.errs[i,2] <- 10^3 * mean (tab[,3])
    avg.max.errs[i,3] <- 10^3 * max (tab[,3])
  }
  cat ("\n\nInsertion speed dependencies\n")
  cat ("avg error [mm]&max error [mm]")
  mat.to.latex.table (avg.max.errs)
}

insertion.experiment <- function(u, r ,  ml)
{
  calc.insert.reference.solution (u, r)
}

################################################################
# Speed  measurements
################################################################

# todo.

cpu.speed.experiment <- function(u, r)
{
  log.message ('Timing experiment')
  insertion.cmd <- sprintf ('%s -oauto-insert-depth=0.08 -Sauto-insert -ofix-planes=bottom -oauto-insert-y=%g -oouter-loop-tolerance=%g',
                            binary, central.insert.y, 0.03)

  speed.tab <- matrix (NA, length (try.speeds), 6)
  for (i in seq (along =try.speeds)) {
    s <-  try.speeds[i]
    cat (s)
    cat (insertion.cmd)
    c <- sprintf ("%s -oauto-insert-speed=%e -oinitial-h=%g -orefinement-h=%g", insertion.cmd, s, calc.h (u), calc.h (r))

    my.system (c)
    stats <- read.table ('speed-stats.txt')

    speed.tab[i,1] <- s
    speed.tab[i,2] <- stats[1, 1]
    speed.tab[i,3] <- stats[1, 2]
    speed.tab[i,4] <- stats[1, 2] / stats[1, 1]
    speed.tab[i,5] <- stats[1, 3] / stats[1, 2]
    speed.tab[i,6] <- stats[1, 4]
  }

  cat ("time [s]&iterations&update freq [Hz]&avg CG iters&max CG iters\n")
  mat.to.latex.table (speed.tab)
}

################################################################
#  Node relocation (first try)
################################################################

relocation.experiment <-  function (max.level) {
  log.message ('relocation error analysis')

  relocate.cmd <- '%s -Sangled-forces -ofix-planes=right -orefinement-h=%g  -oinitial-h=%g -oauto-insert-y=0.05 -oauto-insert-angle=10 -oauto-insert-depth=0.08 -oouter-loop-tolerance=%g '
  tol <-  1e-4
  c <- sprintf(relocate.cmd, binary, calc.h(max.level), calc.h(max.level),
                tol)

  my.system (c)
  my.system ('mv needle-deformation.state angled-deformation-reference.state')
  my.system ('mv iteration-statistics.txt reloc-no-reloc-stats.txt')

  c <- paste (c,  ' -orelocate-nodes=yes')
  my.system (c)
  between.fine <- 10^3 * file.mean.max ("error-plot")

  my.system ('mv iteration-statistics.txt reloc-with-reloc-stats.txt')
  my.system ('mv error-plot relocate-error-between-fine-grid')

  ################
  coarse.ref.level <- max.level -1
  coarse.level <- 3
  coarse.h <- calc.h  (coarse.level)
  coarse.ref.h <- calc.h (coarse.ref.level)

  c <- sprintf(relocate.cmd, binary, coarse.ref.h,coarse.h,
               tol)

  c <- paste (c,  ' -oprint-mesh=yes -orelocate-nodes=yes')
  my.system (c)
  coarse.reloc.errors <- 10^3 * file.mean.max ("error-plot")

  my.system ('mv iteration-statistics.txt reloc-coarse-with-reloc-stats.txt')
  my.system ('mv error-plot relocate-error-coarse-with-relocate')
  my.system ('mv deformed-mesh.eps angled-insert-relocate.eps')

  ################
  c <- paste (c,  ' -orelocate-nodes=no')
  my.system (c)
  coarse.hwn.errors <- 10^3*file.mean.max ("error-plot")
  my.system ('mv error-plot relocate-error-coarse-no-relocate')
  my.system ('mv iteration-statistics.txt reloc-coarse-no-reloc-stats.txt')
  my.system ('mv deformed-mesh.eps angled-insert.eps')
  my.system ('mv needle-deformation.state angled-deformation-reference.state')

  c <- paste (c,  ' -orelocate-nodes=yes')
  my.system (c)
  between.coarse <- 10^3 * file.mean.max ("error-plot")

  #

  ################
  log.message ("Relocation errors");
  cat (sprintf ("With relocation, |fine_{reloc} - fine_{hwn}|  %g&  %g\n",
                between.fine[1], between.fine[2]))
  cat (sprintf ("With relocation, |coarse_{reloc} - fine_{hwn}|  %g&  %g\n",
                coarse.reloc.errors[1], coarse.reloc.errors[2]))
  cat (sprintf ("Without relocation, |coarse_{hwn} - fine_{hwn}|  %g&  %g\n",
                coarse.hwn.errors[1], coarse.hwn.errors[2]))
  cat (sprintf ("Between coarse, |coarse_{hwn} - coarse_{reloc}|  %g&  %g\n",
                between.coarse[1], between.coarse[2]))

  h.descr <- sprintf ("h%d/h%d", as.integer (coarse.ref.level), as.integer (coarse.level))

  plot.error.field  ("relocate-error-coarse-with-relocate",
                     paste ("Error with relocation", h.descr),
                     max.level
                     )

  plot.error.field  ("relocate-error-coarse-no-relocate",
                     paste ("Error without relocation", h.descr),
                     max.level
                     )

  plot.error.field  ("relocate-error-between-fine-grid",
                     sprintf ("Difference between with and without relocation (h%d/h%d)",
                              as.integer (max.level),as.integer (max.level)),
                     max.level
                     )

}

################################################################
# material linearity.
################################################################

nonlinearity.experiment <- function ()  {

  ref.level <- 6
  unif.level <- 3

  nl.cmd <- '%s -Sauto-insert -ofix-planes=right -orefinement-h=%g  -oinitial-h=%g -oauto-insert-y=0.07 -oauto-insert-angle=0 -oauto-insert-speed=0.01 -oauto-insert-depth=0.12 -oouter-loop-tolerance=%g -ofix-planes=bottom -opoisson=0.0'
  tol <-  1e-2
  c <- sprintf(nl.cmd, binary, calc.h (ref.level), calc.h (unif.level),
               tol)

  ## Venant-Kirchoff elasticity has the tendency to hang the simulation, Probably
  ## element inversion is some kind of buckling where K(u) is non-invertible.
  ## Then relaxation does not converge.

  # c.1 <- paste (c, " -oelasticity=nonlinear ")
  #my.system (c.1)
  #my.system ('mv deformed-mesh.eps nonlinear-mesh.eps')
  #Amy.system ('mv reference-mesh.eps nonlinear-ref-mesh.eps')

  c.1 <- paste (c, " -oelasticity=neohooke -orelaxation-type=nonlinear ")
  my.system (c.1)
  my.system ('mv deformed-mesh.eps neohooke-mesh.eps')
  my.system ('mv reference-mesh.eps neohooke-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps neohooke-boundary.eps')
  my.system ('mv reference-boundary.eps neohooke-ref-boundary.eps')

  c.1 <- paste (c, " -oelasticity=consistent-veronda -orelaxation-type=nonlinear ")
  my.system (c.1)
  my.system ('mv deformed-mesh.eps consistent-vw-mesh.eps')
  my.system ('mv reference-mesh.eps consistent-vw-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps consistent-vw-boundary.eps')
  my.system ('mv reference-boundary.eps consistent-vw-ref-boundary.eps')

  c.2 <- paste (c, " -oelasticity=linear ")
  my.system (c.2)
  my.system ('mv deformed-mesh.eps linear-mesh.eps')
  my.system ('mv reference-mesh.eps linear-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps linear-boundary.eps')
  my.system ('mv reference-boundary.eps linear-ref-boundary.eps')

  c.2 <- paste (c, " -oelasticity=neohooke -orefinement-h=0.003125 -oinitial-h=0.025 ")
  my.system (c.2)
  my.system ('mv deformed-mesh.eps needle-nh-coarse-mesh.eps')
  my.system ('mv reference-mesh.eps needle-nh-coarse-ref-mesh.eps')
  my.system ('mv deformed-boundary.eps needle-nh-coarse-boundary.eps')
  my.system ('mv reference-boundary.eps needle-nh-coarse-ref-boundary.eps')
}

################################################################
# misc examples
################################################################

force.distribution.graph <-  function() {
  my.system (paste (binary , '-Sgraph-friction '))

  fr <-  read.table ("force-graph.txt")
  fr[,1] = max(fr[,1]) - fr[,1]

  postscript (file = 'needle-friction-graph.eps',
              paper = "special",
              width = 6, height=4,
              horizontal = FALSE)
  plot (fr[,1], fr[,2], ylab = 'Friction force [N/m]',
        xlab = 'Coordinate along needle [m]',
        type = 'l')
  dev.off()
}

bisection.example <-  function( )
  {
    append.point <- function(nm) {
      f <- file (nm, "a")
      cat ("\n0.0702 0.0351  0.0015 0 360 arc closepath  fill \n ", file = f)
      close (f)
    }

    my.system (paste(binary, " -Sshow-refinement"))
    for (i in 0:9) {
      append.point (sprintf ("maubach-refinement-%d.eps", i))
    }
    append.point (sprintf ("maubach-no-refinement.eps", i))
  }

################################################################
# all experiments
################################################################

everything <- function (ml) {
  my.system ('make conf=barespeed')

  out.dir <- 'experiments'
  oldwd <- getwd()
  setwd (out.dir)

  ################
  # put the newest at the top, since that is changed most often.
  nonlinearity.experiment ()
  static.experiments (ml)

  cpu.speed.experiment (3,7)
  cpu.speed.experiment (3,6)

  relocation.experiment (ml)

  insertion.experiment(3,6,6)

  tolerance.experiment (ml)

  ####

  bisection.example()
  force.distribution.graph ()

  setwd (oldwd)
}


# load data
obs <- read.csv("../data/adjmatrix-sample.csv",header=T)
obs[is.na(obs)] <- 0
users <- read.csv("../data/nodeattr-sample.csv",header=T)
obs.ext <- merge(obs,users,by="caseid")

# MALE case
obs.male <- obs.ext[which(obs.ext$female==0),2:12]
names(obs.male) <- gsub("use","",names(obs.male))

# build male network
require(igraph)
g.m <- graph.incidence(obs.male,mode="all")
summary(g.m)

# degree distributions
deg_users.m<-degree(g.m)[V(g.m)$type==FALSE]
png('../output/user_degree_male.png',width=500,height=300)
hist(deg_users.m,col="#1f78b4",xlab="Number of SNS per male user",ylab="Frequency",main="")
dev.off()
pdf('../output/user_degree_male.pdf',width=5,height=3)
hist(deg_users.m,col="#1f78b4",xlab="Number of SNS per male user",ylab="Frequency",main="")
dev.off()
deg_sns.m<-degree(g.m)[V(g.m)$type==TRUE]
png('../output/sns_degree_male.png',width=500,height=300)
hist(deg_sns.m,col="#1a9641",xlab="Number of male users per SNS",ylab="Frequency",main="",breaks=14)
dev.off()
pdf('../output/sns_degree_male.pdf',width=5,height=3)
hist(deg_sns.m,col="#1a9641",xlab="Number of male users per SNS",ylab="Frequency",main="",breaks=14)
dev.off()

# compute common neighbors
m <- as.matrix(obs.male)
m_cn <- t(m) %*% m
for (i in 1:nrow(m_cn)) {
  m_cn[i,i] <- 0
}

# compute cosine
degrees <- degree(g.m, v=V(g.m)[V(g.m)$type==TRUE])
degpairs <- degrees %*% t(degrees)
degpairs[degpairs==0] <- 1
m_cos <- m_cn/sqrt(degpairs)

# build projection graph
g_proj.m <- graph.adjacency(m_cos, mode="undirected", weighted=TRUE)
summary(g_proj.m)

# map weights to colors
rbPal <- colorRampPalette(c('gray20','black'))
E(g_proj.m)$color <- rbPal(10)[as.numeric(cut(E(g_proj.m)$weight,breaks=10))]
E(g_proj.m)$thickness <- as.numeric(cut(E(g_proj.m)$weight,breaks=10))

# export projection graph
write.graph(g_proj.m,"../output/sns-associations-male.graphml",format="graphml")

# export projections at different thresholds
hist(E(g_proj.m)$weight)
thr <- c(.3,.4,.5,.6)
for (t in thr) {
  thresholded_graph <- delete.edges(g_proj.m, E(g_proj.m)[E(g_proj.m)$weight<t])
  thresholded_graph <- delete.vertices(thresholded_graph, V(thresholded_graph)[degree(thresholded_graph)==0])
  summary(thresholded_graph)

  write.graph(thresholded_graph,paste("../output/sns-associations-male_thr",t,".graphml",sep=""),format="graphml")
}

#E(g_proj.m)[order(-E(g_proj.m)$weight)]
top.m <- as.data.frame(cbind(get.edgelist(g_proj.m),round(E(g_proj.m)$weight,2)))
names(top.m) <- c("SNS1","SNS2","cosine.association")
top.m <- top.m[order(top.m$cosine.association,decreasing=T),]
revtop.m <- top.m[order(top.m$cosine.association,decreasing=F),]
revtop.m[!(revtop.m$SNS1%in%c("myspace","flickr","googleplus")|revtop.m$SNS2%in%c("myspace","flickr","googleplus")),]

# export top network
g2 <- delete.edges(g_proj.m,E(g_proj.m)[!weight%in%tail(sort(E(g_proj.m)$weight),10)])
iso <- V(g2)[degree(g2)==0]
g2 <- delete.vertices(g2,iso)
summary(g2)
rbPal <- colorRampPalette(c('gray80','gray0'))
E(g2)$color <- rbPal(10)[as.numeric(cut(E(g2)$weight,breaks = 10))]
E(g2)$normalized <- round(1+(4/(max(E(g2)$weight)-min(E(g2)$weight))*(E(g2)$weight-min(E(g2)$weight))))
E(g2)$weight <- round(E(g2)$weight,2)

# export projection graph
write.graph(g2,"../output/sns-associations-male-top10.graphml",format="graphml")

# store data for legend
d_legend <- head(top.m,10)

top10 <- head(top.m,10)
library(gridExtra)
library(ggplot2)
rbPal <- colorRampPalette(c('gray80','gray0'))
g_legend <- function(a.gplot){
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  legend
}
top10$cosine.association <- as.numeric(as.character(top10$cosine.association))
top10$color <- rbPal(10)[as.numeric(cut(top10$cosine.association,breaks=10))]
top10 <- top10[order(-top10$cosine.association),]
p1 <- ggplot(top10,aes(SNS1,SNS2)) + geom_raster(aes(fill=as.factor(top10$cosine.association))) +
  scale_fill_manual(values=rev(top10$color),breaks=top10$cosine.association,name="Cosine\nsimilarity")
legend <- g_legend(p1)
pdf('../output/legend-sns-associations-male-top10.pdf',width=1,height=3)
grid.arrange(legend,ncol=1,nrow=1,widths=c(1/6))
dev.off()

# FEMALE case
obs.female <- obs.ext[which(obs.ext$female==1),2:12]
names(obs.female) <- gsub("use","",names(obs.female))

# build male network
require(igraph)
g.f <- graph.incidence(obs.female,mode="all")
summary(g.f)

# degree distributions
deg_users.f<-degree(g.f)[V(g.f)$type==FALSE]
png('../output/user_degree_female.png',width=500,height=300)
hist(deg_users.f,col="#1f78b4",xlab="Number of SNS per female user",ylab="Frequency",main="")
dev.off()
pdf('../output/user_degree_female.pdf',width=5,height=3)
hist(deg_users.f,col="#1f78b4",xlab="Number of SNS per female user",ylab="Frequency",main="")
dev.off()
deg_sns.f<-degree(g.f)[V(g.f)$type==TRUE]
png('../output/sns_degree_female.png',width=500,height=300)
hist(deg_sns.f,col="#1a9641",xlab="Number of female users per SNS",ylab="Frequency",main="",breaks=14)
dev.off()
pdf('../output/sns_degree_female.pdf',width=5,height=3)
hist(deg_sns.f,col="#1a9641",xlab="Number of female users per SNS",ylab="Frequency",main="",breaks=14)
dev.off()

# compute common neighbors
m <- as.matrix(obs.female)
m_cn <- t(m) %*% m
for (i in 1:nrow(m_cn)) {
  m_cn[i,i] <- 0
}

# compute cosine
degrees <- degree(g.f, v=V(g.f)[V(g.f)$type==TRUE])
degpairs <- degrees %*% t(degrees)
degpairs[degpairs==0] <- 1
m_cos <- m_cn/sqrt(degpairs)

# build projection graph
g_proj.f <- graph.adjacency(m_cos, mode="undirected", weighted=TRUE)
summary(g_proj.f)

# map weights to colors
rbPal <- colorRampPalette(c('gray20','black'))
E(g_proj.f)$color <- rbPal(10)[as.numeric(cut(E(g_proj.f)$weight,breaks=10))]
E(g_proj.f)$thickness <- as.numeric(cut(E(g_proj.f)$weight,breaks=10))

# export projection graph
write.graph(g_proj.f,"../output/sns-associations-female.graphml",format="graphml")

# export projections at different thresholds
hist(E(g_proj.f)$weight)
thr <- c(.3,.4,.5,.6)
for (t in thr) {
  thresholded_graph <- delete.edges(g_proj.f, E(g_proj.f)[E(g_proj.f)$weight<t])
  thresholded_graph <- delete.vertices(thresholded_graph, V(thresholded_graph)[degree(thresholded_graph)==0])
  summary(thresholded_graph)

  write.graph(thresholded_graph,paste("../output/sns-associations-female_thr",t,".graphml",sep=""),format="graphml")
}

#E(g_proj.f) <- E(g_proj.f)[order(-E(g_proj.f)$weight)]
top.f <- as.data.frame(cbind(get.edgelist(g_proj.f),round(E(g_proj.f)$weight,2)))
names(top.f) <- c("SNS1","SNS2","cosine.association")
top.f <- top.f[order(top.f$cosine.association,decreasing=T),]
revtop.f <- top.f[order(top.f$cosine.association,decreasing=F),]
revtop.f[!(revtop.f$SNS1%in%c("myspace","flickr","googleplus")|revtop.f$SNS2%in%c("myspace","flickr","googleplus")),]

#plot(g_proj,layout=layout.auto(g_proj),edge.width=E(g_proj)$weight)

g2 <- delete.edges(g_proj.f,E(g_proj.f)[!weight%in%tail(sort(E(g_proj.f)$weight),10)])
iso <- V(g2)[degree(g2)==0]
g2 <- delete.vertices(g2,iso)
summary(g2)
rbPal <- colorRampPalette(c('gray80','gray0'))
E(g2)$color <- rbPal(10)[as.numeric(cut(E(g2)$weight,breaks = 10))]
E(g2)$normalized <- round(1+(4/(max(E(g2)$weight)-min(E(g2)$weight))*(E(g2)$weight-min(E(g2)$weight))))
E(g2)$weight <- round(E(g2)$weight,2)

# export projection graph
write.graph(g2,"../output/sns-associations-female-top10.graphml",format="graphml")

# store data for legend
d_legend <- rbind(d_legend,head(top.f,10))
write.csv(d_legend,"../output/links-gender-for-legend.csv")

top10 <- head(top.f,10)
library(gridExtra)
library(ggplot2)
rbPal <- colorRampPalette(c('gray80','gray0'))
g_legend <- function(a.gplot){
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  legend
}
top10$cosine.association <- as.numeric(as.character(top10$cosine.association))
top10$color <- rbPal(10)[as.numeric(cut(top10$cosine.association,breaks=10))]
top10 <- top10[order(-top10$cosine.association),]
p1 <- ggplot(top10,aes(SNS1,SNS2)) + geom_raster(aes(fill=as.factor(top10$cosine.association))) +
  scale_fill_manual(values=rev(top10$color),breaks=top10$cosine.association,name="Cosine\nsimilarity")
legend <- g_legend(p1)
pdf('../output/legend-sns-associations-female-top10.pdf',width=1,height=3)
grid.arrange(legend,ncol=1,nrow=1,widths=c(1/6))
dev.off()

t <- merge(top.f,top.m,by=c("SNS1","SNS2"))
t$cosine.association.x <- as.numeric(as.character(t$cosine.association.x))
t$cosine.association.y <- as.numeric(as.character(t$cosine.association.y))
library(ggplot2)
d <- t[which(abs(t$cosine.association.x-t$cosine.association.y)>0.13),]
p <- ggplot(t,aes(x=t$cosine.association.x,y=t$cosine.association.y)) + geom_point() +
  geom_abline(intercept=0,slope=1,linetype="dotted") + theme_bw() +
  xlab("Associations for females") + ylab("Associations for males") + xlim(0,1) + ylim(0,1) +
  annotate("text",x=d$cosine.association.x,y=d$cosine.association.y,
           label=paste(d$SNS1,"-",d$SNS2,sep=),size=3)
ggsave("../output/genderdiff.pdf",width=5,height=5)


h <- c(-8,-9,-3,-1,-6,7)
f <- c(-3,-6,-1,8,-6,3,-1,-9,-9,3,-2,5,2,-2,-7,-1)
g <- c(24,75,71,-34,3,22,-45,23,245,25,52,25,-67,-96,96,31,55,36,29,-43,-7)

max(abs(conv(f,h) - g))
max(abs(deconv(g,f) - h))
max(abs(deconv(g,h) - f))


genUrgency = function(x, intercept)
{
  lambda = 0.126
  k = 2.27
  y = intercept + 10*(1-exp(-(x/lambda)^k))
  y
}

x = seq(0,1,0.001)
output = matrix(ncol=5, nrow=length(x))
for(i in seq(1,5))
{
  output[,i] = genUrgency(x, runif(1));
}

df = data.frame(output)
p1 = ggplot(data=df, aes(x=x)) + geom_line(aes(y=y1)) + theme_minimal()
p1 = p1 + geom_line(aes(y=y2))
show(p1)


################################################################################
# Monte Carlo Simulation and Resampling Methods in Social Science              #
# Thomas M. Carsey and Jeffrey J. Harden                                       #
# Chapter 6 File (Parallel Processing 2 of 2)                                  #
# Last update: 1/31/13                                                         #
################################################################################

# Negative Binomial vs. Zero-Inflated Negative Binomial (parallel processing)
library(pscl)
library(snow)
library(doSNOW)
library(foreach)

cl.tmp <- makeCluster(4)
registerDoSNOW(cl.tmp)

# Zero-inflated negative binomial random number generator
rzinbinom <- function(n, mu, size, zprob){
ifelse(runif(n) < zprob, 0, rnbinom(n, size = size, mu = mu))
}

# Simulation function
zinb.sim <- function(n = 1000){
require(pscl)
par.est.zinb <- matrix(NA, nrow = 1, ncol = 4) # Empty matrix to store the
                                               # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

# Generate data with a zero-inflation component
Y.zi <- rzinbinom(n, mu = exp(b0 + b1*X), size = .5,
zprob = exp(b0 + b1*X)/(1 + exp(b0 + b1*X)))
# Generate data with no zero-inflation component
Y.nozi <- rzinbinom(n, mu = exp(b0 + b1*X), size = .5, zprob = 0)
model.nb1 <- glm.nb(Y.zi ~ X) # Standard negative binomial
model.nb2 <- glm.nb(Y.nozi ~ X)
model.zinb1 <- zeroinfl(Y.zi ~ X | X, dist = "negbin") # Zero-inflated model
model.zinb2 <- zeroinfl(Y.nozi ~ X | X, dist = "negbin")
# Store the estimates of the coefficient on X (count equation)
par.est.zinb[ , 1] <- model.nb1$coef[2] # Standard NB, with ZI
par.est.zinb[ , 2] <- model.nb2$coef[2] # Standard NB, no ZI
par.est.zinb[ , 3] <- as.numeric(model.zinb1$coef$count[2]) # ZI NB, with ZI
par.est.zinb[ , 4] <- as.numeric(model.zinb2$coef$count[2]) # ZI NB, no ZI
return(par.est.zinb)
}

# Parallel Processing
set.seed(2837) # Set the seed for reproducible results
reps <- 1000 # Set the number of repetitions

start.time <- Sys.time()
results <- foreach(i = 1:reps, .combine = rbind) %dopar% {
zinb.sim(n = 1000)
}

end.time <- Sys.time()
end.time - start.time


#' rollPlot rolling plotting function
#'
#' This function orders and bins a variable in to groups defined by a window
#' and step size then computes rolling averages for multipe variables across each bin.
#' @param t Table of data.
#' @param x Variable to be binned on x-axis.
#' @param y Vector of variables to plot on y-axis.
#' @param ylab Label for Y-axis. Defaults to "variable".
#' @param xlab Label for X-axis.
#' @param w Window size (number of values per bin). Defaults to 400.
#' @param s Step size (number of values to move along for each bin). Defaults to 80.
#' @param f Function to apply to y values for each bin ("mean","median","sum"). Defaults to "mean".
#' @param scale Scale the x-axis ("linear"=linear spacing of points based value of bin or "bins"=equal spacing between all bins). Defaults to "linear".
#' @param feature Name of features being binned. Defaults to "data points".
#' @param data Returns a table in long form if set to True.
#' @param samples Set the legend name. Defaults to "Samples".
#' @param labels Set the labels for samples.
#' @param split Plot samples separately.
#' @param splitscale Scales for split plots "fixed"(default),"free",free_x","free_y".
#' @param facet Variable to facet by.
#' @param sd Plot standard deviation as ribbon when plotting mean.
#' @param points Plot points at each data position
#' @keywords bin average plots.
#' @export
#' @examples
#' rollPlot()

rollPlot<-function (t, x, y, ylab = "", xlab = "", w = 400, s = 80, f = "mean",
                    scale = "linear", feature = "data points", data = F, samples = "Samples",
                    split = F, sd = F, cols = vector(), facet = NA, splitscale = "fixed",
                    points = F, labels = vector())
{
  library(zoo)
  library(ggplot2)
  library(egg)
  library(reshape2)
  library(viridis)
  library(plyr)

  ##Set labels for samples
  if (length(labels) == 0) {
    labels = y
  }
  rep = F
  ##If X value also appears in Y
  if (x %in% y) {
    rep = T
    tt <- t[,y]
  }
  else{
    tt <- t[, c(x, y)]
  }
  l <- dim(tt)[1]

  ##Order by X value and apply rolling function
  ts <- tt[order(tt[, x]), ]
  tr <- as.data.frame(rollapply(ts, FUN = f, width = w, by = s,
                                align = "center", na.rm = T))
  ##Set indexes for bin plots or xvalues for linear plots then melt
  tr$idx <- row.names(tr)
  if (rep) {
    tr$xval <- tr[, x]
    m <- melt(tr, id.vars = c("xval", "idx"))
  }
  else{
    m <- melt(tr, id.vars = c(x, "idx"))
  }
  ##set labels
  m$variable <- factor(m$variable, levels = y)
  m$variable <- mapvalues(m$variable, from = y, to = labels)
  m$idx <- as.numeric(as.character(m$idx))
  names(m)[1] <- "xval"

  ##repeat for SD calculation if set
  if (f == "mean" & sd) {
    sr <- as.data.frame(rollapply(ts, FUN = sd, width = w,
                                  by = s, align = "center", na.rm = T))
    sr$idx <- row.names(sr)
    if (rep) {
      sr$xval <- sr[, x]
      ms <- melt(sr, id.vars = c("xval", "idx"))
    }
    else {
      ms <- melt(sr, id.vars = c(x, "idx"))
    }
    ms$variable <- factor(ms$variable, levels = y)
    ms$variable <- mapvalues(ms$variable, from = y, to = labels)
    ms$idx <- as.numeric(as.character(ms$idx))
    names(ms)[1] <- "xval"
  }
  ##return melted dfs
  if (data) {
    if (sd & f == "mean") {
      return(list(a = m, sd = ms))
    }
    else {
      return(m)
    }
  }
  ##linear plot
  if (scale != "bins") {
    p <- ggplot(m, aes_string("xval", "value", colour = "variable"))
    if (sd & f == "mean") {
      p <- p + geom_ribbon(aes(ymin = value - ms$value,
                               ymax = value + ms$value, fill = variable), alpha = 0.5,
                           colour = NA)
      if (length(cols) == 0) {
        p <- p + scale_fill_viridis(discrete = T, guide = F)
      }
      else {
        p <- p + scale_fill_manual(values = cols)
      }
    }
    if (points) {
      p <- p + geom_point(size = 2)
    }
    else {
      p <- p + geom_line(size = 2)
    }
    if (!feature=="NULL"){
        p <- p + ggtitle(paste(l, feature))
    }
    p <- p + theme_bw()
    if (scale == "log") {
      p <- p + scale_x_log10()
    }
    if (xlab != "") {
      p <- p + xlab(xlab)
    }
    else {
      p <- p + xlab(x)
    }
  }
  ##binned plot
  else {
    p <- ggplot(m, aes(x = idx, y = value, colour = variable,
                       group = variable))
    if (sd & f == "mean") {
      p <- p + geom_ribbon(aes(ymin = value - ms$value,
                               ymax = value + ms$value, fill = variable), alpha = 0.5,
                           colour = NA)
      if (length(cols) == 0) {
        p <- p + scale_fill_viridis(discrete = T, guide = F)
      }
      else {
        p <- p + scale_fill_manual(values = cols)
      }
    }
    if (points) {
      p <- p + geom_point(size = 2)
    }
    else {
      p <- p + geom_line(size = 2)
    }
    if(!feature=="NULL"){
        p <- p + ggtitle(paste(l, feature))
    }
    p <- p + theme_bw()
  }

  if (ylab != "") {
    p <- p + ylab(ylab)
  }
  if (xlab != "") {
      p <- p + xlab(xlab)
  }
  else {
      p <- p + xlab(paste(x,"index"))
  }
  if (length(cols) == 0) {
    p <- p + scale_color_viridis(discrete = T, name = samples)
  }
  else {
     p <- p + scale_color_manual(values = cols, name = samples)
  }
  if (split) {
    p <- p + facet_wrap(~variable, scales = splitscale)
  }
  p
}


# Propiedades numéricas del OLS, Gauss-Markov, sesgo de variable omitida
#################################################################
cat("\014")
rm(list=ls())
graphics.off()

#################################################################
# Motivacion
#################################################################

# Ademas de trabajar con incertidumbre (intervalos de confianza, p-values, etc.),
# la estadistica inferencial (lo que estamos haciendo este semestre)
# descansa sobre supuestos muy importantes.

# Es importante conocer estos supuestos. Te daras cuenta que
# la principal herramienta cuantitativa de las ciencias sociales
# tiene muchos defectos y/o supuestos irreales. En consecuencia, siempre
# actua con prudencia y humildad respecto a tus resultados.

#################################################################
# Supuestos de los modelos lineales
#################################################################

# (1) El error tiene promedio cero: por eso SIEMPRE calcula los errores y plotealos.
# (2) El error tiene varianza constante: idem.
# (3) El error no esta correlacionado (los errores son independientes entre si): idem.
# (4) El error esta normalmente distribiuido: idem.
# (5) Las X's estan medidas sin error, y son independientes del error.
# (6) Las X's no son invariables, es decir, las X's son variables, no constantes.

# (*) Punto sobre la diferencia entre ERROR y RESIDUO:
## recuerda que y = b0 + b1x1 + e.
## Ese "e" en realidad, es un residuo, no "error". "Parametro de poblacion."

#################################################################
# Teorema de Gauss-Markov
#################################################################

# el fundamento matematico de OLS (modelos lineales), es el
# Teorema de Gauss-Markov.

# Consiste en lo siguiente: si
## (a) el error tiene promedio cero, y
## (b) si el error esta normalmente distribuido, y
## (c) si el error tiene varianza constante,
# entonces nuestros betas son los estimadores mas eficientes y sin sesgo.

# En ingles, es conocido como "BLUE": "best linear unbiased estimator".

# En otras palabras, cuando todos los supuestos funcionan,
# la diferencia entre la MATRIZ QUE CONTIENE TODOS LOS BETAS CORRECTOS,
# Y LA MATRIZ QUE NOSOTROS TENEMOS ACCESO (O POODEMOS OCUPAR) ES CERO.

# (1) Punto del modelo "real" ("true model").
# (2) Punto del epsilon (error) y la letra "e" (residuo).
# (3) Punto del beta y la letra "b".

# Son diferencias filosoficas. Importantes...pero filosoficas.

# Que puede salir mal?
## Ej.: los errores no son independientes; es decir, son dependientes.
### Caso de las series de tiempo.

#################################################################
# Sesgo de Variable Omitida: "omitted variable bias"
#################################################################

# Todos los supuestos de OLS operan bajo otro supuesto: el modelo que
# estimamos, es el "verdadero modelo". Es decir, no se nos queda ninguna
# variable afuera: i.e., todas las variables que debieramos ocupar, estan
# consideradas. Si esto falla, todo falla, y tenemos "el sesgo de la variable
# omitida".

# Mal que mal, OLS es una ecuacion, y el valor de los betas cambiara si es que
# no incluimos todas las variables que debieramos incluir.

## ILUSTRAR EN LA PIZARRA.

# Para demostrar este punto, simularemos (inventaremos) unos datos.

# Inventemos las variables independientes
set.seed(2020)
x1 = rnorm(1000, mean=0, sd=1) # como nunca, conocemos que el promedio REAL de esta variable es 0
x2 = rnorm(1000, mean=2, sd=2) # como nunca, conocemos que el promedio REAL de esta variable es 2
x3 = rnorm(1000, mean=1, sd=3) # como nunca, conocemos que el promedio REAL de esta variable es 1
x4 = x1*x2

# Definamos que, como debiera ser, el error tiene promedio cero.
e = rnorm(1000, 0)

# Establecer el valor real de los betas: conocemos con exactitud los valores,
# porque nosotros los creamos!
b1 = 1
b2 = -1
b3 = 5
b4 = -2

# El "VERDADERO MODELO": "y" es una combinacion lineal de todas las variables.
y = b1*x1 + b2*x2 + b3*x3 + b4*x4 + e # true model

hist(y)

# Hagamos una regresion.
modelo.completo = lm(y ~ x1 + x2 + x3 + x4)
summary(modelo.completo) # sin sorpresa, los betas son los mismos que inventamos nosotros.

# (1) La tabla de "Residuals" dice que la mediana es 0. Eso es genial. Pero sin sorpresas, nosotros inventamos todo, asi que obvio que resulta bien.
# (2) Plotiemos los errores

plot(modelo.completo$fitted.values, modelo.completo$residuals)

# Perfecto! No notamos ningun patron.
# Es decir, vemos una nube desordenada de puntos.
# Aqui es cuando VEMOS lo que asumimos: los errores se cancelan entre si.

# Variable Omitida: Que pasa con nuestros coeficientes cuando se nos quedan dos
# variables afuera?

modelo.segado = lm(y ~ x1)

summary(modelo.segado) # Ya los resultados son muy diferentes.

# (1) Mediana de los residuos?
# (2) Plotiemos los errores?

plot(modelo.segado$fitted.values, modelo.segado$residuals)

# Promediemos el error
options(scipen = 1000000) # apagar notacion cientifica.
mean(modelo.segado$residuals)

# Que vemos aqui?
# Que implica?

#################################################################
# Atencion
#################################################################

# Lo peor de todo, es que nunca sabras si te faltan variables o no.
# Es por esto que lo que guia el proceso de anadir/remover variables, es
# teoria. Es un proceso casi artistico.


xz <- function(n, a) {
  while (a > 0) {
    if (a %% 2 == 0) {
      if (n > 0) {
        n <- n - 1
      } else {
        return(FALSE)
      }
    }
    a <- a %/% 2
  }
  n == 0
}

cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  t <- sapply(strsplit(s, " ")[[1]], as.integer)
  r <- 0
  for (i in 2^(t[1]-1):t[2]) {
    if (xz(t[1], i)) {
      r <- r + 1
    }
  }
  r
}), sep="\n")


## Difference that maintains original array size by appending a row

.fdiff <- function(X) rbind(diff(X), rep(NA,ncol(X)))

## Ghiglia and Pritt's wrap operator. Thanks to Steve K.

wrap <- function(phase) (phase+pi)%%(2*pi) - pi

## Calculate residue map
## A "positive" charged residue has value +1
## A "negative" charge has value -1

rmap <- function(phase, dx=NULL, dy=NULL, plot=FALSE, ...) {
  nr <- nrow(phase)
  nc <- ncol(phase)

  if (is.null(dx)) {
    dx <- wrap(.fdiff(phase))
  }
  if (is.null(dy)) {
    dy <- wrap(t(.fdiff(t(phase))))
  }
  d2y <- rbind(dy[1:(nr-1),]-dy[2:nr,],rep(NA,nc))
  d2x <- cbind(dx[,2:nc]-dx[,1:(nc-1)],rep(NA,nr))
  residues <- round((d2y+d2x)/(2*pi))
  if (plot) {
    ## positive charges
    chp <- which(residues ==1, arr.ind=TRUE)
    ## negative charges
    chm <- which(residues == -1, arr.ind=TRUE)
    image(1:nr, 1:nc, phase, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE, ...)
    if(length(chp)>0) {
      points(chp, col="green", pch=20)
    }
    if(length(chm)>0) {
      points(chm, col="red", pch=20)
    }
    nr <- sum(abs(residues),na.rm=TRUE)
    nr
  } else {
    residues
  }
}

## "Itoh's" method for phase unwrapping.

## integrate the wrapped phase differences
## This is called by brcutpuw, or it can be called
## directly by the user.

## Note: as of July 2020 the unwrapper is written in C++ using Rcpp.
## It's fastest to bypass the computation of dx and dy in R
## and unwrap with a call to id_uw.
## netflowpuw (in lppuw, and at present unsupported) passes values of dx and dy with ucall==TRUE.
## brcutpuw passes dx and dy with ucall==FALSE.
## The call to id_dxy_uw is slower by about 40%.

idiffpuw <- function(phase, mask=phase, ucall=TRUE, dx=NULL, dy=NULL) {

    nr <- nrow(phase)
    nc <- ncol(phase)

    if (ucall) {
        if (is.null(dx)) {
          puw <- id_uw(as.integer(nr), as.integer(nc), as.vector(phase)/(2*pi))
          puw <- matrix(puw, nr, nc)
        } else {
          puw <- id_dxy_uw(as.integer(nr), as.integer(nc), as.vector(phase)/(2*pi),
                           as.vector(mask), as.vector(dx/(2*pi)), as.vector(dy/(2*pi)),
	                   integer(nr*nc))
          puw <- matrix(puw, nr, nc)
        }
        puw[is.na(phase)] <- NA
        class(puw) <- "pupil"
        puw
    } else {
      if (is.null(dx)) dx <- wrap(.fdiff(phase))
      if (is.null(dy)) dy <- wrap(t(.fdiff(t(phase))))
      uw <- integer(nr*nc)
      puw <- id_dxy_uw(as.integer(nr), as.integer(nc), as.vector(phase)/(2*pi),
                       as.vector(mask), as.vector(dx/(2*pi)), as.vector(dy/(2*pi)),
	               uw)
      puw <- matrix(puw, nr, nc)
      puw[is.na(phase)] <- NA
      uw <- matrix(as.logical(uw), nr, nc)
      class(puw) <- "pupil"
      list(puw=2*pi*puw, uw=uw)
    }
}

## Quality guided unwrapper.
## This is mostly a wrapper for a call to the C++ function "q_uw".

qpuw <- function(phase, qual) {
    nr <- nrow(phase)
    nc <- ncol(phase)

    phase <- phase/(2*pi)
    qual[is.na(phase)] <- 0

    puw <- q_uw(as.integer(nr), as.integer(nc), as.vector(phase), as.vector(qual))
    puw <- matrix(puw, nr, nc)
    puw[is.na(phase)] <- NA
    class(puw) <- "pupil"
    puw
}

##
##  Branch cut algorithm.
## This now solves a variant of the assignment problem to minimize
## the total length of all branch cuts.
##
## note: parameter pen is a penalty added to distances from charges to edges.
##         I'm not sure this is really useful. Seems to work fine with the default
##         of 0.
##

brcutpuw <- function(phase, pen=0, details=FALSE) {

    require(clue)

    ## distance between points specified by their x,y coordinates.

    dmat <- function(p1, p2) {
        fn <- function(x,y) abs(y-x)
        xleg <- outer(p1[,1], p2[,1], FUN=fn)
        yleg <- outer(p1[,2], p2[,2], FUN=fn)
        xleg+yleg
    }

    ## Make a branch cut

    brcut <- function(startp, endp, mask) {
        xl <- endp[1]-startp[1]
        yl <- endp[2]-startp[2]
        if (abs(yl) <= abs(xl)) {
            slope <- yl/xl
            ix <- startp[1]:endp[1]
            iy <- startp[2] + round(slope*(ix-startp[1]))
        } else {
            slope <- xl/yl
            iy <- startp[2]:endp[2]
            ix <- startp[1] + round(slope*(iy-startp[2]))
        }
        mask[cbind(ix,iy)] <- NA
        mask
    }

    res <- rmap(phase)
    ## no residues, so a single call to idiffpuw is all we need
    if (sum(abs(res),na.rm=TRUE) == 0) {
        return(idiffpuw(phase,ucall=TRUE))
    }

    nr <- nrow(phase)
    nc <- ncol(phase)
    dx <- wrap(.fdiff(phase))
    dy <- wrap(t(.fdiff(t(phase))))

    mask <- matrix(1,nr,nc)
    mask[is.na(phase)] <- NA

    ## positive charges
    chp <- which(res==1, arr.ind=TRUE)
    ncp <- nrow(chp)
    ## negative charges
    chm <- which(res== -1, arr.ind=TRUE)
    ncm <- nrow(chm)
    ## get the boundary points - ones one pixel outside the area of defined phase.
    ## step in
    ptsb <- which(is.na(phase) & (!is.na(rbind(phase[-1,], rep(NA, nc)))), arr.ind=TRUE)
    ptsb <- rbind(ptsb, which(is.na(phase) & (!is.na(cbind(phase[,-1], rep(NA, nr)))), arr.ind=TRUE))
    ## step out
    ptsc <- which((!is.na(phase)) & is.na(rbind(phase[-1,], rep(NA, nc))), arr.ind=TRUE)
    ptsc[,1] <- ptsc[,1]+1
    ptsb <- rbind(ptsb, ptsc)
    ptsc <- which((!is.na(phase)) & is.na(cbind(phase[,-1], rep(NA, nr))), arr.ind=TRUE)
    ptsc[,2] <- ptsc[,2]+1
    ptsb <- rbind(ptsb, ptsc)

    if ((ncp>0) & (ncm>0)) {

      ## distances between residues
      dpm <- dmat(chp, chm)

      ## distance from each positive charge to nearest edge
      dce <- dmat(chp, ptsb)
      ipb <- apply(dce, 1, which.min)
      dpe <- apply(dce, 1, min)+pen
      pec <- matrix(ptsb[ipb,], ncp, 2)

      ## distance from each negative charge to nearest edge
      dce <- dmat(chm, ptsb)
      ipb <- apply(dce, 1, which.min)
      dme <- apply(dce, 1, min)+pen
      mec <- matrix(ptsb[ipb,], ncm, 2)

      ## cost matrix of assigning p to edge and m to edge for each (p,m). This has the same dimension as dpm
      cost.ec <- outer(dpe, dme, "+")
      isd <- (dpm <= cost.ec)

      ## elementwise minimum of dpm and cost.ec.
      ## Idea is if dpm[p,m] < cost.ec[p,m] we should connect dipole, otherwise connect both to edge
      minc <- pmin(dpm, cost.ec)
      pecuts <- NULL
      mecuts <- NULL

      ## use Hungarian algorithm from package clue to get optimal assigments from p to m.
      ## Then figure out which are dipole cuts and which are edge cuts.
      ## If ncm > ncp there have to be some unassigned m's. Those connect to edge.

      if (ncm >= ncp) {
        yp <- solve_LSAP(minc)
        ass <- cbind(seq_along(yp), as.integer(as.vector(yp)))
        mecuts <- setdiff(1:ncm, ass[,2])
      } else {
        yp <- solve_LSAP(t(minc))
        ass <- cbind(as.integer(as.vector(yp)), seq_along(yp))
        pecuts <- setdiff(1:ncp, ass[,1])
      }
      dpcuts <- matrix(ass[which(isd[ass]),], ncol=2)
      edgecuts <- matrix(ass[which(!isd[ass]),], ncol=2)
      pecuts <- c(pecuts, edgecuts[,1])
      mecuts <- c(mecuts, edgecuts[,2])
      cost.dpcuts <- dpm[dpcuts]
      cost.pe <- dpe[pecuts]
      cost.me <- dme[mecuts]

      if (details) {
        cat(paste(nrow(dpcuts),"dipole connections, total cost =",sum(cost.dpcuts),"\n"))
        cat(paste(length(pecuts),"+ to edge, total cost =",sum(cost.pe),"\n"))
        cat(paste(length(mecuts),"- to edge, total cost =",sum(cost.me),"\n"))
      }

      cutlen <- sum(cost.dpcuts)+sum(cost.pe)+sum(cost.me)

      for (i in seq_along(dpcuts[,1])) {
          startp <- chp[dpcuts[i, 1],]
          endp <- chm[dpcuts[i, 2],]
          mask <- brcut(startp, endp, mask)
      }
      for (i in seq_along(pecuts)) {
          startp <- chp[pecuts[i],]
          endp <- pec[pecuts[i],]
          mask <- brcut(startp, endp, mask)
      }
      for (i in seq_along(mecuts)) {
          startp <- chm[mecuts[i],]
          endp <- mec[mecuts[i],]
          mask <- brcut(startp, endp, mask)
      }
    }
    ## if there are only plus or minus charges connect to nearest edge (should be rare case, but...)
    else if (ncp > 0) {
      ## distance from each positive charge to nearest edge
      dce <- dmat(chp, ptsb)
      ipb <- apply(dce, 1, which.min)
      dpe <- apply(dce, 1, min)+pen
      pe <- matrix(ptsb[ipb,],ncp,2)
      for (i in 1:ncp) {
          startp <- chp[i,]
          endp <- pe[i,]
          mask <- brcut(startp, endp, mask)
      }
    }
    else if (ncm > 0) {
      ## distance from each negative charge to nearest edge
      dce <- dmat(chm, ptsb)
      ipb <- apply(dce, 1, which.min)
      dme <- apply(dce, 1, min)+pen
      me <- matrix(ptsb[ipb,],ncm,2)
      for (i in 1:ncm) {
          startp <- chm[i,]
          endp <- me[i,]
          mask <- brcut(startp, endp, mask)
      }
    }

    ## call idiffpuw to unwrap all unmasked pixels
    uwum <- idiffpuw(phase, mask, ucall=FALSE, dx=dx, dy=dy)
    puw <- uwum$puw
    uw <- uwum$uw
    uw[is.na(phase)] <- NA
    ## fill in whatever was left wrapped
    ## This inverts the logic of fill algorithm in idiffpuw
    ## todo initially contains a list of pixels that haven't been unwrapped
    ## that should be. We look for neighbors that have been unwrapped
    ## and unwrap from them, removing the newly unwrapped pixels from
    ## the todo list.
    ## This should work because branch cuts are just a pixel wide and should
    ## adjoin unmasked regions. It's possible that cuts could completely
    ## enclose an area, in which case it will still be filled
    ## with most likely erroneous values as we fill through the cuts.

    todo <- which(!uw)
    kn <- c(-1, 1, -nr, nr)
    while (length(todo) > 0) {
        for (i in 1:4) {
            b <- todo + kn[i]
            subs <- which(uw[b])
            puw[todo[subs]] <- puw[b[subs]] + switch(i, dx[b[subs]], -dx[todo[subs]],
             dy[b[subs]], -dy[todo[subs]])
            uw[todo[subs]] <- TRUE
            todo <- todo[-subs]
            if (length(todo)==0) break
        }
    }
    if (details) {
        bcuts <- matrix(NA, nr, nc)
        bcuts[is.na(mask) & (!is.na(phase))] <- 1
        list(puw=puw/(2*pi), cutlen=cutlen, bcuts=bcuts,
                    dpm=dpm, dpe=dpe, dme=dme,
                    dpcuts=dpcuts, pecuts=pecuts, mecuts=mecuts,
                    cost.dpcuts=cost.dpcuts, cost.pe=cost.pe, cost.me=cost.me
        )
    } else
        puw/(2*pi)
}


rm(list = ls())
# kevin murphy's book octave to r
library(digest)
library(scales)
#install.packages("scales")
library(ggvis)
library(caret)

library(gmodels)
library(class)
library(reshape2)
library(data.table)
library(dplyr)
library(R.matlab)
library(matlab)
library(plot3D)
library(limSolve)
library(mboost)
library(Boom)
library(animation)
library(Rcpp)

###########  first : animation r package example ##################
ani.options(nmax = 70)
par(mar = c(4, 4, 2, 0.1))
f2 = function(x, y) sin(1 / 2 * x ^ 2 - 1 / 4 * y ^ 2 + 3) * cos(2 * x + 1 -
  exp(y))
grad.desc(f2, c(-2, -2, 2, 2), c(-1, 0.5), gamma = 0.3, tol = 1e-04)
grad.desc(f2, c(-2, -2, 2, 2), c(-1, 0.5), gamma = 0.03, tol = 1e-04)

#%% Visualize steepest descent optimization on a 2d function
#% We try fixed step size, and also line searching.

#% This file is from pmtk3.googlec

# from kevin murphys book
aokiFn = function(x)
{
    if (is.vector(x) == TRUE)
    {
        f = 0.5 %*% (x[1] ^ 2 - x[2]) ^ 2 + 0.5 %*% (x[1] - 1) ^ 2;
    }
    else
    {
        #% each row is a param vector
        f = 0.5 * (x[, 1] ^ 2 - x[, 2]) ^ 2 + 0.5 * (x[, 1] - 1) ^ 2;
    }

    g = cbind(2 * x[1] * (x[1] ^ 2 - x[2]) + x[1] - 1, x[2] - x[1] ^ 2);
    H = cbind(6 * x[1] ^ 2 - 2 * x[2] + 1, -2 * x[1], -2 * x[1], 1)
    if (nargs() >= 2)
        stop("not implemented for arg 2 or more")

   list(f = f,g = g, H = H)
}

## from aokiFn above

f1 = function(x, y) 0.5 * (x ^ 2 - y) ^ 2 + 0.5 * (x - 1) ^ 2
#library(Deriv)
#Deriv(f, "x")
#Deriv(f, "y")

## this is a deriv of the above
g1 = function(x, y) c(2 * x * (x ^ 2 - y) + x - 1,
                      y - x ^ 2)

xx = grad.desc(FUN = f1, gr = g1, rg = c(0, -0.5, 2, 3), init = c(0.5, 0.5), gamma = 0.3,len = 50,tol = 0.0000001 )
xx$persp(col = "lightblue", theta = 130, phi = 30, axes = TRUE, nticks = 5)

#plot3D::points3D(1, 1, 1, pch = 19, col = "red", add = TRUE)
##########################################################################

steepestDescent = function(f, x0, stepSize = 0.3, ftol = 1e-3, outputFn = NULL, maxIter = 500, exactLineSearch = FALSE) {
    #% f is the function of the form[fx, gx] = f(x) where gx is a column vector
    #% outputfn has the form stop = outputfn(x, optimValues, state)

    #% This file is from pmtk3.googlecode.com
    k = 1;
    reldiff = NaN;
    x = as.vector(x0);
    stop = FALSE;
    f1 = f(x);
    while (stop == FALSE) {

        k = k + 1;
        d = -f1$g;
        #% steepest descent direction
        if (is.null(stepSize)) {
            #ls = linesearch(f, x, f1$f, f$g, d, ~ exactLineSearch);
        } else {
            xnew = x + stepSize * d;
            f1 = f(xnew);
        }

        #%reldiff = norm(xnew - x) / norm(xnew);
        #%stop = (reldiff < ftol) | (k > maxIter);
        stop = norm(f1$g) < ftol | (k > maxIter);
        if (is.null(outputFn) == FALSE) {
            optimValues.iteration = k;
            optimValues.fval = f1$g;
            optimValues.funccount = k;
            state = 'iter';
            stop = stop | outputFn(x, optimValues, state);

        }
        plot3D::points3D(xnew[1], xnew[2], 1, pch = 19, col = "yellow", add = TRUE)
        #print(xnew)
        x = xnew;

    }
    x
}

x1 = seq(0, 2, by = 0.1)
y1 = seq(-0.5, 3, by = 0.1)
g = meshgrid(x1, y1);

#x = matrix(g$x,size(g$x))
#y = matrix(g$y, size(g$y))
x = g$x
y = g$y
dfg = cbind(x = as.vector(x), y = as.vector(y))
size(dfg)
ak = aokiFn(dfg)
Z1 = ak$f %>% as.vector

z = matrix(Z1, size(g$x))
par(mfrow = c(1,1))

#plot3D::persp3D(x = x, y = y, z = z, box = TRUE, shade = 0.15,
                    #axes = TRUE, nticks = 5, ticktype = "detailed", zlab = "aokiFn",
                    #theta = 140, phi = 20, expand = 0.75, main = "test")

# 0.1 step size works but slow , cpp implementation could be nice here
stepSizes = list( 0.3, 0.6 ); #% [] means use line search
for (m in 1:length(stepSizes)) {

    plot3D::persp3D(x = x, y = y, z = z, box = TRUE, shade = 0.15,
                        axes = TRUE, nticks = 5, ticktype = "detailed", zlab = "aokiFn",
                        theta = 140, phi = 20, expand = 0.75, main = "test")

    plot3D::points3D(1, 1, 1, pch = 19, col = "red", add = TRUE)
    x0 = c(0, 0);
    #global xhist fhist %updated by optimstore
    xhist = c();
    fhist = c();
    stepsize = as.numeric(stepSizes[m]);
    x = steepestDescent(aokiFn, x0, stepSize = stepsize);
    #print(m)
    #print(x)

}
x


#Group members (Name, Student ID, E-Mail):

# * Baldomero Valdez,  Valenzuela, 2905175, baldmer.w@gmail.com
# * Omar Trinidad Gutierrez Mendez, 2850441, omar.vpa@gmail.com
# * Shinho Kang, 2890169, wis.shinho.kang@gmail.com

# install package colonCA (as root in Ubuntu)
# > source("https://bioconductor.org/biocLite.R")
# > biocLite("colonCA")

# 1a. Load `colonCA` dataset and use the function prcomp to calculate the PCA
# values (_____ / 4)

library(colonCA)
# colonCA dataset is an ExpressionSet object
data(colonCA)

colon.ds = log(exprs(colonCA))
colon.ds = t(colon.ds)
#colon.ds = as.data.frame(colon.ds)
#colon.ds$diagnostic = colonCA$class

# we apply the transponse function ?
colon.pca = prcomp(colon.ds,
                   center = TRUE,
                   scale. = TRUE
                   )
#print(colon.pca$rotation[1:5, 1:5])

# 1b. 2D PCA plot from normal patients and patients with cancer (_____ / 4)
# What do you observe?

par(mfrow=c(1, 1))

negative = apply(colon.pca$rotation[, colonCA$class == 'n'], 1, sum)
positive = apply(colon.pca$rotation[, colonCA$class == 't'], 1, sum)

plot(negative ~ positive,
     pch = 21,
     bg = c('red', 'green')[unclass(colonCA$class)])

# 1c. screeplot of eigenvalues (_____ / 2)
# colon.pca contains a `sdev` component
screeplot(colon.pca, npcs = 62)

# 1d. principal components analysis (_____ / 4)
summary(colon.pca)

# Which proportion of the overall variance do the first 2 principal components
# explain?  => 0.55905
# How many principal components would you need to explain 90% and 95% of the
# overall variance?
# To explain 90% we need the first 21 PCA whose cumulative proportion is 0.90082
# To explain 95% we need the first 34 PCA whose cumulative proportion is 0.94972


# https://www.isixsigma.com/tools-templates/control-charts/a-guide-to-control-charts/

library(dplyr)
library(lubridate)
library(ggplot2)
library(EnvStats)
library(gridExtra)

get_time <- function(line_of_file) {
  lin <- strsplit(line_of_file," ")
  tim <- lin[[1]][1] %>% as.character()
  tim <- substr(tim, 1, nchar(tim)-1) %>% as_datetime()
  return(tim)
}

get_wait_times <- function( tim) {
  dtim <- c()
  for ( i in 2:length(tim)) {
    dtim <- c( dtim, tim[i] - tim[i-1])
  }
  return(dtim)
}

dat <- readLines(con = "data/log2.txt")

tim <- c()
for(i in 1:length(dat)) {

  lin <- strsplit( dat[i], " ")[[1]]
  lin <- lin[ (length(lin)-2):length(lin)]

  if ( i == 1) {
    starttime <- get_time( dat[i])
  }

  if ( identical( lin, c("ETH", "share", "found!")) == TRUE) {
    if ( get_time( dat[i]) > starttime + 300) { # For warming up & whatnot
      tim <- c(tim, get_time( dat[i]))
    }
  }
}

dtim <- get_wait_times(tim)

hist(dtim, breaks = 100)

dtim %>% ecdf() %>% plot()

estim <- eexp( dtim, ci = TRUE)

bot <- c()
for (i in 1:200) {
 bot <- c( bot, sample(dtim, replace = TRUE) %>% mean(.))
}
hist(bot, breaks = 50)
1/quantile( bot, probs = c(.05, .95))

plot( tim[-1], dtim)

expquant <- function( lamb, p = .95) {
  (-log(1-p))/lamb
}

expquant(.02,.99)

trf_exp_norm <- function( dat, lambd) {
  pexp(dat, lambd) %>% qnorm() %>% return()
}

trf_norm_exp <- function( dat, lambd) {
  pnorm(dat) %>% qexp(.,rate = lambd) %>% return()
}

ntim <- trf_exp_norm(dtim, estim$parameters)

hist(ntim)
plot(ntim)

smooth.spline(ntim) %>% plot()

#####

baseline <- dtim[1:30]
process  <- dtim[31:length(dtim)]

base_lamb <- eexp( baseline)$parameters

base_norm <- trf_exp_norm( baseline, base_lamb)

process_norm <- trf_exp_norm( process, base_lamb)
proc_2sig <- trf_norm_exp( 2, base_lamb)
proc_3sig <- trf_norm_exp( 3, base_lamb)
proc_5sig <- trf_norm_exp( 4.75343, base_lamb)

sigs <- expand.grid( x = as_datetime(tim[2]),
                     label = c("mean + 2 sigma ~ 97.7%",
                               "mean + 3 sigma ~ 99.8%",
                               "mean + ~4.75 sigma < 1/1M "))
sigs$y <- c( proc_2sig, proc_3sig, proc_5sig)

data.frame( time = as_datetime(tim[-1]),
            dt   = dtim) %>%
  ggplot( aes( x = time,
               y = dt)) +
    theme_bw() +
    geom_point() +
    geom_hline( yintercept = proc_2sig, color = "blue") +
    geom_hline( yintercept = proc_3sig, color = "salmon4") +
    geom_hline( yintercept = proc_5sig, color = "red", lwd = 2) +
    scale_x_datetime() +
    labs( y = "Time between blocks (sec)",
          x = "Time") +
    geom_label( data = sigs, aes( x = x, y = y, label = label,
                                  vjust = 1, hjust = 0))

data.frame( dt   = dtim) %>%
  ggplot( aes( x = dt)) +
  theme_bw() +
  geom_histogram(aes(y=..density..), position="identity", alpha=0.7,
                 fill = "lightblue", color = "black",
                 bins = ceiling(sqrt(length(dtim)))) +
  geom_density(alpha=0.5, fill = "grey90", color = "darkblue",
               size = 2, color = "darkblue", kernel = "epanechnikov")+
  geom_vline(aes(xintercept=mean(dt)),
             linetype="dashed") +
  stat_function(fun = dexp, args = list(rate = 1/mean(dtim)), color = "darkgreen", size = 2) +
  labs( y = "",
        x = "Time between blocks (seconds)",
        caption = "Blue: Density; Green: Theoretical; note: should diverge for small values",
        title = "Distribution of time between blocks")

data.frame( time = as_datetime(tim[32:length(tim)]),
            dt_norm = process_norm) %>%
  ggplot( aes( x = time,
               y = dt_norm)) +
  theme_bw() +
  geom_point()  +
  geom_hline( yintercept = 0, color = "red") +
  geom_hline( yintercept = c(-3,3), color = "blue") +
  geom_hline( yintercept = mean(process_norm), color = "salmon4", linetype = "dashed") +
  labs( y = "Time between blocks (z-score)",
        x = "Time",
        caption = "dashed line: drift \n 99.7% should be between +-3") +
  scale_y_continuous( breaks = -3:3)

group <- 5

mn  <- c()
ran <- c()
for (i in 1:floor(length(process_norm)/5)) {
  mn  <- c(mn,  mean( process_norm[(i*5 - 4):(i*5)]))
  ran <- c(ran, max( process_norm[(i*5 - 4):(i*5)]) - min( process_norm[(i*5 - 4):(i*5)]))

}
rbar <- mean(ran)
D4 <-  2.114 #For group = 5

pmean <- data.frame(  x = as_datetime(tim[ seq( 32+5, length(tim), by = 5)]),
                      mn = mn,
                      ran = ran) %>%
  ggplot( aes(x = x, y = mn)) +
    theme_bw() +
    geom_point() +
    geom_line( linetype = "dotted") +
    geom_hline( yintercept = c(-3/sqrt(group),3/sqrt(group)), color = "blue") +
    geom_hline( yintercept = mean(mn), color = "grey20", linetype = "dashed") +
    labs( y = "Mean z-score for time between blocks",
          x = "Time",
          caption = "99.7% should be between blue limits\ndashed: drift")

pran  <- data.frame(  x = as_datetime(tim[ seq( 32+5, length(tim), by = 5)]),
                      mn = mn,
                      ran = ran) %>%
  ggplot( aes(x = x, y = ran)) +
  theme_bw() +
  geom_point() +
  geom_line( linetype = "dotted") +
  geom_hline( yintercept = rbar * D4, color = "blue") +
  labs( y = "Range (per 5 shares)",
        x = "Time",
        caption = "99.7% should be below blue limit")

grid.arrange( pmean,pran)


a <- 5
r <- 2

n <- 100000
centX <- a * runif(n)
centY <- a * runif(n)

ifx <- ((centX < r) | (centX > (a-r)))
ify <- ((centY < r) | (centY < (a-r)))
p <- mean(ifx | ify)

print(p)


# install.packages('lmtest')
# install.packages('car')
#install.packages("tseries")
#install.packages("forecast")
library(forecast)
library(tseries)
library(lmtest)
library(car)

setwd('/Users/demg/Projects/FA/Course III/ECONOMETRICS/task8')
data <- read.csv('./check.csv', sep = ";")

y <- data$GDP
x1 <- data$t
x2 <- data$d1
x3 <- data$d2
x4 <- data$d3

# Корреляционная матрица
cor(data)

# Диаграммы рассеяния
plot(y, x1, col = 'red')
plot(y, x2, col= 'blue')
plot(y, x3, col = 'green')
plot(y, x4, col = 'yellow')

########################################################################################
# Множественная модель
p_many <- lm(y~x1+x2+x3+x4)
s_many <- summary(p_many)
s_many

A_many <- sum(abs(s_many$residuals/y)) / length(y) * 100 # Апроксимация
A_many

confint(p_many, level = 0.95) # Доверительные интервалы

# Сравнение моделей
determ <- s_many$r.squared
adjust_determ <- s_many$adj.r.squared
st_error <- error_many
approx <- A_many
f_test <- s_many$fstatistic[1]

#######В) Проверьте значимость модели регрессии в целом и каждого коэффициента модели по отдельности.######
compare <- data.frame(
  Коэффициент_детерминации=determ,
  Скорректированный_коэффициент=adjust_determ,
  Стандартная_ошибка_модели=st_error,
  Ошибка_аппроксимации=approx,
  F_тест=f_test
)
print(compare)

"
Качество модели хорошее:
Модель очень качественная R^2 = 0.9628084
R^2 = 0.9628 (приближено к 1)
Se = 1051 (относительно у не очень много — качество нормальное (умеренное отношение))
F = 226.5
p-value = < 2.2e-16
Ошибка_аппроксимации < 7 - модель хорошая (5.371801)
"

#прогнозирование по модели с фиктивными переменными
pred=data.frame(c(41,42,43),c(1,0,0),c(0,1,0),c(0,0,1))
colnames(pred)=c("x1","x2","x3","x4")
predictGDP=predict(p_many, newdata = pred)
predictGDP
pred

dwtest(p_many) # Тест Дарбина-Ватсона
#  2.676e-08
bgtest(p_many, order = 1, order.by = NULL, type = c("Chisq", "F")) # Тест Бреуша-Годфри
#pv 4.028e-06 > 0.1,0.05, 0.01 =>H0 принимается, автокорреляция первого порядка отсутствует

gqtest(p_many, order.by = x1, fraction = 0) # Тест Голдфельда-Квандта для x1
#p-value = 0.1982 - больше 0.1 0.05 0.01, отсутствует проблема гетероскедастичности

bptest(p_many, studentize = TRUE) # Тест Бреуша-Пагана
#p-value = 0.546, - больше 0.1 0.05 0.01, отсутствует проблема гетероскедастичности

error_many <- sqrt(deviance(p_many)/df.residual(p_many))

#работа с временным рядом GDP
GDP <- c(data$GDP)
GDP1 <- ts(data=GDP,start=c(2009), name="GDP", frequency = 4)
GDP1
ACF <- Acf(GDP1) # выборочная автокорреляция
ACF
PACF <- Pacf(GDP1) # частная автокорреляиця
PACF
tsdisplay(GDP1)
#вывод: ряд нестационарный


data = read.csv('data/airlines_data.csv')
head(data)
str(data)

library(dplyr)

aggregated_data <-
                    subset( data, !is.na(arr_flights) & !is.na(arr_del15)) %>%
                    group_by(year, carrier_name) %>%
                    summarise(
                                arrivals = sum(arr_flights),
                                delayed  = sum(arr_del15),
                                cancelled = sum(arr_cancelled),
                                diverted = sum(arr_diverted),
                                delay_rate = 100*delayed/arrivals,
                                timely_rate = 100 - delay_rate

                    )

top_flights <- aggregated_data %>%
                group_by(carrier_name) %>%
                summarise( arrivals = mean(arrivals) )

top_flights <- top_flights[ order(top_flights$arrivals, decreasing = TRUE), ]

selected_airlines <-  top_flights$carrier_name[1:5]

final_data <- subset(aggregated_data, is.element(carrier_name, selected_airlines))

write.csv(final_data, 'data/summarized_data.csv')

Project 6 - Data Visualization/data/data_cleaning.r


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Sun Mar 28 11:14:38 2010
########################################################
#season and trend decomposition of the monthly murder rates in Mexico

source("library/utilities.r")
source("timelines/constants.r")

plotReg <- function(df){
  hom.ts <- ts(df$rate, start=1990, freq = 12)
  trend = time(hom.ts)
  ndays <- strptime(df$date, format = "%Y-%m-%d")$mday
  reg <- glm(rate ~ trend + factor(month) + ndays, data = df)
  reg2 <- glm(rate ~ trend + factor(year) + factor(month) +
            ndays, data = df)
  reg3 <- glm(rate ~ trend + ndays, data = df)
  print(anova(reg, reg2))
  print(summary(reg))
  print(summary(reg2))
  print(summary(reg3))
  df$fitted <- unlist(reg$fitted.values)
  df$fitted <- fitted(reg)
  print(ggplot(df, aes(as.Date(date), rate)) +
      geom_line() +
      geom_line(aes(as.Date(date), fitted,
                    legend = FALSE), color = "blue") +
      scale_x_date(major ="year") +
      opts(title = reg$call))
}

plotTrend <- function(df, ban){
  start.dw <- op.mich
  end.dw <- as.Date("2008-12-31")
  print(ggplot(df, aes(as.Date(date), rate)) +
    geom_rect(xmin = as.numeric(start.dw), xmax = as.numeric(end.dw),
              ymin=0, ymax=Inf, alpha = .01, fill = "pink") +
    geom_line(size = .2) +
    geom_line(aes(as.Date(date), trend), color = "blue") +
    geom_vline(aes(xintercept = as.Date("2004-09-13")), color = "gray",
               linetype = 2) +
    scale_x_date() +
    xlab("") + ylab("Annualized Homicide Rate") +
    opts(title = "Monthly Homicide Rate and Trend (the Gray Line is the Assault Weapon Ban Expiration Date)") +
    annotate("text", x = as.numeric(start.dw), y = 16.9,
             label = "Drug War", hjust =-.2))
}

plotSeasonal <- function(df){
  months <- factor(format(as.Date(df$date), "%b"))[1:12]
  print(ggplot(df[1:12,], aes(1:12, seasonal), group = 1) +
    geom_line() +
    scale_x_continuous(breaks = 1:12,
                       labels = months) +
    xlab("") +
    opts(title = "Seasonal Component of the Homicide Rate") +
    geom_hline(yintercept=0, color = "gray70"))
}

hom <- read.csv(bzfile("timelines/data/county-month-gue-oax.csv.bz2"))
hom <- cleanHom(hom)
hom <- addMonths(hom)
#hom <- subset(hom, Year.of.Murder >= 1994)

#I can't see any clearcut paterns at the state level
ggplot(hom, aes(y = Total.Murders, x = Month.of.Murder,
                group = Year.of.Murder, color = Year.of.Murder)) +
    geom_line() +
    facet_wrap(~ County, scales = "free_y")

#Now I can see them
print(ggplot(hom, aes(as.Date(Date), Total.Murders)) +
    geom_line() +
    scale_x_date() +
    facet_wrap(~ County, scales = "free_y") +
    opts(title = "Monthly Number of Homicides"))
dev.print(png, "trends/output/st-murders.png", width = 960, height = 600)

#Now only since the start of the Drug War
print(ggplot(subset(hom, as.Date(Date) >= as.Date("2006/12/01")),
             aes(as.Date(Date), Total.Murders)) +
    geom_line() +
    scale_x_date() +
    facet_wrap(~ County, scales = "free_y")+
    opts(title = "Monthly Number of Homicides Since the Start of the Drug War"))
dev.print(png, "trends/output/st-drug-war-murders.png", width = 960, height = 600)

#Let's see what Chiapas looked like during the 95 Acteal massacre
print(ggplot(subset(hom, as.Date(Date) <= as.Date("1998/06/01") &
                    as.Date(Date) >= as.Date("1997/01/01") &
                    County == "Chiapas"),
             aes(as.Date(Date), Total.Murders)) +
    geom_line() +
    scale_x_date() +
    facet_wrap(~ County, scales = "free_y")+
    opts(title = "Monthly Number of Homicides Since the Start of the Drug War"))

#STL decomposition with loess
pop <- monthlyPop()
homrate <- addHom(hom, pop)
homrate <- addTrend(homrate)
homrate <-  subset(homrate, year >= 1994)

plotReg(homrate)
dev.print(png, "trends/output/regression.png", width = 800,
          height = 600)

Cairo(file = "trends/output/trend.png", width = 960, height=600)
plotTrend(homrate)
dev.off()

plotSeasonal(homrate)
dev.print(png, "trends/output/seasonal.png", width = 450, height = 300)

########################################################
#Bunch of crappy tests
########################################################
#See if the residuals are normal
hom.ts <- ts(homrate$rate, start=1990, freq = 12)
plot(stl(hom.ts, "per"))
dhom <- diff(hom.ts)
plot(dhom)
shapiro.test(dhom)
hist(dhom)
#12 month lag
lag.plot(dhom, 40)

#Arima
#fit.ar <- arima(hom.ts,order=c(1,1,1))
#tsdiag(fit.ar)
#Box.test(fit.ar$residuals)
#plot(hom.ts, xlim=c(1990,2010), ylim=c(5,19), type = "l")
#hom.pred <- predict(fit.ar, n.ahead = 12)
#lines(hom.pred$pred, col="red")
#lines(hom.pred$pred + 2 * hom.pred$se, col="red", lty=3)
#lines(hom.pred$pred - 2 * hom.pred$se, col="red", lty=3)


library(extRemes)
library(ggplot2)
library(ggpubr)

###Stationary plot
EVT_plot <- function(obs, ensemble, GEV_type, main, y_lab = "February average precipitation (mm/day)", ylim = NA) {
  ## We plot the GEV distribution for ERA5 and empirical data for SEAS5
  fit_obs <- fevd(
    x = obs, threshold = NULL, threshold.fun = ~1, location.fun = ~1,
    scale.fun = ~1, shape.fun = ~1, use.phi = FALSE,
    type = GEV_type, method = "MLE", initial = NULL, # type= c("GEV", "GP", "PP", "Gumbel", "Exponential"), method= c("MLE", "GMLE", "Bayesian", "Lmoments")
    span = NULL, units = NULL, time.units = "days", period.basis = "year", ## time and period only important for labelling and do not influence the calculation
    na.action = na.fail, optim.args = NULL, priorFun = NULL,
    priorParams = NULL, proposalFun = NULL, proposalParams = NULL,
    iter = 9999, weights = 1, blocks = NULL, verbose = FALSE
  )

  ## Now calculate the return levels and their confidence intervals for each return period within rperiods
  rperiods <- c(seq(from = 1.01, to = 1.5, by = 0.1), 1.7, 2, 3, 5, 10, 20, 50, 80, 100, 120, 200, 250, 300, 500, 800, 2000, 5000)
  rvs_obs <- ci.fevd(fit_obs, alpha = 0.05, type = "return.level", return.period = rperiods, method = "normal")
  colnames(rvs_obs) <- c("Obs_l", "Obs", "Obs_h") # Rename the col
  GEV_obs <- data.frame(cbind(rvs_obs, rperiods)) ## Make a datafram for ggplot

  ## Add the emipirical data
  rp_obs <- length(obs) / 1:length(obs) ## these are the (empirical) return periods for the sorted datapoints
  obs_sorted <- sort(obs, decreasing = T) ## For example, the highest extreme has a rp of 35 years, the second highest 17.5, third highest 11.7 etc.
  datapoints_obs <- data.frame(cbind(rp_obs, obs_sorted))

  rp_S5 <- length(ensemble) / 1:length(ensemble) # SEAS5 has return periods up to 3800 years
  ensemble_sorted <- sort(ensemble, decreasing = T)
  datapoints_S5 <- data.frame(cbind(rp_S5, ensemble_sorted))

  ## And plot
  cols <- c("UNSEEN" = "black", "OBS     " = "blue") ## for  the legend
  ggplot(data = datapoints_S5, aes(x = rp_S5)) +
    geom_point(aes(y = ensemble_sorted, col = "UNSEEN"), alpha = 0.5, size = 1) +
    geom_ribbon(data = GEV_obs, aes(ymin = Obs_l, ymax = Obs_h, x = rperiods, fill = "OBS     "), alpha = 0.1) +
    geom_point(data = datapoints_obs, aes(x = rp_obs, y = obs_sorted, col = "OBS     "), size = 1) +
    scale_x_continuous(trans = "log10") +
    scale_fill_manual(name = "Data", values = cols) +
    scale_colour_manual(name = NULL, values = cols) +
    theme_classic() +
    theme(
      legend.position = c(.95, .05),
      legend.justification = c("right", "bottom"),
      legend.box.just = "right",
      legend.title = element_blank(),
      text = element_text(size = 11),
      axis.text = element_text(size = 11)
    ) +
    labs(title = main, y = y_lab, x = "Return period (years)") +
    if (is.finite(ylim)) {
      coord_cartesian(ylim = c(NA, ylim))
    }
}

##Unseen trends plots:
rperiods = c(2, 5, 10, 20, 50, 80, 100, 120, 200, 250, 300, 500, 800,2000,5000)

RV_ci <- function(extremes,covariate,return_period,covariate_values,GEV_type) { ## A function to fit the GEV and obtain the return values
  fit <- fevd(extremes, type = GEV_type, location.fun = ~ covariate, ##Fitting the gev with a location and scale parameter linearly correlated to the covariate (years)
               scale.fun = ~ covariate, use.phi = TRUE)

  params_matrix <- make.qcov(fit, vals = list(mu1 = covariate_values,phi1 = covariate_values)) #Create a parameter matrix for the GEV fit
  rvs=ci.fevd(fit,alpha = 0.05,type='return.level',return.period = return_period,method ="normal",qcov=params_matrix)  #Calculate the return values and confidence intervals for each year
  return(rvs)
}

#This function was written specifically for the California case study. The year 2020 was left out of the fit for the observations.
unseen_trends1 <- function (ensemble, obs, x_ens, x_obs, covariate_ens, covariate_obs, covariate_values,
    rp, GEV_type, title = "", ylab = "Three-day precipitation (mm)")
{
    ci_ens = RV_ci(extremes = ensemble, covariate = covariate_ens,
        return_period = rp, covariate_values = covariate_values,
        GEV_type = GEV_type)
    ci_obs = RV_ci(extremes = obs[1:(length(obs)-1)], covariate = covariate_obs,
        return_period = rp, covariate_values = covariate_values,
        GEV_type = GEV_type)
    cols = c(OBS = "blue", `UNSEEN-trends` = "orange")
    p_trend = ggplot() + ggtitle(title) + geom_point(aes(x = x_ens,
        y = ensemble), size = 2, alpha = 0.051) + geom_point(aes(x = x_obs,
        y = obs), col = "blue", shape = 4, size = 2, stroke = 1.5) +
        geom_line(aes(x = x_obs, y = ci_ens[, 2]), col = "orange") +
        geom_ribbon(aes(x = x_obs, ymin = ci_ens[, 1], ymax = ci_ens[,
            3], fill = "UNSEEN-trends"), alpha = 0.5) + geom_line(aes(x = x_obs,
        y = ci_obs[, 2]), col = "blue") + geom_ribbon(aes(x = x_obs,
        ymin = ci_obs[, 1], ymax = ci_obs[, 3], fill = "OBS"),
        alpha = 0.2) + theme_classic() + ylab(ylab) + scale_fill_manual(name = "Method",
        values = cols) + theme(axis.title.x = element_blank(),
        plot.title = element_text(hjust = 0.5), text = element_text(size = 10),
        axis.text = element_text(size = 10))
    return(p_trend)
}

# unseen_trends1 <- function(ensemble, obs, x_ens, x_obs, covariate_ens, covariate_obs, rp, GEV_type, title = "", ylab = 'Three-day precipitation (mm)') {

#     ci_ens=RV_ci(extremes = ensemble,
#                  covariate = covariate_ens,
#                  return_period = rp,
#                  covariate_values = covariate_obs, ## The covariate values are used to create the parameter matrix. This should only be the years, most likely same as covariate_obs. c(1:36 in this case)
#                  GEV_type=GEV_type)

#     ci_obs=RV_ci(extremes = obs,
#                  covariate = covariate_obs,
#                  return_period = rp,
#                  covariate_values = covariate_obs,
#                  GEV_type=GEV_type)

#     ###plot
#     cols=c("OBS"="blue","UNSEEN-trends"="orange")
#     p_trend=
#       ggplot()+
#       ggtitle(title) +
#       geom_point(aes(x = x_ens,y = ensemble),size=2,alpha=0.051)+
#        # scale_size_manual(values = seq(0.1,3,length.out = 3499)) +
#       geom_point(aes(x=x_obs,y = obs),col='blue',shape=4,size=2,stroke=1.5)+
#       geom_line(aes(x=x_obs,y = ci_ens[,2]),col='orange')+
#       geom_ribbon(aes(x=x_obs,ymin = ci_ens[,1],ymax=ci_ens[,3],fill="UNSEEN-trends"),alpha=0.5)+
#       geom_line(aes(x=x_obs,y = ci_obs[,2]),col='blue')+
#       geom_ribbon(aes(x=x_obs,ymin = ci_obs[,1],ymax=ci_obs[,3],fill="OBS"),alpha=0.2)+
#       theme_classic()+
#       ylab(ylab)+
#       scale_fill_manual(name="Method",values=cols) +
#       theme(axis.title.x=element_blank(),
#             plot.title = element_text(hjust = 0.5),
#             text=element_text(size=14),
#             axis.text = element_text(size=14))
#     return(p_trend)
# }

unseen_trends2 <- function (ensemble, obs, covariate_ens, covariate_obs, GEV_type,
                            covariate_values = c(1, length(obs)),
                            rperiods = c(2, 5, 10, 20, 50, 80, 100, 120, 200, 250, 300, 500, 800,2000,5000),
                            ylab = "Return value")
{
    rvs_1981 = RV_ci(extremes = ensemble, covariate = covariate_ens,
        return_period = rperiods, covariate_values = covariate_values[1], GEV_type = GEV_type)
    colnames(rvs_1981) = c("S5_1981_l", "S5_1981", "S5_1981_h",
        "S5_1981_sd")
    rvs_2020 = RV_ci(extremes = ensemble, covariate = covariate_ens,
        return_period = rperiods, covariate_values = covariate_values[2], GEV_type = GEV_type)
    colnames(rvs_2020) = c("S5_2020_l", "S5_2020", "S5_2020_h",
        "S5_2020_sd")
    rvs_obs_1981 = RV_ci(extremes = obs, covariate = covariate_obs,
        return_period = rperiods, covariate_values = covariate_values[1], GEV_type = GEV_type)
    colnames(rvs_obs_1981) = c("Obs_1981_l", "Obs_1981", "Obs_1981_h",
        "Obs_1981_sd")
    rvs_obs_2020 = RV_ci(extremes = obs, covariate = covariate_obs,
        return_period = rperiods, covariate_values = covariate_values[2], GEV_type = GEV_type)
    colnames(rvs_obs_2020) = c("Obs_2020_l", "Obs_2020", "Obs_2020_h",
        "Obs_2020_sd")
    rvs = data.frame(cbind(rvs_1981, rvs_2020, rvs_obs_1981,
        rvs_obs_2020, rperiods))
    cols = c(`1981` = "black", `2020` = "red")
    p = ggplot(data = rvs, aes(x = rperiods)) +
    geom_line(aes(y = S5_1981),col = "black") +
    geom_ribbon(aes(ymin = S5_1981_l, ymax = S5_1981_h,fill = "1981"), alpha = 0.5) +
    geom_line(aes(y = S5_2020,colour = "2020"), col = "red") +
    geom_ribbon(aes(ymin = S5_2020_l,ymax = S5_2020_h, fill = "2020"), alpha = 0.5) +
    geom_line(aes(y = Obs_1981),col = "black", linetype = "dashed") +
    geom_ribbon(aes(ymin = Obs_1981_l,ymax = Obs_1981_h), fill = "black", alpha = 0.1) +
    geom_line(aes(y = Obs_2020),col = "red", linetype = "dashed") +
    geom_ribbon(aes(ymin = Obs_2020_l,ymax = Obs_2020_h), fill = "red", alpha = 0.1) +
    scale_x_continuous(trans = "log10") +
    theme_classic() +
    scale_fill_manual(name = "Years", values = cols) +
    xlab("Return period (years)") +
    ylab(ylab) +
    theme(text = element_text(size = 10),
          axis.text = element_text(size = 10))
    return(p)
}

# unseen_trends2 <- function(ensemble, obs, covariate_ens, covariate_obs, GEV_type, ylab = 'Three-day precipitation (mm)') {

#     # Calculate the return values for 1981 (covariate = 1)
#     rvs_1981=RV_ci(extremes = ensemble,
#                    covariate = covariate_ens,
#                    return_period = rperiods,
#                    covariate_values = 1,
#                    GEV_type = GEV_type) ##calc the return values
#     colnames(rvs_1981) = c('S5_1981_l','S5_1981','S5_1981_h','S5_1981_sd') #Rename the column

#     # Calculate the return values for 2015 (covariate = 35)
#     rvs_2015=RV_ci(extremes = ensemble,
#                    covariate = covariate_ens,
#                    return_period = rperiods,
#                    covariate_values = 35,
#                    GEV_type = GEV_type)
#     colnames(rvs_2015) = c('S5_2015_l','S5_2015','S5_2015_h','S5_2015_sd')

#     rvs_obs_1981=RV_ci(extremes = obs,
#                        covariate = covariate_obs,
#                        return_period = rperiods,
#                        covariate_values = 1,
#                        GEV_type = GEV_type)
#     colnames(rvs_obs_1981) = c('Obs_1981_l','Obs_1981','Obs_1981_h','Obs_1981_sd') #Rename the col

#     rvs_obs_2015=RV_ci(extremes = obs,
#                        covariate = covariate_obs,
#                        return_period = rperiods,
#                        covariate_values = 35,
#                        GEV_type = GEV_type)
#     colnames(rvs_obs_2015) = c('Obs_2015_l','Obs_2015','Obs_2015_h','Obs_2015_sd')

#     ## Combine the return values into one dataframe
#     rvs=data.frame(cbind(rvs_1981,rvs_2015,rvs_obs_1981,rvs_obs_2015,rperiods))

# #     cols=c("S5_1981"="#f04546","S5_2015"="#3591d1","Obs_1981"="#62c76b","Obs_2015"="#62c76b")
#     cols=c("1981"="black","2015"="red")
#     p=ggplot(data = rvs,aes(x=rperiods))+
#       geom_line(aes(y = S5_1981),col='black')+
#       geom_ribbon(aes(ymin=S5_1981_l,ymax=S5_1981_h,fill='1981'),alpha=0.5)+
#       geom_line(aes(y = S5_2015,colour="2015"),col='red')+
#       geom_ribbon(aes(ymin=S5_2015_l,ymax=S5_2015_h,fill="2015"), alpha=0.5)+
#       geom_line(aes(y = Obs_1981),col='black',linetype ='dashed')+
#       geom_ribbon(aes(ymin=Obs_1981_l,ymax=Obs_1981_h),fill='black', alpha=0.1)+
#       geom_line(aes(y = Obs_2015),col='red',linetype ='dashed')+
#       geom_ribbon(aes(ymin=Obs_2015_l,ymax=Obs_2015_h),fill='red', alpha=0.1)+
#       scale_x_continuous(trans='log10')+
#       theme_classic()+
#       scale_fill_manual(name="Years",values=cols) +
#       xlab('Return period (years)')+
#       ylab(ylab)+
#       theme(text=element_text(size=14),
#             axis.text = element_text(size=14))
#     return(p)
# }


library(tradepolicy)

# Data ----

ch2_application1 <- agtpa_applications %>%
  select(exporter, importer, pair_id, year, trade, dist, cntg, lang, clny) %>%
  filter(year == 2006) %>%
  mutate(
    log_dist = log(dist),
    intl = ifelse(exporter != importer, 1, 0),
    exporter = ifelse(exporter == "DEU", "0-DEU", exporter),
    importer = ifelse(importer == "DEU", "0-DEU", importer)
  ) %>%

  # Create Yit
  group_by(exporter, year) %>%
  mutate(y = sum(trade)) %>%

  # Create Eit
  group_by(importer, year) %>%
  mutate(e = sum(trade)) %>%

  # Create Er
  ungroup() %>%
  mutate(e_r = max(ifelse(importer == "0-DEU", e, NA), na.rm = T))

# Step I: Solve the baseline model ----

fit_baseline_app1 <- glm(
  trade ~ 0 + log_dist + cntg + intl + exporter + importer,
  family = quasipoisson(link = "log"),
  data = ch2_application1
)

ch2_app1_baseline_2 <- tp_clustered_glm(fit_baseline_app1$formula, ch2_application1)

ch2_application1 <- ch2_application1 %>%
  left_join(
    tp_fixed_effects(fit_baseline_app1),
    c("exporter", "importer")
  )

ch2_application1 <- ch2_application1 %>%
  mutate(
    tij_bln = exp(fit_baseline_app1$coefficients["log_dist"] * log_dist +
                    fit_baseline_app1$coefficients["cntg"] * cntg +
                    fit_baseline_app1$coefficients["intl"] * intl),

    # outward multilateral resistance (omr)
    omr_bln = y * (e_r / exp(fe_exporter)),

    # inward multilateral resistance (imr)
    imr_bln = e / (exp(fe_importer) * e_r)
  )

ch2_application1 <- ch2_application1 %>%
  mutate(tradehat_bln = predict(fit_baseline_app1, ch2_application1, "response")) %>%
  group_by(exporter) %>%
  mutate(xi_bln = sum(tradehat_bln * (exporter != importer))) %>%
  ungroup()

# Step II: Define a counterfactual scenario ----

ch2_application1 <- ch2_application1 %>%
  mutate(
    tij_cfl = exp(fit_baseline_app1$coefficients["log_dist"] * log_dist +
                    fit_baseline_app1$coefficients["cntg"] * cntg),
    log_tij_cfl = log(tij_cfl)
  )

ch2_application1 <- ch2_application1 %>%
  mutate(
    intl_cfl = 0,
    tij_bln = exp(fit_baseline_app1$coefficients["log_dist"] * log_dist +
                    fit_baseline_app1$coefficients["cntg"] * cntg +
                    fit_baseline_app1$coefficients["intl"] * intl_cfl),
    log_tij_cfl = log(tij_cfl)
  )

# Step III: Solve the counterfactual model ----

fit_counterfactual_app1 <- glm(
  trade ~ 0 + exporter + importer + offset(log_tij_cfl),
  family = quasipoisson(link = "log"),
  data = ch2_application1
)

ch2_application1 <- ch2_application1 %>%
  left_join(
    tp_fixed_effects(fit_counterfactual_app1),
    by = c("exporter", "importer")
  ) %>%
  rename(
    fe_exporter_bln = fe_exporter.x,
    fe_exporter_cfl = fe_exporter.y,
    fe_importer_bln = fe_importer.x,
    fe_importer_cfl = fe_importer.y
  )

ch2_application1 <- ch2_application1 %>%
  mutate(
    # outward multilateral resistance (omr)
    omr_cfl = y * (e_r / exp(fe_exporter_cfl)),

    # inward multilateral resistance (imr)
    imr_cfl = e / (exp(fe_importer_cfl) * e_r)
  )

ch2_application1 <- ch2_application1 %>%
  mutate(tradehat_cfl = predict(fit_counterfactual_app1, ch2_application1, "response")) %>%
  group_by(exporter) %>%
  mutate(xi_cfl = sum(tradehat_cfl * (exporter != importer))) %>%
  ungroup()

# set the criteria of convergence
# taken from the literature (see the Stata code)
sigma <- 7

ch2_application1 <- ch2_application1 %>%
  mutate(
    change_tij = tij_cfl / tij_bln,
    phi = ifelse(importer == exporter, e / y, 0)
  ) %>%
  group_by(exporter) %>%
  mutate(phi = max(phi)) %>%
  ungroup()

ch2_application1 <- ch2_application1 %>%
  group_by(exporter) %>%
  mutate(change_p_i = ((exp(fe_exporter_cfl) / e_r) / (exp(fe_exporter_bln) / e_r))^(1 /(1 - sigma))) %>%
  ungroup() %>%

  group_by(importer) %>%
  mutate(
    change_p_j = ifelse(importer == exporter, change_p_i, 0),
    change_p_j = max(change_p_j)
  ) %>%
  ungroup()

ch2_application1 <- ch2_application1 %>%
  mutate(trade_cfl = tradehat_cfl * change_p_i * change_p_j)

ch2_application1 <- ch2_application1 %>%
  mutate(
    omr_cfl_0 = omr_cfl,
    imr_cfl_0 = imr_cfl,
    change_imr_full_0 = 1,
    change_omr_full_0 = 1,
    change_p_i_0 = change_p_i,
    change_p_j_0 = change_p_j,
    fe_exporter_cfl_0 = fe_exporter_cfl,
    fe_importer_cfl_0 = fe_importer_cfl,
    tradehat_0 = tradehat_cfl,
    e_r_cfl_0 = e_r
  )

# set parameters
max_dif <- 1
sd_dif <- 1
change_price_i_old <- 0

i <- 1
while(sd_dif > 1e-5 | max_dif > 1e-5) {
  ch2_application1 <- ch2_application1 %>%
    mutate(trade_1 = tradehat_0 * change_p_i_0 * change_p_j_0 / (change_omr_full_0 * change_imr_full_0))

  # repeat the counterfactual model
  fit_counterfactual_app1_2 <- glm(
    trade_1 ~ 0 + exporter + importer + offset(log_tij_cfl),
    family = quasipoisson(link = "log"),
    data = ch2_application1
  )

  ch2_application1 <- ch2_application1 %>%
    left_join(
      tp_fixed_effects(fit_counterfactual_app1_2),
      by = c("exporter", "importer")
    )

  # compute the conditional general equilibrium effects of trade
  ch2_application1 <- ch2_application1 %>%
    mutate(tradehat_1 = predict(fit_counterfactual_app1_2, ch2_application1, "response")) %>%
    group_by(exporter) %>%
    mutate(y_cfl_1 = sum(tradehat_1)) %>%
    ungroup() %>%

    mutate(e_cfl_1 = ifelse(importer == exporter, phi * y_cfl_1, 0)) %>%
    group_by(importer) %>%
    mutate(e_cfl_1 = max(e_cfl_1)) %>%
    ungroup() %>%

    mutate(
      e_r_cfl_1 = ifelse(importer == "0-DEU", e_cfl_1, 0),
      e_r_cfl_1 = max(e_r_cfl_1)
    )

  # compute the change in prices for exporters and importers
  ch2_application1 <- ch2_application1 %>%
    mutate(change_p_i_1 = ((exp(fe_exporter) / e_r_cfl_1) /
      (exp(fe_exporter_cfl_0) / e_r_cfl_0))^(1 / (1 - sigma)))

  # compute the change in prices for exporters and importers
  ch2_application1 <- ch2_application1 %>%
    group_by(importer) %>%
    mutate(
      change_p_j_1 = ifelse(importer == exporter, change_p_i_1, 0),
      change_p_j_1 = max(change_p_j_1)
    ) %>%
    ungroup()

  # compute both outward and inward multilateral resistance
  ch2_application1 <- ch2_application1 %>%
    mutate(
      omr_cfl_1 = (y_cfl_1 * e_r_cfl_1) / exp(fe_exporter),
      imr_cfl_1 = e_cfl_1 / (exp(fe_importer) * e_r_cfl_1)
    )

  # update the differences
  max_dif <- abs(max(ch2_application1$change_p_i_0 - change_price_i_old))
  sd_dif <- sd(ch2_application1$change_p_i_0 - change_price_i_old)
  change_price_i_old <- ch2_application1$change_p_i_0

  # compute changes in outward and inward multilateral resistance
  ch2_application1 <- ch2_application1 %>%
    mutate(
      change_omr_full_1 = omr_cfl_1 / omr_cfl_0,
      change_imr_full_1 = imr_cfl_1 / imr_cfl_0,
      omr_cfl_0 = omr_cfl_1,
      imr_cfl_0 = imr_cfl_1,
      change_omr_full_0 = change_omr_full_1,
      change_imr_full_0 = change_imr_full_1,
      change_p_i_0 = change_p_i_1,
      change_p_j_0 = change_p_j_1,
      fe_exporter_cfl_0 = fe_exporter,
      fe_importer_cfl_0 = fe_importer,
      tradehat_0 = tradehat_1,
      e_r_cfl_0 = e_r_cfl_1
    ) %>%
    select(-fe_exporter, -fe_importer)

  i <- i + 1
}

ch2_application1 <- ch2_application1 %>%
  mutate(
    change_p_i_full = ((exp(fe_exporter_cfl_0) / e_r_cfl_0) /
                         (exp(fe_exporter_bln) / e_r))^(1 / (1 - sigma)),
    change_p_j_full = change_p_i_full * (exporter == importer)
  ) %>%
  group_by(importer) %>%
  mutate(change_p_j_full = max(change_p_j_full)) %>%
  ungroup() %>%
  mutate(y_full = change_p_i_full * y)

ch2_application1 <- ch2_application1 %>%
  mutate(e_full = change_p_j_full * e * (exporter == importer)) %>%
  group_by(importer) %>%
  mutate(e_full = max(e_full, na.rm = TRUE)) %>%
  ungroup() %>%
  mutate(
    e_full_r = e_full * (importer == "0-DEU"),
    e_full_r = max(e_full_r)
  )

ch2_application1 <- ch2_application1 %>%
  mutate(
    omr_full = y_full * e_r_cfl_0 / exp(fe_exporter_cfl_0),
    imr_full = e_full / (exp(fe_importer_cfl_0) * e_full_r)
  )

ch2_application1 <- ch2_application1 %>%
  mutate(x_full = (y_full * e_full * tij_cfl) / (imr_full * omr_full)) %>%
  group_by(exporter) %>%
  mutate(xi_full = sum(x_full * (importer != exporter))) %>%
  ungroup()

# Step IV: Collect, construct, and report indexes of interest ----

ch2_application1 <- ch2_application1 %>%
  mutate(
    change_price_full = (change_p_i_full - 1) * 100,
    change_omr_cfl = (omr_cfl^(1 / (1 - sigma)) / omr_bln^(1 / (1 - sigma)) - 1) * 100,
    change_omr_full = (omr_full^(1 / (1 - sigma)) / omr_bln^(1 / (1 - sigma)) - 1) * 100,
    change_xi_cfl = (xi_cfl / xi_bln  - 1) * 100,
    change_xi_full = (xi_full / xi_bln - 1) * 100
  )

ch2_application1 <- ch2_application1 %>%
  mutate(
    change_imr_full = -(imr_full^(1 / (1 - sigma)) / imr_bln^(1 / (1 - sigma)) - 1) * 100,
    rgdp = ((y_full / imr_full^(1 / (1 - sigma))) / (y / imr_bln^(1 / (1 - sigma))) - 1) * 100
  )

# Figures replication ----

ch2_application1 <- ch2_application1 %>%
  filter(exporter == importer) %>%
  select(exporter, importer, y, change_xi_cfl, change_xi_full, rgdp,
         change_price_full, change_imr_full) %>%
  mutate(log_y = log(y))

ch2_app1_figures_2 <- ggplot(data = ch2_application1 %>%
         filter(exporter != "HKG")) +
  geom_point(aes(x = log_y, y = change_xi_cfl, color = "1")) +
  geom_point(aes(x = log_y, y = change_xi_full, color = "2")) +
  labs(
    x = "Log value of output",
    y = "Percent change of exports",
    title = "Figure 6: Effects of abolishing international borders on exports",
    caption = "Source: Authors' calculations",
    color = ""
  ) +
  theme_minimal() +
  theme(legend.position = "bottom") +
  scale_color_manual(
    labels = c(
      "Conditional general equilibrium",
      "Full endowment general equilibrium"
    ),
    values = c("#b6b8dd","#232958")
  )

save.image("all-models-and-data/04-chapter2-trade-without-borders.RData", compress = "xz")


 DGGGLM Example Program Results

 Weighted least squares solution
      1.9889    -1.0058    -2.9911

 Residual vector
     -6.37E-04  -2.45E-03  -4.72E-03   7.70E-03

 Square root of the residual sum of squares
      9.38E-03