# This is a special version of K-dO rq modified to compute the LR process
# Note that the sol array is now p+3 by J and the third row contains the
# value of the objective function at the tau specified in row one.
#
#     This software is in the public domain  and may be freely
#     used and redistributed for non-commercial purposes.  No guarantees
#     are offered or implied.  comments, bug reports, etc are welcome
#     and should be sent to roger@ysidro.econ.uiuc.edu or to
#
#        roger koenker
#        department of economics
#        university of illinois
#        champaign, illinois, 61820
#
#
    z <- .Fortran("rqbr", as.integer(n), as.integer(p), as.integer(n +
        5), as.integer(p + 3), as.integer(p + 4), as.double(x),
        as.double(y), as.double(tau), as.double(tol), flag = as.integer(1),
        coef = double(p), resid = double(n), integer(n), double((n +
            5) * (p + 4)), double(n), as.integer(nsol), as.integer(ndsol),
        sol = double((p + 3) * nsol), dsol = double(n * ndsol),
        lsol = as.integer(0), h = integer(p * nsol), qn = as.double(qn),
        cutoff = as.double(cutoff), ci = double(4 * p), tnmat = double(4 *
            p), as.double(big), as.logical(lci1))

# If I can get this to work and not crash
# then should just be a matter of porting the wrapper into a SKlearn style interface
# for br and fn. ppro is harder because it is more of an r source port.

# Also important to use 'conquer' package as that's reputed to be better than BR/FN
# And updated preprocessing when available

Cf2py intent(in) m
Cf2py intent(in) nn
Cf2py intent(in) m5
Cf2py intent(in) n3
Cf2py intent(in) n4
Cf2py intent(in) a
Cf2py intent(in) b
Cf2py intent(in) t
Cf2py intent(in) toler
Cf2py intent(out) ift
Cf2py intent(out) x
Cf2py intent(out) e
Cf2py intent(out) s
Cf2py intent(out) wa
Cf2py intent(out) wb
Cf2py intent(out) nsol
Cf2py intent(out) ndsol
Cf2py intent(out) sol
Cf2py intent(out) dsol
Cf2py intent(out) lsol
Cf2py intent(out) h
Cf2py intent(out) qn
Cf2py intent(out) cutoff
Cf2py intent(out) ci
Cf2py intent(out) tnmat
Cf2py intent(out) big
Cf2py intent(out) lci1

subroutine rqbr(m,nn,m5,n3,n4,a,b,t,toler,ift,x,e,s,wa,wb,nsol,ndsol,sol,dsol,lsol,h,qn,cutoff,ci,tnmat,big,lci1)
#
#     m = number of observations
#     n = number of parameters
#     m5 = m+5
#     n3 = n+3
#     n4 = n+4
#     a is the x matrix
#     b is the y vector
#     t, the desired quantile
#     toler, smallest detectable |x-y|/x machine precision to the 2/3
#     ift exit code:
#     		0-ok
#    		else dimensions inconsistent see below
#     x the parameter estimate betahat
#     e is the residual vector
#     s is an integer work array
#     wa is a real work array
#     wb is another real work array
#     nsol is an estimated (row) dimension of the primal solution array say 3*m; minimum value = 2
#     ndsol is an estimated (row) dimension of the dual solution array say 3*m; minimum value = 2
#     sol is the primal solution array
#     dsol is the dual solution arry
#     lsol is the actual dimension of the solution arrays
#     h is the matrix of basic observations indices
#     qn is the vector of residuals variances from the projection of each column of the x matrix on the remaining columns
#     cutoff, the critical point for N(0,1)
#     ci is the matrix of confidence intervals
#     tnmat is the matrix of the JGPK rank test statistics
#     big, large positive finite floating-point number
#     utilization:  if you just want a solution at a single quantile you
#     neednt bother with sol, nsol, etc, if you want all the solutions
#     then set theta to something <0 and sol and dsol will return all the
#     estimated quantile solutions.
#     the algorithm  is a slightly modified version of algorithm as 229
#     described in koenker and dorey, computing regression quantiles,
#     applied statistics, pp. 383-393.
#
integer i,j,k,kl,kount,kr,l,lsol,m,m1,m2,m3,m4,m5,ift
integer n,n1,n2,n3,nsol,ndsol,out,s(m),h(nn,nsol)
integer nn,n4,idxcf
logical stage,test,init,iend,lup
logical lci1,lci2,skip
double precision a1,aux,b1,big,d,dif,pivot,smax,t,t0,t1,tnt,dk
double precision min,max,toler,zero,half,one,two
double precision b(m),sol(n3,nsol),a(m,nn),x(nn),wa(m5,n4),wb(m)
double precision sum,e(m),dsol(m,ndsol)
double precision qn(nn),cutoff,ci(4,nn),tnmat(4,nn),tnew,told,tn
parameter( zero = 0.d0)
parameter( one = 1.d0)
parameter( two = 2.d0)
#
#  check dimension parameters
#
n=nn
ift = 0
wa(m+2,nn+1) = one
if (m5!=m+5)
  ift = 3
if (n3!=n+3)
  ift = 4
if (n4!=n+4)
  ift = 5
if (m<=zero||n<=zero)
  ift = 6
if (ift<=two) {
#
#  initialization
#
  half = one/two
  iend = .true.
  lci2 = .false.
  lup = .true.
  skip = .false.
  idxcf = 0
  tnew = zero
  tn = zero
  m1 = m+1
  n1 = n+1
  n2 = n+2
  m2 = m+2
  m3 = m+3
  m4 = m+4
  do j = 1,n{
    x(j) = zero
    }
  do i = 1,m
    e(i) = zero
  if (t<zero||t>one) {
    t0 = one/(two*float(m))
    t1 = one-t0
    t = t0
    iend = .false.
    lci1 = .false.
    }
  repeat { #0
    do i = 1,m {
      k = 1
      do j = 1,nn
        if (k<=nn){
          if(j==idxcf)
            skip = .true.
          else
            skip = .false.
          if(!skip){
            wa(i,k) = a(i,j)
            k = k+1
            }
          }
      wa(i,n4) = n+i
      wa(i,n2) = b(i)
      if (idxcf != 0)
        wa(i,n3) = tnew*a(i,idxcf)
      else
        wa(i,n3) = zero
      wa(i,n1) = wa(i,n2)-wa(i,n3)
      if (wa(i,n1)<zero)
        do j = 1,n4
          wa(i,j) = -wa(i,j)
      }
    do j = 1,n {
      wa(m4,j) = j
      wa(m2,j) = zero
      wa(m3,j) = zero
      do i = 1,m {
        aux = sign(one,wa(m4,j))*wa(i,j)
        wa(m2,j) = wa(m2,j)+aux*(one-sign(one,wa(i,n4)))
        wa(m3,j) = wa(m3,j)+aux*sign(one,wa(i,n4))
        }
      wa(m3,j) = two*wa(m3,j)
      }
    dif = zero
    init = .false.
    if(!lci2){
#compute the columns means
      do k = 1,n {
        wa(m5,k) = zero
        do i = 1,m{
          wa(m5,k) = wa(m5,k)+a(i,k)
          }
        wa(m5,k) = wa(m5,k)/float(m)
        }
      }
    lsol = 1
    kount = 0
    repeat { #1
#
# compute new marginal costs
#
      do j = 1,n{
        wa(m1,j) = wa(m2,j)+wa(m3,j)*t
        }
      if (!init) {
#
# stage 1
#
# determine the vector to enter the basis
#
        stage = .true.
        kr = 1
        kl = 1
        go to 30
        }
      repeat { #2
#
# stage 2
#
        stage = .false.
        repeat { #3
#
# determine the vector to enter the basis
#
          max = -big
          do j = kr,n {
            d = wa(m1,j)
            if (d<zero) {
              if (d>(-two))
                next 1
              d = -d-two
              }
            if (d>max) {
              max = d
              in = j
              }
            }
          if (max<=toler)
            break 2
          if (wa(m1,in)<=zero) {
            do i = 1,m4
              wa(i,in) = -wa(i,in)
            wa(m1,in) = wa(m1,in)-two
            wa(m2,in) = wa(m2,in)-two
            }
          repeat { #4
#
# determine the vector to leave the basis
#
            k = 0
            do i = kl,m {
              d = wa(i,in)
              if (d>toler) {
                k = k+1
                wb(k) = wa(i,n1)/d
                s(k) = i
                test = .true.
                }
              }
            repeat { #5
              if (k<=0)
                test = .false.
              else {
                min = big
                do i = 1,k
                  if (wb(i)<min) {
                    j = i
                    min = wb(i)
                    out = s(i)
                    }
                wb(j) = wb(k)
                s(j) = s(k)
                k = k-1
                }
#
# check for linear dependence in stage 1
#
              if (!test&&stage)
                break 1
              if (!test)
                break 5
              pivot = wa(out,in)
              if (wa(m1,in)-pivot-pivot<=toler){
                go to 10
                }
              do j = kr,n3 {
                d = wa(out,j)
                wa(m1,j) = wa(m1,j)-d-d
                wa(m2,j) = wa(m2,j)-d-d
                wa(out,j) = -d
                }
              wa(out,n4) = -wa(out,n4)
              } #5
            do i = 1,m4 {
              d = wa(i,kr)
              wa(i,kr) = wa(i,in)
              wa(i,in) = d
              }
            kr = kr+1
            go to 20
#
# pivot on wa(out,in)
#
            10  do j = kr,n3
              if (j!=in)
                wa(out,j) = wa(out,j)/pivot
            do i = 1,m3
              if (i!=out) {
                d = wa(i,in)
                do j = kr,n3
                  if (j!=in)
                    wa(i,j) = wa(i,j)-d*wa(out,j)
                }
            do i = 1,m3
              if (i!=out)
                wa(i,in) = -wa(i,in)/pivot
            wa(out,in) = one/pivot
            d = wa(out,n4)
            wa(out,n4) = wa(m4,in)
            wa(m4,in) = d
            kount = kount+1
            if (!stage)
              break 1
#
# interchange rows in stage 1
#
            kl = kl+1
            do j = kr,n4 {
              d = wa(out,j)
              wa(out,j) = wa(kount,j)
              wa(kount,j) = d
              }
            20  if (kount+kr==n1)
              break 2
            30  max = -one
            do j = kr,n
              if (abs(wa(m4,j))<=n) {
                d = abs(wa(m1,j))
                if (d>max) {
                  max = d
                  in = j
                  }
                }
            if (wa(m1,in)<zero)
              do i = 1,m4
                wa(i,in) = -wa(i,in)
            } #4
          } #3
        } #2
      if (kr==1) {
        do j = 1,n {
          d = abs(wa(m1,j))
          if (d<=toler||two-d<=toler){
            ift = 1
            wa(m2,nn+1) = zero
            go to 80
            }
          }
        }
      80 kount = 0
      sum = zero
      if (!lci2){
        do i = 1,kl-1 {
          k = wa(i,n4)*sign(one,wa(i,n4))
          x(k) = wa(i,n1)*sign(one,wa(i,n4))
          }
        }
      do i = 1,n {
        kd = abs(wa(m4,i))-n
        dsol(kd,lsol) = one+wa(m1,i)/two
        if (wa(m4,i)<zero)
          dsol(kd,lsol) = one-dsol(kd,lsol)
        if (!lci2){
          sum = sum + x(i)*wa(m5,i)
          sol(i+3,lsol) = x(i)
          h(i,lsol) = kd
          }
        }
      do i = kl,m {
        kd = abs(wa(i,n4))-n
        if (wa(i,n4)<zero)
          dsol(kd,lsol) = zero
        if (wa(i,n4)>zero)
          dsol(kd,lsol) = one
        }
      if (!lci2){
        sol(1,lsol) = smax
        sol(2,lsol) = sum
        sum = zero
        do j=kl,m{
          d = wa(j,n1)*sign(one,wa(j,n4))
          sum = sum + d*(smax + half*(sign(one,d) - one))
	 }
        sol(3,lsol) = sum
        do i=1,m
          dsol(i,lsol+1) = dsol(i,lsol)
        }
      if (lci2){
# compute next theta
        a1 = zero
        do i = 1,m {
          a1 = a1+a(i,idxcf)*(dsol(i,lsol)+t-one)
          }
        tn = a1/sqrt(qn(idxcf)*t*(one-t))
        if (abs(tn)<cutoff){
          if (lup)
            smax = big
          else
            smax = -big
          do i =1,kl-1 {
            k = wa(i,n4)*sign(one,wa(i,n4))
            sol(k,1) = wa(i,n2)*sign(one,wa(i,n4))
            sol(k,2) = wa(i,n3)*sign(one,wa(i,n4))/tnew
            }
          do i = kl,m {
            a1 = zero
            b1 = zero
            k = wa(i,n4)*sign(one,wa(i,n4))-n
            dk = wa(i,n4)*sign(one,wa(i,n4))
            l = 1
            do j = 1,n{
              if (j==idxcf)
                l = l+1
              a1 = a1 + a(k,l)*sol(j,1)
              b1 = b1 + a(k,l)*sol(j,2)
              l = l+1
              }
            tnt = (b(k)-a1)/(a(k,idxcf)-b1)
            if (lup){
              if (tnt>tnew)
                if (tnt<smax){
                  smax = tnt
                  out = i
                  }
              }
            else {
              if (tnt<tnew)
                if (tnt>smax){
                  smax = tnt
                  out = i
                  }
              }
            }
          if (lup){
            told = tnew
            tnew = smax + toler
            ci(3,idxcf) = told - toler
            tnmat(3,idxcf) = tn
            if (!(tnew < big-toler)){
              ci(3,idxcf) = big
              ci(4,idxcf) = big
              tnmat(3,idxcf) = tn
              tnmat(4,idxcf) = tn
              lup = .false.
              go to 70
              }
            }
          else{
            told = tnew
            tnew = smax - toler
            ci(2,idxcf) = told + toler
            tnmat(2,idxcf) = tn
            if (!(tnew > -big+toler)){
              ci(2,idxcf) = -big
              ci(1,idxcf) = -big
              tnmat(2,idxcf) = tn
              tnmat(1,idxcf) = tn
              lup = .true.
              go to 60
              }
            }
#update the new marginal cost
          do i = 1,m{
            wa(i,n3) = wa(i,n3)/told*tnew
            wa(i,n1) = wa(i,n2) - wa(i,n3)
            }
          do j = kr,n3{
            d = wa(out,j)
            wa(m1,j) = wa(m1,j) -d -d
            wa(m2,j) = wa(m2,j) -d -d
            wa(out,j) = -d
            }
          wa(out,n4) = -wa(out,n4)
          init = .true.
          }
        else{
          if (lup){
            ci(4,idxcf) = tnew - toler
            tnmat(4,idxcf) = tn
            lup = .false.
            go to 70
            }
          else{
            ci(1,idxcf) = tnew + toler
            tnmat(1,idxcf) = tn
            lup = .true.
            go to 60
            }
          }
        }
      if ((iend)&&(!lci2))
        go to 40
      if (!lci2){
        init = .true.
        lsol = lsol+1
        do i = 1,m
          s(i) = zero
        do j = 1,n
          x(j) = zero
#
#  compute next t
#
        smax = two
        do j = 1,n {
          b1 = wa(m3,j)
          a1 = (-two-wa(m2,j))/b1
          b1 = -wa(m2,j)/b1
          if (a1>=t)
            if (a1<smax) {
              smax = a1
              dif = (b1-a1)/two
              }
          if (b1>t)
            if (b1<smax) {
              smax = b1
              dif = (b1-a1)/two
              }
          }
        tnt = smax+toler*(one+abs(dif))
        if (tnt>=t1+toler)
          iend = .true.
        t = tnt
        if (iend)
          t = t1
        }
      } #1
    wa(m2,nn+1) = two
    ift = 2
    go to 50
    40  if (lsol>2) {
      sol(1,1) = zero
      #sol(2,1) = zero
      sol(3,1) = zero
      sol(1,lsol) = one
      #sol(2,lsol) = zero
      sol(3,lsol) = zero
      do i = 1,m {
        dsol(i,1) = one
        dsol(i,lsol) = zero
        dsol(i,lsol+1) = zero
        }
      }
    l = kl-1
    do i = 1,l
      if (wa(i,n1)<zero)
        do j = kr,n4
          wa(i,j) = -wa(i,j)
    50  sum = zero
    if(!lci2){
      do i = kl,m {
        k = wa(i,n4)*sign(one,wa(i,n4))
        d = wa(i,n1)*sign(one,wa(i,n4))
        sum = sum+d*sign(one,d)*(half+sign(one,d)*(t-half))
        k = k-n
        e(k) = d
        }
      wa(m2,n2) = kount
      wa(m1,n2) = n1-kr
      wa(m1,n1) = sum
      }
    if (wa(m2,nn+1)==two)
      break 1
    if (!lci1)
      break 1
    if (!lci2){
      lci2 = .true.
      n = nn-1
      n1 = n+1
      n2 = n+2
      n3 = n+3
      n4 = n+4
    60 idxcf = idxcf+1
      if (idxcf>nn){
        break 1
	}
    70  if (lup){
        tnew = x(idxcf)+toler
        told = tnew
        ci(3,idxcf) = x(idxcf)
        tnmat(3,idxcf) = zero
        }
      else{
        tnew = x(idxcf)-toler
        told = tnew
        ci(2,idxcf) = x(idxcf)
        tnmat(2,idxcf) = zero
        }
      }
    } #0
  # restore the original value of dual when ci is true
  do i=1,m
    dsol(i,lsol) = dsol(i,lsol+1)
  }
return
end


unscaledf <- function(dfs, meanvec, scaledata, scalefactor, zeromin) {
    ## reverses scaling
    if (zeromin == TRUE) dfs <- sweep(dfs, 2, (scalefactor/2), "-")
    scalerange <- (sapply(scaledata,max) - sapply(scaledata,min)) / scalefactor
    df <- sweep(dfs, 2, scalerange, "*")
    df <- sweep(df,  2, meanvec,    "+")
    df <- data.frame(df)
    ## names(df) <- gsub("_s", "", names(df))
    return(df)
}
## dfs.out <- scaled(dfs)
## dfs     <- dfs.out$dfs
## dfsu    <- unscaledf(dfs, meanvec=dfs.out$meanvec, scaledata=dfs.out$scaledata,
##                      scalefactor=dfs.out$scalefactor, zeromin=dfs.out$zeromin)


mydata<-read.csv("C:/Users/Harsh Darji/Desktop/EmployeeCleanedData.csv")
#Reading the csv file

head(mydata)

install.packages("arules")
#Installing the package arules

library(arules)
#loading package arules

install.packages("arulesViz")
#Installing the package arulesViz

head(mydata)

str(mydata)
# Structure of Dataframe

mydf<-mydata[,-which(names(mydata)=="Voluntary.Involuntary.Termination.Flag")]
# Removing this column as there are 1200 na values, making this variable insignificant

mydf$Termination.Reason.Description[is.na(mydf$Termination.Reason.Description)]<-"other"
mydf$Protected.Veteran.Status[is.na(mydf$Protected.Veteran.Status)]<-0
#Replacing NA in Termination.reason.description column by other as the reason to leave can e something else.
# Replacing NA in Protected.Veteran.Status by 0 as we do not have the metadata where we can understand values like 2,4.

head(mydf)

mydf$Attrition<-ifelse(mydf$Attrition==0,"Not left","Left")
# Attrition=0 ->Not left, Attrition=1-> Left

str(mydf)

mydf$Attrition<-as.factor(mydf$Attrition)
#Converting Attrition into factor

rules<-apriori(mydf,parameter=list(supp=0.001,conf=0.8),appearance=list(default='lhs',rhs='Attrition=Left'),control=list(verbose=F))
# Suport= 0.001
#Confidence=0.8

summary(rules)

inspect(rules[1:10])

#Following Factors lead to Attrition =1 i.e employee Leaving.
#Termination.Reason.Description=Death
#Protected.Veteran.Status=3
#Termination.Reason.Description=Fight on Co Prop
#Termination.Reason.Description=Poor Performance

new_rules<-apriori(mydf,parameter=list(supp=0.01,conf=0.7),appearance=list(default='lhs',rhs='Attrition=Left'),control=list(verbose=F))

#Support=0.01
#Confidence=0.7

summary(new_rules)

inspect(new_rules[1:10])

#Following Factors lead to Attrition =1 i.e employee Leaving.
#Termination.Reason.Description=Abandoned Job
#Termination.Reason.Description=Another Job
#Termination.Reason.Description=Abandoned Job,
      #Protected.Veteran.Status=2

top_rules<-head(sort(rules,by='lift'),10)

library(arulesViz)

plot(top_rules,method='graph')

plot(top_rules,method='paracoord')

new_top_rules<-head(sort(new_rules,by='lift'),10)

plot(new_top_rules,method='graph')

plot(top_rules,method='paracoord')

# Major Factors that lead to Attrition among employees are:
# Death
# Change of Job
#Poor Performance
#Abandoned Job and pay frequency is weekly
#Re location
#Fight on co op


# context("Area Under the Curve")

# test_that("Coincides with what the AUC::auc(roc()) function returns.", {

  set.seed(1231)
  x <- rnorm(100)
  y <- as.integer((.2*x + rnorm(100)) > 0)
  p <- stats::predict(stats::glm(y~0+x, family=binomial("probit")), type="response")

  ans0 <- auc(p, y, 100)
  ans1 <- AUC::auc(AUC::roc(p, as.factor(y)))

  expect_equal(ans0$auc, ans1, tol=0.01)

# })


library(ggplot2)
library(reshape)
library(scales)
library(choroplethr)

ggplot(grades_by_month, aes(x=month, y=value, group=variable, color=variable)) + geom_line() +
  geom_hline(aes(yintercept=avg), linetype="dashed", color="gray57") + xlab("") +
  ylab("% of Restaurants with 'A' Grade") + scale_y_continuous(labels=percent) +
  theme(legend.position="none") + ggtitle("NYC Restaurant Grades by Month of Year") +
  theme(plot.title=element_text(face="bold")) + facet_wrap(~ variable, ncol=1)

zip_choropleth(total_clean, county_zoom=manhattan, title="Manhattan Restaurant Grades by Zip Code", legend="% of Restaurants Graded A")


require("Matrix")
require("rsvd")
require("factoextra")
require("foreach")
require("dplyr")
require("doParallel")

#Pattern neighbors

calcRandPCA<-function(tmat, d=10, seed=42)
{
  # @param tmat A non-negative matrix with samples by features
  # @return A matrix with features by samples projected on PCA space
  set.seed(seed)

  rpca_obj <- rpca(tmat, k=d, center=T, scale=F, retx=T, p=10, q=7)
  rpca_obj$x
}

calcPDist <- function(tmat)
{
  get_dist(tmat,method = "pearson")
}

calcPContribution<-function(distMat)
{
  distMat<-as.matrix(distMat)
  rmat<-exp(-4.5*(distMat)^2)
  rmat[distMat>1]<-0
  diag(rmat)<-0

  return(Matrix(rmat, sparse=T))
}

findPNeighbors<-function(mat.pcontribution, positions, tau.p=16, nThreads=8)
{
  if(tau.p < 0)
    stop("Parameter tau.p must be 0 or positive.")

  bars<-positions$barcodes
  ind.bars<-1:length(bars)
  names(ind.bars)<-bars

  cl=makeCluster(nThreads)
  registerDoParallel(cl)

  p.neighbors<-foreach(i=1:length(bars),.packages = c("dplyr","Matrix")) %dopar%
    {
      a<-positions[mat.pcontribution[,i]>0,]
      if(nrow(a)>0){
        b<-a %>%
          mutate(p.contribution = mat.pcontribution[ind.bars[barcodes],i])
        if(0 == tau.p || nrow(a)<tau.p)
          b %>% mutate(ps.contribution = p.contribution/(sum(p.contribution)+0.00000001))
        else
          (b %>% arrange(desc(p.contribution)))[1:tau.p,] %>% mutate(ps.contribution = p.contribution/(sum(p.contribution)+0.00000001))
      } else
        NULL
    }

  stopCluster(cl)

  names(p.neighbors)<-bars

  return(p.neighbors)

}

#Spatial neighbors

GetPointNeighbors<-function(px,py,order=2,is.keepself=F)
{

  x.range<-(px-order):(px+order)
  x.range<-x.range[x.range>=0]
  y.range<-(py-order):(py+order)
  y.range<-y.range[y.range>=0]

  x.range<-rep.int(x.range,times=length(y.range))
  x.range<-sort(x.range)

  points<-data.frame(x=x.range, y=y.range)

  points<-points %>% mutate(distance=abs(x-px)+abs(y-py)) %>%
    filter(distance <= order)

  if(!is.keepself)
    points<-points %>% filter(distance>0)

  return(points)

}

findSNeighbors<-function(positions, is.hexa=F , tau.s=2, nThreads=8)
{
  if(is.hexa)
    tau.s<-tau.s*2

  bars<-positions$barcodes
  ind.bars<-1:length(bars)
  names(ind.bars)<-bars

  cl=makeCluster(nThreads)
  registerDoParallel(cl)

  s.neighbors<-foreach(i=1:length(bars),.packages =c("dplyr","Matrix"),.export = c("GetPointNeighbors")) %dopar%
    {
      a<-inner_join(x=positions, y=GetPointNeighbors(px=positions$st.x[i],py=positions$st.y[i],order = tau.s),by=c("st.x"="x","st.y"="y"))
      if(nrow(a)>0){
        a %>%
        mutate(s.contribution=(1/distance)) %>%
        mutate(ss.contribution=s.contribution/(sum(s.contribution)+0.00000001))
      } else
        NULL
    }

  stopCluster(cl)

  names(s.neighbors)<-positions$barcodes

  return(s.neighbors)

}

#get combined smoothed expression matrix

getCSmoothedExp<-function(exp, s.neighbors, p.neighbors, alpha, beta, nThreads=8)
{
  bars<-names(p.neighbors)
  ind.bars<-1:length(p.neighbors)
  names(ind.bars)<-bars

  cl=makeCluster(nThreads)
  registerDoParallel(cl)

  s.exp<-foreach(i=1:length(bars),.combine = "cbind",.packages = c("dplyr","Matrix")) %dopar%
    {
      if(!is.null(s.neighbors[[i]]))
        exp[,ind.bars[s.neighbors[[i]]$barcodes]] %*% Matrix(s.neighbors[[i]]$ss.contribution,sparse=T)
      else
        0
    }

  p.exp<-foreach(i=1:length(bars),.combine = "cbind",.packages = c("dplyr","Matrix")) %dopar%
    {
      if(!is.null(p.neighbors[[i]]))
        exp[,ind.bars[p.neighbors[[i]]$barcodes]] %*% Matrix(p.neighbors[[i]]$ps.contribution,sparse=T)
      else
        0
    }

  stopCluster(cl)

  exp.smoothed<-exp * (1-alpha) +
    (s.exp * beta + p.exp * (1-beta))*alpha

  return(exp.smoothed)
}

fillBlanks<-function(exp, coord, is.hexa=F, tau.s=2, filling.threshold = 0.5, nThreads = 8)
{

  x.bounds<-c(min(coord$st.x),max(coord$st.x))
  y.bounds<-c(min(coord$st.y),max(coord$st.y))
  x.availible<-x.bounds[1]:x.bounds[2]
  y.availible<-y.bounds[1]:y.bounds[2]
  x.availible<-sort(rep(x.availible,length(y.availible)))
  coord.maybe<-data.frame(st.x=x.availible,st.y=y.availible)

  if(is.hexa)
  {
    tau.s<-tau.s*2
    coord.maybe<- coord.maybe %>%
      mutate(is.exist = ((st.x %% 2) == (st.y %% 2))) %>%
      select(st.x,st.y)
   }

  coord.maybe<-suppressMessages(coord %>% right_join(coord.maybe,copy = T) %>% filter(is.na(barcodes)))
  coord.maybe$barcodes<-paste0("SUPP",1:nrow(coord.maybe))

  cl=makeCluster(nThreads)
  registerDoParallel(cl)

  s.neighbors<-foreach(i=1:nrow(coord.maybe),.packages = c("dplyr"),.export = c("GetPointNeighbors")) %dopar%
    {
      nbs.maybe<-GetPointNeighbors(px = coord.maybe$st.x[i],py = coord.maybe$st.y[i],order = tau.s)
      if(is.hexa)
        nbs.maybe<-nbs.maybe %>% filter(0 == distance %% 2)

      nbs<-coord %>% inner_join(nbs.maybe,by=c("st.x"="x","st.y"="y"))
      if(nrow(nbs)>filling.threshold * nrow(nbs.maybe))
      {
        nbs %>%
        mutate(s.contribution=(1/distance)) %>%
        mutate(ss.contribution=s.contribution/(sum(s.contribution)+0.00000001))
      } else
      NULL
    }

  names(s.neighbors)<-coord.maybe$barcodes
  s.neighbors<-s.neighbors[sapply(s.neighbors,function(x){!is.null(x)})]

  if(0==length(s.neighbors))
  {
    s.exp<-NULL
    s.neighbors<-NULL
  }
  else
  {
    s.exp<-foreach(i=1:length(s.neighbors),.combine = "cbind",.packages = c("dplyr","Matrix")) %dopar%
      {
        exp[,s.neighbors[[i]]$barcodes] %*% Matrix(s.neighbors[[i]]$ss.contribution,sparse=T)
      }
    colnames(s.exp)<-names(s.neighbors)
  }
  stopCluster(cl)

  return(list(exp=s.exp,colData=filter(coord.maybe,barcodes %in% names(s.neighbors))))
}

#Run SPCS
SPCS<-function(data.tbl, coor.tbl, is.hexa = F, is.padding =T, tau.p=16, tau.s=2, alpha=0.6, beta=0.4, filling.thres=0.5, nThreads=8)
{
  data.mat<-Matrix(as.matrix(data.tbl))

  message(paste0("SPCS Smoothing on ",ncol(data.tbl)," spots with ",nrow(data.tbl)," genes"))
  message("1) Pre-processing...",appendLF = F)

  t0<-proc.time()

  rpca.res = calcRandPCA(t(data.mat))
  pdist.mat = calcPDist(rpca.res)
  rmat = calcPContribution(pdist.mat)

  positions = coor.tbl
  colnames(positions) = c("st.x","st.y")
  positions$barcodes = rownames(positions)

  t1<-proc.time()
  message("Finished. Time Elapsed:",(t1-t0)["elapsed"],"secs (incl. sys. cost",(t1-t0)["sys.self"],"secs).")

  message("2) Detecting neighbors...\n"," --Pattern neighbors...",appendLF = F)
  t0<-proc.time()

  p.neighbors <- findPNeighbors(rmat, positions, tau.p, nThreads)

  t1<-proc.time()
  message("Finished. Time Elapsed:",(t1-t0)["elapsed"],"secs (incl. sys. cost",(t1-t0)["sys.self"],"secs).\n"," --Spatial neighbors...",appendLF = F)
  t0<-proc.time()

  s.neighbors <- findSNeighbors(positions,is.hexa, tau.s, nThreads)

  t1<-proc.time()
  message("Finished. Time Elapsed:",(t1-t0)["elapsed"],"secs (incl. sys. cost",(t1-t0)["sys.self"],"secs).")

  message("3) Calculating expression...",appendLF = F)
  t0<-proc.time()

  data.tbl.combinedsmooth = getCSmoothedExp(data.mat, s.neighbors, p.neighbors, alpha, beta, nThreads)

  t1<-proc.time()
  message("Finished. Time Elapsed:",(t1-t0)["elapsed"],"secs (incl. sys. cost",(t1-t0)["sys.self"],"secs).")

  if(is.padding)
  {
    message("4) Filling blank spots...",appendLF = F)
    t0<-proc.time()

    filled.blanks<-fillBlanks(data.tbl.combinedsmooth, positions, is.hexa, tau.s, filling.thres, nThreads)

    t1<-proc.time()
    message("Finished. Time Elapsed:",(t1-t0)["elapsed"],"secs (incl. sys. cost",(t1-t0)["sys.self"],"secs).\n",
        nrow(filled.blanks$colData),"blank spots has been filled.")
    data.tbl.combinedsmooth = as.data.frame(as.matrix(cbind(data.tbl.combinedsmooth,filled.blanks$exp)))
    attr(data.tbl.combinedsmooth,"SUPP_ColData")<-filled.blanks$colData
  }
  else
  {
    data.tbl.combinedsmooth = as.data.frame(as.matrix(data.tbl.combinedsmooth))
  }

  if (sum(is.na(data.tbl.combinedsmooth)) > 0) {
    mean.exp = sum(data.tbl.combinedsmooth[!is.na(data.tbl.combinedsmooth)]) / sum(!is.na(data.tbl.combinedsmooth))
    data.tbl.combinedsmooth[is.na(data.tbl.combinedsmooth)] = mean.exp
  }

  return(data.tbl.combinedsmooth)
}


source("dataprocessing/read_data.r")
source("mapping/epimap.r")
source("dataprocessing/process_radiation_fluxes.r")

opt = Rmap_options()

readdata = function(filename,...) {
    read.csv(sprintf('%s/%s.csv',opt$data_directory,filename),...)
}

df <- readdata("areas",row.names=1)
N <- nrow(df)
areas <- rownames(df)
quoted_areas <- sapply(areas,function(s) paste('"',s,'"',sep=''))
geoloc <- df[,1:2]
population <- df[,3]
population <- as.double(population)

geodist <- readdata("distances",row.names=1)
colnames(geodist) <- areas

for (radiation_length_scale in c(.1,.2,.5)) {
  numrep <- 100000
  val = compute_radiation_fluxes(numrep, radiation_length_scale, population, geodist)

  write.matrix.csv(val$flux,sprintf('data/radiation_flux_ls=%1.1f_2.csv',radiation_length_scale))
  write.matrix.csv(val$flux_sd,sprintf('data/radiation_flux_sd_ls=%1.1f_2.csv',radiation_length_scale))
}


#!/usr/bin/env Rscript
####################################################################################
### Copyright (C) 2015-2019 by ABLIFE
####################################################################################

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

####################################################################################
# Date           Version       Author            ChangeLog

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

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

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

#####################################################################################
suppressPackageStartupMessages(library("optparse"))
suppressPackageStartupMessages(library("stats"))

usage = "The prog is used to display the result of the correlation between two samples choiced by parameters:-s -c

example: Rscript %prog -f /users/ablife/ablife-R/Line/Cor_line/latest/expressed_gene_RPKM.txt.tmp -l 10 -s 2 -c 3 -o ./"

option_list <- list(
	make_option(c("-f", "--file"),action = "store",type = "character",
		help = "The Input RPKM file"),
	make_option(c("-l", "--logValue"),action = "store",type = "character",default = "10",
		help = "The base of the log"),
	make_option(c("-s","--firstsample"),action = "store",type = "integer",
		help = "The first sample to solve the correlation"),
	make_option(c("-c","--secondsample"),action = "store",type = "integer",
		help = "The second sample to solve the correlation"),
	make_option(c("-o", "--outdir"),action = "store",type = "character",default = "./",
		help = "The outdir")
	)
# parser <- OptionParser(usage = "%prog [option] file",option_list =option)

# arguments <- parse_args(parser,positional_arguments = 2)
opt <- parse_args(OptionParser(option_list = option_list,usage = usage))

if(!is.character(opt$filename)){
	opt$filename = gsub(" ","_",opt$title)
}
log_base <- as.numeric(opt$logValue)
setwd(opt$outdir)

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

###################################################################################
library(ggplot2)
library(reshape2)
library(plotrix)
library(methods)
###################################################################################
colour <- c('#85A2EF','#D285EF','#A2EF85','#4682B4','#A0522D','#87CEEB','#6B8E23','#6A5ACD','#E59B95','#EFD285','#B4B643','#2E9AFE','#A1DDBB','#FF8C00')

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

data <- read.table(file = opt$file,header = T,sep = '\t',stringsAsFactors=FALSE,check.names = FALSE)
colname <- colnames(data)
colname
x <- log(data[,opt$firstsample]+1,log_base)
y <- log(data[,opt$secondsample]+1,log_base)

Max <- max(max(x),max(y))

CorResult <- cor(x,y,method = 'pearson')
CorResult
CorResult <- round(CorResult,3)
CorResult <- paste("italic(R)==",CorResult,sep='')

# colname[1] <- sub('X.','',colname[1])

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

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

ablife_theme_Cor <- function(base_size = 12){
	library(grid)		####for using unit function
	theme(
		plot.title = element_text(size=34,lineheight = 10,colour="#000000",face ="bold",family = "sans",vjust = 1),

		axis.title.x = element_text(size=28,colour = "#000000",vjust = 0.5),
		axis.title.y = element_text(size=28,colour = "#000000",vjust = 1),
		axis.text.x = element_text(size = 22,colour = "#000000"),
		axis.text.y = element_text(size = 22,colour = "#000000"),
		axis.ticks.length = unit(0.25,"cm"),
		axis.ticks = element_line(colour = "#000000"),

		legend.title = element_text(size = 15),
		legend.text = element_text(size = 15),
		legend.key.size = unit(1.2,"cm"),

		panel.background = element_rect(fill = "white",colour = NA),
		# panel.border = element_rect(size = 1,colour = "#8B8B8B",fill =NA),
		# panel.grid.major = element_line(size=0.5,colour = "#BFBFBF"),
		# panel.grid.minor = element_line(size=0.1,colour = "#7F7F7F")
		panel.border = element_rect(size = 1.5,colour = "#000000",fill =NA)
		)
}

# outname = gsub(" ","_",Image_name)
png(file=paste(colname[opt$firstsample],'_vs_',colname[opt$secondsample],"_lm.png",sep=''),pointsize=60,width=600,height=600)
ggplot(data)+
		geom_point(aes(x = x,y=y,stat = "identity"),position = "identity",colour = "dodgerblue3")+
		labs(x=colname[opt$firstsample],y= colname[opt$secondsample])+
		ablife_theme_Cor()+
		geom_abline(aes(intercept=0,slope=1),linetype = "dashed",size = 1.5,colour = "gray6")+
		# geom_text(aes(x= 0.4*max(x),y=0.8*max(y),label = CorResult),size =10,fontsize=1,fontface = "italic",parse= TRUE)+
		annotate("text",x= 0.4*max(x),y=0.8*max(y),label = CorResult,size= 12,parse = TRUE)+
		xlim(c(0,Max))


library(dplyr)
library(ggplot2)
library(FNN)
library(rpart)
library(randomForest)
library(xgboost)

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

## Import datasets needed for chapter 6
PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')

loan200 <- read.csv(file.path(PSDS_PATH, 'data', 'loan200.csv'))
loan200$outcome <- ordered(loan200$outcome, levels=c('paid off', 'default'))

loan3000 <- read.csv(file.path(PSDS_PATH, 'data', 'loan3000.csv'))
loan3000$outcome <- ordered(loan3000$outcome, levels=c('paid off', 'default'))

loan_data <- read.csv(file.path(PSDS_PATH, 'data', 'loan_data.csv'))
loan_data <- select(loan_data, -X, -status)

## KNN
## the first row of loan200 is the target data
newloan <- loan200[1, 2:3, drop=FALSE]
knn_pred <- knn(train=loan200[-1,2:3], test=newloan, cl=loan200[-1,1], k=20)
knn_pred == 'paid off'

## look at the nearest 20 records
loan200[attr(knn_pred, 'nn.index')-1, ]
dist <- attr(knn_pred, 'nn.dist')

circleFun <- function(center = c(0,0), r = 1, npoints = 100){
  tt <- seq(0, 2*pi, length.out = npoints-1)
  xx <- center[1] + r * cos(tt)
  yy <- center[2] + r * sin(tt)
  return(data.frame(x = c(xx, xx[1]), y = c(yy, yy[1])))
}

circle_df <- circleFun(center=unlist(newloan), r=max(dist), npoints=201)
loan200_df <- bind_cols(loan200, circle_df)

## Code for figure 6-2: small KNN example
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0602.png'), width = 5.5, height=4, units='in', res=300)

ggplot(data=loan200_df, aes(x=payment_inc_ratio, dti, color=outcome, shape=outcome)) +
  geom_point(size=2) +
  scale_shape_manual(values = c(1, 4, 15)) +
  geom_path(aes(x=x, y=y), color='black') +
  xlim(3, 15) +
  ylim(17, 29) +
  theme_bw()

dev.off()

## Standardization
loan_df <- model.matrix(~ -1 + payment_inc_ratio + dti + revol_bal + revol_util, data=loan_data)
newloan = loan_df[1,, drop=FALSE]
loan_df = loan_df[-1,]
outcome <- loan_data[-1,1]
knn_pred <- knn(train=loan_df, test=newloan, cl=outcome, k=5)
knn_pred
loan_df[attr(knn_pred,"nn.index"),]

loan_df <- model.matrix(~ -1 + payment_inc_ratio + dti + revol_bal + revol_util, data=loan_data)
loan_std <- scale(loan_df)
target_std = loan_std[1,, drop=FALSE]
loan_std = loan_std[-1,]
outcome <- loan_data[-1,1]
knn_pred <- knn(train=loan_std, test=target_std, cl=outcome, k=5)
knn_pred
loan_df[attr(knn_pred,"nn.index"),]

## Create a feature for borrowers
borrow_df <- model.matrix(~ -1 + dti + revol_bal + revol_util + open_acc +
                            delinq_2yrs_zero + pub_rec_zero, data=loan_data)
borrow_knn <- knn(borrow_df, test=borrow_df, cl=loan_data[, 'outcome'], prob=TRUE, k=20)
prob <- attr(borrow_knn, "prob")
borrow_feature <- ifelse(borrow_knn=='default', 1-prob, prob)
summary(borrow_feature)

loan_data$borrower_score <- borrow_feature

################################################################
# Decision trees

loan_tree <- rpart(outcome ~ borrower_score + payment_inc_ratio,
                   data=loan3000,
                   control = rpart.control(cp=.005))

## Figure 6-3: Rules for simple tree model (not same as in book)
png(filename=file.path(PSDS_PATH, 'figures', 'psds_rpart_tree.png'),  width = 6, height=4, units='in', res=300)

par(mar=c(0,0,0,0)+.1)
plot(loan_tree, uniform=TRUE, margin=.05)
text(loan_tree, cex=.75)

dev.off()

## Figure 6-4: View of partition rules
r_tree <- data_frame(x1 = c(0.575, 0.375, 0.375, 0.375, 0.475),
                     x2 = c(0.575, 0.375, 0.575, 0.575, 0.475),
                     y1 = c(0,         0, 10.42, 4.426, 4.426),
                     y2 = c(25,       25, 10.42, 4.426, 10.42),
                     rule_number = factor(c(1, 2, 3, 4, 5)))
r_tree <- as.data.frame(r_tree)

labs <- data.frame(x=c(.575 + (1-.575)/2,
                       .375/2,
                       (.375 + .575)/2,
                       (.375 + .575)/2,
                       (.475 + .575)/2,
                       (.375 + .475)/2
                       ),
                   y=c(12.5,
                       12.5,
                       10.42 + (25-10.42)/2,
                       4.426/2,
                       4.426 + (10.42-4.426)/2,
                       4.426 + (10.42-4.426)/2
                       ),
                   decision = factor(c('paid off', 'default', 'default', 'paid off', 'paid off', 'default')))

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0604.png'), width = 6, height=4, units='in', res=300)

ggplot(data=loan3000, aes(x=borrower_score, y=payment_inc_ratio)) +
  geom_point( aes(color=outcome, shape=outcome), alpha=.5) +
  scale_color_manual(values=c('blue', 'red')) +
  scale_shape_manual(values = c(1, 46)) +
  # scale_shape_discrete(solid=FALSE) +
  geom_segment(data=r_tree, aes(x=x1, y=y1, xend=x2, yend=y2, linetype=rule_number), size=1.5, alpha=.7) +
  guides(colour = guide_legend(override.aes = list(size=1.5)),
         linetype = guide_legend(keywidth=3, override.aes = list(size=1))) +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), limits=c(0, 25)) +
  geom_label(data=labs, aes(x=x, y=y, label=decision)) +
  #theme(legend.position='bottom') +
  theme_bw()

dev.off()

## Gini coefficient and impurity

info <- function(x){
  info <- ifelse(x==0, 0, -x * log2(x) - (1-x) * log2(1-x))
  return(info)
}
x <- 0:50/100
plot(x, info(x) + info(1-x))

gini <- function(x){
  return(x * (1-x))
}
plot(x, gini(x))

impure <- data.frame(p = rep(x, 3),
                     impurity = c(2*x,
                                  gini(x)/gini(.5)*info(.5),
                                  info(x)),
                     type = rep(c('Accuracy', 'Gini', 'Entropy'), rep(51,3)))

## Figure 06-05: comparison of impurity measures
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0605.png'), width = 5, height=4, units='in', res=300)

ggplot(data=impure, aes(x=p, y=impurity, linetype=type, color=type)) +
  geom_line(size=1.5) +
  guides( linetype = guide_legend( keywidth=3, override.aes = list(size=1))) +
  scale_x_continuous(expand=c(0,0.01)) +
  scale_y_continuous(expand=c(0,0.01)) +
  theme_bw() +
  theme( legend.title=element_blank())

dev.off()

###############################################################################
# ensemble models: random forest

rf <- randomForest(outcome ~ borrower_score + payment_inc_ratio,
                   data=loan3000)
rf

## Figure 6-6: error rate of random forest
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0606.png'), width = 5, height=4, units='in', res=300)

error_df = data.frame(error_rate = rf$err.rate[,'OOB'],
                      num_trees = 1:rf$ntree)
ggplot(error_df, aes(x=num_trees, y=error_rate)) +
  geom_line()  +
  theme_bw()

dev.off()

## Figure 6-7: plot of random forest predictions
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0607.png'),  width = 5, height=4, units='in', res=300)

pred <- predict(rf, prob=TRUE)
rf_df <- cbind(loan3000, pred = pred)

ggplot(data=rf_df, aes(x=borrower_score, y=payment_inc_ratio,
                       shape=pred, color=pred)) +
  geom_point(alpha=.6, size=2) +
  scale_shape_manual( values=c( 46, 4)) +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  theme_bw()
dev.off()

# A nice plot showing a gradient of predictions but not as illustrative as the prior plot
## not in book
png(filename=file.path(PSDS_PATH, 'figures', 'psds_rf_gradient.png'),  width = 5, height=4, units='in', res=300)
ggplot(data=rf_df, aes(x=borrower_score, y=payment_inc_ratio, color=prob_default)) +
  geom_point(alpha=.6) +
  scale_color_gradient2(low='blue', mid='white', high='red', midpoint=.5) +
  scale_x_continuous(expand=c(0,0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  theme(legend.position='bottom') +
  geom_line(data=lda_df0, col='green', size=2, alpha=.8)
dev.off()

## Fit random forest to all the data; this can take a while and
## may cause problems if you don't have enough RAM
rf_all <- randomForest(outcome ~ ., data=loan_data, importance=TRUE)
rf_all

varImpPlot(rf_all, type=1)

imp1 <- importance(rf_all, type=1)
imp2 <- importance(rf_all, type=2)
idx <- order(imp1[,1])
nms <- factor(row.names(imp1)[idx], levels=row.names(imp1)[idx])
imp <- data.frame(Predictor = rep(nms, 2),
                  Importance = c(imp1[idx, 1], imp2[idx, 1]),
                  Type = rep( c('Accuracy Decrease', 'Gini Decrease'), rep(nrow(imp1), 2)))

## Figure 6-8: Variable importance plot for random forest
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0608.png'),  width = 4, height=6, units='in', res=300)

ggplot(imp) +
  geom_point(aes(y=Predictor, x=Importance), size=2, stat="identity") +
  facet_wrap(~Type, ncol=1, scales="free_x") +
  theme(
    panel.grid.major.x = element_blank() ,
    panel.grid.major.y = element_line(linetype=3, color="darkgray") ) +
  theme_bw()

dev.off()

## search over hyperparameter space (not in book); this takes a while
loan_data1 <- loan_data0[,-which(names(loan_data0) %in% 'emp_length')]
loan_data1$term = factor(loan_data1$term)
loan_data1$emp_length = factor(loan_data1$emp_length>1)

params <- data.frame(nodesize = c(5, 15, 25, 5, 10, 25),
                     mtry = c(3, 3, 3, 5, 5, 5))
rf_list <- vector('list', 6)
for(i in 1:nrow(params)){
  rf_list[[i]] <- randomForest(outcome ~ ., data=loan_data, mtry=params[i, 'mtry'],
                               nodesize = params[i,'nodesize'], ntree=100)
}

rf_list[[1]]$confusion

###############################################################################
# ensemble models: xgboost

predictors <- data.matrix(loan3000[, c('borrower_score', 'payment_inc_ratio')])
label <- as.numeric(loan3000[,'outcome'])-1
xgb <- xgboost(data=predictors, label=label, objective = "binary:logistic",
               params=list(subsample=.63, eta=0.1), nrounds=100)

pred <- predict(xgb, newdata=predictors)
xgb_df <- cbind(loan3000, pred_default=pred>.5, prob_default=pred)

## Figure 6-9: prediction from xgboost
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0609.png'), width = 5, height=4, units='in', res=300)

ggplot(data=xgb_df, aes(x=borrower_score, y=payment_inc_ratio,
                        color=pred_default, shape=pred_default)) +
  geom_point(alpha=.6, size=2) +
  scale_shape_manual( values=c( 46, 4)) +
  scale_x_continuous(expand=c(.03, 0)) +
  scale_y_continuous(expand=c(0,0), lim=c(0, 20)) +
  theme_bw()

dev.off()

## Create a test and training set and compare the learning rates under different hyperparameter choices
seed <- 400820
predictors <- data.matrix(loan_data[,-which(names(loan_data) %in% 'outcome')])
label <- as.numeric(loan_data$outcome)-1
test_idx <- sample(nrow(loan_data), 10000)

xgb_default <- xgboost(data=predictors[-test_idx,], label=label[-test_idx],
                       objective = "binary:logistic", nrounds=250, verbose=0)
pred_default <- predict(xgb_default, predictors[test_idx,])
error_default <- abs(label[test_idx] - pred_default) > 0.5
xgb_default$evaluation_log[250,]
mean(error_default)

xgb_penalty <- xgboost(data=predictors[-test_idx,],
                       label=label[-test_idx],
                       params=list(eta=.1, subsample=.63, lambda=1000),
                       objective = "binary:logistic", nrounds=250, verbose=0)
pred_penalty <- predict(xgb_penalty, predictors[test_idx,])
error_penalty <- abs(label[test_idx] - pred_penalty) > 0.5
xgb_penalty$evaluation_log[250,]
mean(error_penalty)

error_default <- rep(0, 250)
error_penalty <- rep(0, 250)
for(i in 1:250)
{
  pred_default <- predict(xgb_default, predictors[test_idx,], ntreelimit = i)
  error_default[i] <- mean(abs(label[test_idx] - pred_default) > 0.5)
  pred_penalty <- predict(xgb_penalty, predictors[test_idx,], ntreelimit = i)
  error_penalty[i] <- mean(abs(label[test_idx] - pred_penalty) > 0.5)
}

errors <- rbind(xgb_default$evaluation_log,
                xgb_penalty$evaluation_log,
                data.frame(iter=1:250, train_error=error_default),
                data.frame(iter=1:250, train_error=error_penalty))
errors$type <- rep(c('default train', 'penalty train',
                     'default test', 'penalty test'), rep(250, 4))

## Figure 6-10: learning rates for different choices of hyperparameters
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0610.png'), width = 6, height=4, units='in', res=300)

ggplot(errors, aes(x=iter, y=train_error, group=type)) +
  geom_line(aes(linetype=type, color=type), size=1) +
  scale_linetype_manual(values=c('solid', 'dashed', 'dotted', 'longdash')) +
  theme_bw() +
  theme(legend.key.width = unit(1.5,"cm")) +
  labs(x="Iterations", y="Error") +
  guides(colour = guide_legend(override.aes = list(size=1)))

dev.off()

## Cross validation
N <- nrow(loan_data)
fold_number <- sample(1:5, N, replace = TRUE)
params <- data.frame(eta = rep(c(.1, .5, .9), 3),
                     max_depth = rep(c(3, 6, 12), rep(3,3)))
rf_list <- vector('list', 9)
error <- matrix(0, nrow=9, ncol=5)
for(i in 1:nrow(params)){
  for(k in 1:5){
    cat('Fold', k, 'for model', i, '\n')
    fold_idx <- (1:N)[fold_number == k]
    xgb <- xgboost(data=predictors[-fold_idx,], label=label[-fold_idx],
                   params = list(eta = params[i, 'eta'],
                                 max_depth = params[i, 'max_depth']),
                   objective = "binary:logistic", nrounds=100, verbose=0)
    pred <- predict(xgb, predictors[fold_idx,])
    error[i, k] <- mean(abs(label[fold_idx] - pred) >= 0.5)
  }
}

avg_error <- 100 * round(rowMeans(error), 4)
cbind(params, avg_error)


library(ggplot2)
library(ggvis)
library(dplyr)
library(rgdal)
library(mosaic)
library(maptools)
library(ggmap)
library(mapproj)

source('lib/libraries.r', encoding = 'UTF-8')

#Brezposelnost v Sloveniji na splošno
osnovni_graf <- ggplot(slovenija, aes(x=leto, y=brezposelnost, fill="5"), )+
  ggtitle('Brezposelnost glede na celotno Slovenijo v 1000')+
  geom_bar(stat = 'identity', position = 'dodge') +
  scale_x_continuous('Leto', breaks = seq(2008, 2018, 1), limits = c(2007,2019)) +
  theme(legend.position = "none")

#Graf stopnje brezposelnosti skozi leta glede na staistične
vec_graf <- ggplot(data = graf_regije, mapping = aes(x=regija, y=stopnja_brezposelnosti, fill=factor(leto))) +
  labs(fill='leto') +
  ggtitle('Brezposelnost na 1000 prebivalcev po regijah') +
  geom_bar(stat = 'identity', position = 'dodge') +
  labs(x = 'Regija', y = 'Stopnja brezposelnosti') +
  theme(axis.text.x = element_text(angle = 90, size = 8))

#Zemljevid brezposelnosti po statističnih regijah glede na 1000 ljudi
  #za leto 2010

Slovenija <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", encoding="UTF-8") %>% fortify()
colnames(Slovenija)[12]<-'regija'
Slovenija$regija <- gsub('Notranjsko-kraška', 'Primorsko-notranjska', Slovenija$regija)
Slovenija$regija <- gsub('Spodnjeposavska', 'Posavska', Slovenija$regija)

zemljevid.brezposelnost.2010 <- ggplot() +
  geom_polygon(data = right_join(brezposelnost.2010,Slovenija, by = c('regija')),
               aes(x = long, y = lat, group = group, fill = stopnja_brezposelnosti))+
  xlab("") + ylab("") + ggtitle('Brezposelnost v letu 2010') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#FCDADA', high='#970303', limits=c(3,12)) +
  labs(fill="Stopnja brezposelnosti")

  #za leto 2018

zemljevid.brezposelnost.2018 <- ggplot() +
  geom_polygon(data = right_join(brezposelnost.2018,Slovenija, by = c('regija')),
               aes(x = long, y = lat, group = group, fill = stopnja_brezposelnosti))+
  xlab("") + ylab("") + ggtitle('Brezposelnost v letu 2018') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#FCDADA', high='#970303',limits=c(3,12)) +
  labs(fill="Stopnja brezposelnosti")

#Grafki brezposelnosti v Sloveniji glede na stopnjo dosežene izobrazbe

graf_izobrazba <- ggplot(data = izobrazba, mapping = aes(x=leto, y=brezposelnost, col="4")) +
  ggtitle('Brezposelnost glede na stopnjo dosežene izobrazbe') +
  geom_point() +
  facet_wrap(izobrazbe~., ncol=3) +
  theme(axis.text.x = element_text(angle = 90, size = 6))+
  scale_x_continuous('Leto', breaks = seq(2008, 2018, 1), limits = c(2007,2019)) +
  theme(legend.position = "none")

#Brezposelnost glede na trajanje iskanja dela

graf_trajanje <- ggplot((data = trajanje), aes(x=leto, y=brezposelnost, col=cas)) + geom_point() + geom_line() +
  scale_x_continuous('Leto', breaks = seq(2008, 2018, 1), limits = c(2008,2018)) +
  ggtitle('Brezposelnost na 1000 prebivalcev glede na čas iskanja dela') +
  labs(colour = "Čas iskanja dela")

graf.trajanje <- ggplot((data=trajanje), aes(x=leto, y=brezposelnost, col=cas))


#Worldclim2 temperature model.
#clearn environment, load packages.
rm(list=ls())
library(runjags)

#output path for temperature summary object.
out.path <- '/fs/data3/caverill/NEFI_microbial/worldclim2_uncertainty/temperature_JAGS_model.rds'

#load data
temp <- readRDS('/fs/data3/caverill/NEFI_microbial/worldclim2_uncertainty/worldclim2_tavg_uncertainty.rds')

#subset prec for prelim fitting.
temp <- temp[sample(nrow(temp),30000),]

#setup runjags model. Temperature has constant variance.
temp.model = "
model {
#setup priors for model predictors.
for(j in 1:N.preds){
m[j] ~ dnorm(0, .0001) #flat uninformative priors.
}

#tau is still a function of sigma.
#sigma is now a funtion of an intercept (as before) and elevation, with a parameter that gets fitted.
sigma ~ dunif(0,100)
tau <- pow(sigma, -2)

#fit a linear model
#should be a way to store predictors as a list with an intercept.
#then just multiply the m vector by the predictor list for the linear component of the model.
for(i in 1:N){
y.hat[i] <- m[1]*1 + m[2]*x[i]
y[i] ~ dnorm(y.hat[i], tau)
}
} #close model loop.
"

#Setup data object.
temp.data <- list(      y = temp$observed,
                        x = temp$predicted,
                        N = length(temp$observed),
                        N.preds = 2)

#pick starting values based on lm fits to help chain mixing and speed convergence.
start.temp <- list()
temp.freq <- lm(observed ~ predicted, data = temp)
start.temp[[1]] <- list(sigma = 1, m = c(coef(temp.freq)))
start.temp[[2]] <- lapply(start.temp[[1]],'*',1.01)
start.temp[[3]] <- lapply(start.temp[[1]],'*',0.99)

#fit temperature model. This number of samples gives clean looking distributions.
temp.out <- run.jags(temp.model,
                     data = temp.data,
                     adapt = 200,
                     burnin = 1000,
                     sample = 3000,
                     n.chains = 3,
                     monitor = c('m','sigma'),
                     inits = start.temp
)
#summarize and plot output.
temp.summary <- data.frame(summary(temp.out))
plot(temp.out)

#save output.
saveRDS(temp.summary,out.path)


# (12) #########

print("Work on a matrix")
##
ct <- makeCluster(cores)
registerDoParallel(ct)
##
if(!exists("mymean")){mymean=0}
nt<-8
mymat<-matrix(nrow=nt,ncol=nt)
mymat[1:nt,]<-mymean

csum<-foreach(ijk = 1:nt, .combine=cbind ) %dopar% {
	set.seed(ijk)
# note: the length for rnorm is ignored but needed or you get an error
	junk<-rnorm(nt,mean=mymat[,ijk])
}
print(csum)
bonk=vector(mode="double",length=nt)
for (i in 1:nt){bonk[i]=sum(csum[,i])}
print(bonk)
print(sum(mymat))

print("BIG QUESTION:  WHY IS THIS DIFFERENT FROM OPENMP?")

stopCluster(ct)
#readline(prompt = "NEXT>")

##########


#usage of my.plotcorr
#much like the my.plotcorr function, this is modified from the plotcorr documentation
#this function requires the ellipse library, though, once installed you don't need to load it - it is loaded in the function
install.packages(c('ellipse'))
install.packages(c('latex2exp'))
library(ellipse)
library(latex2exp)
source('my.plotcorr.r')

corr.mtcars = matrix(nrow=5,ncol=5)

# alpha l
corr.mtcars[1,1] <- -0.55
corr.mtcars[1,2] <- 0.14

corr.mtcars[2,1] <- 0.28
corr.mtcars[2,2] <- -0.36
corr.mtcars[2,3] <- 0.29

corr.mtcars[3,2] <- 0.26
corr.mtcars[3,3] <- -0.49
corr.mtcars[3,4] <- -0.02

corr.mtcars[4,3] <- 0.36
corr.mtcars[4,4] <- -0.16
corr.mtcars[4,5] <- -0.05

corr.mtcars[5,4] <- 0.47
corr.mtcars[5,5] <- 0.06

# Here we play around with the colors, colors are selected from a list with colors recycled
# Thus to map correlations to colors we need to make a list of suitable colors
# To start, pick the end (and mid) points of a scale, here a red to white to blue for neg to none to pos correlation
colsc=c(rgb(0, 61, 104, maxColorValue=255), 'white', rgb(241, 54, 23, maxColorValue=255))

# Build a ramp function to interpolate along the scale, I've opted for the Lab interpolation rather than the default rgb, check the documentation about the differences
colramp = colorRampPalette(colsc, space='Lab')

# I'll show two types of color styles using this color ramp
# the first
# Use the same number of colors along the scale for the number of variables
# colors = colramp(length(corr.mtcars[1,]))

# the second form
# we could, alternatively, make a scale with 100 points
colors = colramp(100)

print(corr.mtcars)

my.plotcorr(corr.mtcars, col=colors[((corr.mtcars + 1)/2) * 100], diag='ellipse', lower.panel='ellipse', upper.panel='ellipse',main='')


library(tradepolicy)
library(eflm)

# data ----

ch1_application1 <-  agtpa_applications %>%
  select(exporter, importer, pair_id, year, trade, dist, cntg, lang, clny) %>%
  filter(year %in% seq(1986, 2006, 4))

ch1_application1 <- ch1_application1 %>%
  mutate(
    log_trade = log(trade),
    log_dist = log(dist)
  )

ch1_application1 <- ch1_application1 %>%
  # Create Yit
  group_by(exporter, year) %>%
  mutate(
    y = sum(trade),
    log_y = log(y)
  ) %>%

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

ch1_application1 <- ch1_application1 %>%
  # Replicate total_e
  group_by(exporter, year) %>%
  mutate(total_e = sum(e)) %>%
  group_by(year) %>%
  mutate(total_e = max(total_e)) %>%

  # Replicate rem_exp
  group_by(exporter, year) %>%
  mutate(
    remoteness_exp = sum(dist *  total_e / e),
    log_remoteness_exp = log(remoteness_exp)
  ) %>%

  # Replicate total_y
  group_by(importer, year) %>%
  mutate(total_y = sum(y)) %>%
  group_by(year) %>%
  mutate(total_y = max(total_y)) %>%

  # Replicate rem_imp
  group_by(importer, year) %>%
  mutate(
    remoteness_imp = sum(dist / (y / total_y)),
    log_remoteness_imp = log(remoteness_imp)
  )

ch1_application1 <- ch1_application1 %>%
  # This merges the columns exporter/importer with year
  mutate(
    exp_year = paste0(exporter, year),
    imp_year = paste0(importer, year)
  )

ch1_application1 <- ch1_application1 %>%
  filter(exporter != importer)

# ols ----

form <- log_trade ~ log_dist + cntg + lang + clny + log_y + log_e

d <- ch1_application1 %>% filter(trade > 0)
fit_ols_lm <- lm(
  form,
  data = d,
  y = FALSE,
  model = FALSE
)

fit_ols_elm <- elm(
  form,
  data = d,
  y = FALSE,
  model = FALSE,
  reduce = TRUE
)

rm(d)

# ols remoteness ----

form <- log_trade ~ log_dist + cntg + lang + clny + log_y + log_e +
  log_remoteness_exp + log_remoteness_imp

d <- ch1_application1 %>% filter(trade > 0)

fit_ols_remoteness_lm <- lm(
  form,
  data = d,
  y = FALSE,
  model = FALSE
)

fit_ols_remoteness_elm <- elm(
  form,
  data = d,
  y = FALSE,
  model = FALSE,
  reduce = TRUE
)

rm(d)

# fe ----

form <- log_trade ~ log_dist + cntg + lang + clny + exp_year + imp_year

d <- ch1_application1 %>% filter(trade > 0)

fit_fe_lm <- lm(
  form,
  data = d,
  y = FALSE,
  model = FALSE
)

fit_fe_elm <- elm(
  form,
  data = d,
  y = FALSE,
  model = FALSE,
  reduce = TRUE
)

rm(d)

# ppml ----

form <- trade ~ log_dist + cntg + lang + clny + exp_year + imp_year

d <- ch1_application1

fit_ppml_glm <- glm(
  form,
  family = stats::quasipoisson(link = "log"),
  data = d,
  y = FALSE,
  model = FALSE
)

fit_ppml_eglm <- eglm(
  form,
  family = stats::quasipoisson(link = "log"),
  data = d,
  y = FALSE,
  model = FALSE,
  reduce = TRUE
)

rm(d, form, ch1_application1)

save.image("benchmarks/01-chapter1-traditional-gravity.RData", compress = "xz")

rm(list = ls())
gc()


# Latent class models with one (loglinear independence) to three classes
data(election)
f <- cbind(MORALG,CARESG,KNOWG,LEADG,DISHONG,INTELG,
           MORALB,CARESB,KNOWB,LEADB,DISHONB,INTELB)~1
nes1 <- poLCA(f,election,nclass=1) # log-likelihood: -18647.31
nes2 <- poLCA(f,election,nclass=2) # log-likelihood: -17344.92
nes3 <- poLCA(f,election,nclass=3) # log-likelihood: -16714.66
# Three-class model with a single covariate (party)
f2a <- cbind(MORALG,CARESG,KNOWG,LEADG,DISHONG,INTELG,
             MORALB,CARESB,KNOWB,LEADB,DISHONB,INTELB)~PARTY
nes2a <- poLCA(f2a,election,nclass=3,nrep=5) # log-likelihood: -16222.32
pidmat <- cbind(1,c(1:7))
exb <- exp(pidmat %*% nes2a$coeff)
matplot(c(1:7),(cbind(1,exb)/(1+rowSums(exb))),ylim=c(0,1),type="l",
        main="Party ID as a predictor of candidate affinity class",
        xlab="Party ID: strong Democratic (1) to strong Republican (7)",
        ylab="Probability of latent class membership",lwd=2,col=1)
text(5.9,0.35,"Other")
text(5.4,0.7,"Bush affinity")
text(1.8,0.6,"Gore affinity")


nv.ssize <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/analysis/verification/nv.ssize-pop-sampled-richness.csv")
View(nv.ssize)
nv.ssize$zresid <- (nv.ssize$ssize_25 - nv.ssize$expected_25) / nv.ssize$sd_25
nv.ssize$zresid50 <- (nv.ssize$ssize_50 - nv.ssize$expected_50) / nv.ssize$sd_50
ggplot(nv.ssize, aes(x = zresid50, y = ..density..)) + geom_density()
ggplot(nv.ssize, aes(x = zresid, y = ..density..)) + geom_density()
nv.ssize.single <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/analysis/verification/nv.ssize-pop-sampled-richness-singlelocus.csv")
View(nv.ssize.single)
nv.ssize.single$zresid <- (nv.ssize.single$ssize_25 - nv.ssize.single$expected_25) / nv.ssize.single$sd_25
nv.ssize.single$zresid50 <- (nv.ssize.single$ssize_50 - nv.ssize.single$expected_50) / nv.ssize.single$sd_50
ggplot(nv.ssize.single, aes(x = zresid, y = ..density..)) + geom_density()
ggplot(nv.ssize.single, aes(x = zresid50, y = ..density..)) + geom_density()


rasterdf <- function(x, aggregate = 1) {
    resampleFactor <- aggregate
    inputRaster <- x
    inCols <- ncol(inputRaster)
    inRows <- nrow(inputRaster)
    # Compute numbers of columns and rows in the new raster for mapping
    resampledRaster <- rast(ncol=(inCols / resampleFactor),
                            nrow=(inRows / resampleFactor))
    # Match to the extent of the original raster
    ext(resampledRaster) <- ext(inputRaster)
    # Resample data on the new raster
    y <- resample(inputRaster, resampledRaster, method = 'near')

    # Extract cell coordinates
    coords <- xyFromCell(y, seq_len(ncell(y)))
    dat <- stack(as.data.frame(values(y)))
    # Add names - 'value' for data, 'variable' to indicate different raster layers
    # in a stack
    names(dat) <- c('value', 'variable')
    dat <- cbind(coords, dat)
    dat
    }


#' Most variable CpG sites
#'
#' Returns the most variable CpG sites (rows) in the methylation matrix.
#'
#' @param beta Methylation matrix (rows = CpG sites, columns = samples).
#' @param n Number of CpG sites to return.
#' @return The \code{n} CpG site identifiers (rownames of \code{x}) with the greatest variance in \code{x}.
#'
#' @export
meffil.most.variable.cpgs <- function(beta, n=1000) {
    stopifnot(!is.null(rownames(beta)))
    var <- matrixStats::rowVars(beta, na.rm=T)
    rownames(beta)[order(var, decreasing=TRUE)[1:n]]
}


library(data.table)
library(ggplot2)
library(cowplot)
library(fixest)
library(lubridate)
library(dummies)

rm(list=ls())
gc()

source("myscript.r")

# the 'not in' function
'%!in%' <- Negate('%in%')

# the 'normalizing' function
mean_adj <- function(x){
  x <- x/mean(x)
  return(x)
}

# load the price and conflict data
load("dataset.RData")

# crop
crop <- "Rice"
crop_dt <- combined_dt[Crop==crop]

# transition variable
tvr <- "s1bar"
crop_dt$tv <- crop_dt[,..tvr]

# control variables (interacted with lagged price differential)
crop_dt[,w1 := x*Within_Reg]
crop_dt[,w2 := x*Distance_km/100]
crop_dt[,w3 := x*Travel_hr]

## set of regressions

### baseline (reg+dist+month)
pstr_coef <- my_pstr(crop_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad+Month, crop_dt)
r.rdm <- summary(crop.fe)

### reg+time+month
pstr_coef <- my_pstr(crop_dt,w=c("w1","w3","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w3 | Dyad + Month, crop_dt)
r.rtm <- summary(crop.fe)

### reg+month
pstr_coef <- my_pstr(crop_dt,w=c("w1","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1 | Dyad + Month, crop_dt)
r.regm <- summary(crop.fe)

### dist+month
pstr_coef <- my_pstr(crop_dt,w=c("w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w2 | Dyad + Month, crop_dt)
r.distm <- summary(crop.fe)

### time+month
pstr_coef <- my_pstr(crop_dt,w=c("w3","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w3 | Dyad + Month, crop_dt)
r.timem <- summary(crop.fe)

### reg
pstr_coef <- my_pstr(crop_dt,w=c("w1"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1 | Dyad, crop_dt)
r.reg <- summary(crop.fe)

### dist
pstr_coef <- my_pstr(crop_dt,w=c("w2"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w2 | Dyad, crop_dt)
r.dist <- summary(crop.fe)

### time
pstr_coef <- my_pstr(crop_dt,w=c("w3"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
crop_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(crop_dt$tv-pstr_coef["c1"])/sd(crop_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w3 | Dyad, crop_dt)
r.time <- summary(crop.fe)

## unique list of markets
market <- unique(c(crop_dt$Market1,crop_dt$Market2))
market <- market[order(market)]

### omit 1
omit_dt <- crop_dt[(Market1!=market[1] & Market2!=market[1])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit1 <- summary(crop.fe)

### omit 2
omit_dt <- crop_dt[(Market1!=market[2] & Market2!=market[2])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit2 <- summary(crop.fe)

### omit 3
omit_dt <- crop_dt[(Market1!=market[3] & Market2!=market[3])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit3 <- summary(crop.fe)

### omit 4
omit_dt <- crop_dt[(Market1!=market[4] & Market2!=market[4])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit4 <- summary(crop.fe)

### omit 5
omit_dt <- crop_dt[(Market1!=market[5] & Market2!=market[5])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit5 <- summary(crop.fe)

### omit 6
omit_dt <- crop_dt[(Market1!=market[6] & Market2!=market[6])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit6 <- summary(crop.fe)

### omit 7
omit_dt <- crop_dt[(Market1!=market[7] & Market2!=market[7])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit7 <- summary(crop.fe)

### omit 8
omit_dt <- crop_dt[(Market1!=market[8] & Market2!=market[8])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit8 <- summary(crop.fe)

### omit 9
omit_dt <- crop_dt[(Market1!=market[9] & Market2!=market[9])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit9 <- summary(crop.fe)

### omit 10
omit_dt <- crop_dt[(Market1!=market[10] & Market2!=market[10])]

pstr_coef <- my_pstr(omit_dt,w=c("w1","w2","Month_01","Month_02","Month_03","Month_04","Month_05","Month_06","Month_07","Month_08","Month_09","Month_10","Month_11"),tv=tvr,g_start=.5,c_start=.5,tf=1,max_it=100)
omit_dt$G_tv <- ((1+exp(-pstr_coef["g1"]*(omit_dt$tv-pstr_coef["c1"])/sd(omit_dt$tv)))^(-1))
crop.fe <- feols(y~x:I(1-G_tv)+x:G_tv+w1+w2 | Dyad + Month, omit_dt)
r.omit10 <- summary(crop.fe)

coef_names <- names(r.rdm$coefficients)[3:4]

panel_list <- list(r.rdm,r.rtm,r.regm,r.distm,r.timem,r.reg,r.dist,r.time,r.omit1,r.omit2,r.omit3,r.omit4,r.omit5,r.omit6,r.omit7,r.omit8,r.omit9,r.omit10)

coef_vec <- c(1:length(coef_names))

coef_list <- list()
se_list <- list()

for(s in 1:length(coef_vec)){

  coef_num <- coef_vec[s]

  coef_mat <- matrix(nrow=length(panel_list),ncol=1)
  se_mat <- matrix(nrow=length(panel_list),ncol=1)
  for(i in 1:length(panel_list)){
    coef_mat[i,1] <- panel_list[[i]]$coeftable[coef_names,][coef_num,1]
    se_mat[i,1] <- panel_list[[i]]$coeftable[coef_names,][coef_num,2]
  }

  colnames(coef_mat) <- paste(c("coef"),s,sep="")
  colnames(se_mat) <- paste(c("se"),s,sep="")
  coef_mat <- as.data.table(coef_mat)
  se_mat <- as.data.table(se_mat)

  coef_list[[s]] <- coef_mat
  se_list[[s]] <- se_mat
}

coef_mat <- Reduce(cbind,coef_list)
se_mat <- Reduce(cbind,se_list)

coef_mat$pos <- rownames(coef_mat)
se_mat$pos <- rownames(se_mat)

colnames(coef_mat) <- c("Low Conflict Intensity","High Conflict Intensity","pos")
colnames(se_mat) <- c("Low Conflict Intensity","High Conflict Intensity","pos")

coef_long <- melt(coef_mat,id.vars="pos")
coef_long$pos <- factor(coef_long$pos,levels=unique(coef_long$pos))
colnames(coef_long) <- c("pos","var","coef")

se_long <- melt(se_mat,id.vars="pos")
se_long$pos <- factor(se_long$pos,levels=unique(se_long$pos))
colnames(se_long) <- c("pos","var","se")

se_long$pos <- NULL
se_long$var <- NULL

dt_long <- cbind(coef_long,se_long)

## control identifiers
controls <- c("Dyad","Month","Same region","Distance (km)","Travel time (hr)",paste(market[1],sep=""),paste(market[2],sep=""),paste(market[3],sep=""),paste(market[4],sep=""),paste(market[5],sep=""),paste(market[6],sep=""),paste(market[7],sep=""),paste(market[8],sep=""),paste(market[9],sep=""),paste(market[10],sep=""))
control_mat <- matrix(nrow=length(panel_list),ncol=length(controls))
control_mat[1,c(1,2,3,4)] <- 1
control_mat[2,c(1,2,3,5)] <- 1
control_mat[3,c(1,2,3)] <- 1
control_mat[4,c(1,2,4)] <- 1
control_mat[5,c(1,2,5)] <- 1
control_mat[6,c(1,3)] <- 1
control_mat[7,c(1,4)] <- 1
control_mat[8,c(1,5)] <- 1
control_mat[9,c(1,2,3,4,6)] <- 1
control_mat[10,c(1,2,3,4,7)] <- 1
control_mat[11,c(1,2,3,4,8)] <- 1
control_mat[12,c(1,2,3,4,9)] <- 1
control_mat[13,c(1,2,3,4,10)] <- 1
control_mat[14,c(1,2,3,4,11)] <- 1
control_mat[15,c(1,2,3,4,12)] <- 1
control_mat[16,c(1,2,3,4,13)] <- 1
control_mat[17,c(1,2,3,4,14)] <- 1
control_mat[18,c(1,2,3,4,15)] <- 1

colnames(control_mat) <- controls
control_mat <- as.data.table(control_mat)

control_mat$pos <- rownames(control_mat)
control_mat$pos <- factor(control_mat$pos,levels=unique(control_mat$pos))

cfixed <- c(controls[1:5],"pos")
cmarkt <- c(controls[6:length(controls)],"pos")

control_fixed <- control_mat[,..cfixed]
control_markt <- control_mat[,..cmarkt]

fixed_long <- melt(control_fixed,id.vars="pos")
fixed_long$pos <- factor(fixed_long$pos,levels=unique(fixed_long$pos))
colnames(fixed_long) <- c("pos","var","fe")

markt_long <- melt(control_markt,id.vars="pos")
markt_long$pos <- factor(markt_long$pos,levels=unique(markt_long$pos))
colnames(markt_long) <- c("pos","var","fe")

# plots
gg1 <- ggplot(dt_long,aes(x=pos,color=var,shape=var)) +
  geom_hline(yintercept=0,size=1,linetype=3,color="gray50",alpha=.8)+
  geom_errorbar(aes(ymin=coef-1.96*se,ymax=coef+1.96*se,group=var),position=position_dodge(.5),size=1,width=NA,alpha=.5) +
  geom_point(aes(y=coef),position=position_dodge(.5),size=3)+
  labs(x="Specification",y="")+
  scale_color_manual(values=c("steelblue","indianred"))+
  scale_shape_manual(values=c(16,18))+
  theme_classic()+
  theme(legend.position="top", legend.title = element_blank(), axis.line.x=element_blank(), axis.text.y = element_text(size=8),axis.ticks.x=element_blank())

gc1 <- ggplot(fixed_long,aes(x=pos,y=var)) +
  geom_tile(na.rm=T,color=NA,fill=NA) +
  ylim(rev(levels(fixed_long$var))) +
  geom_point(aes(size=fe),na.rm=T,shape=15,color="gray50") +
  labs(title="Fixed effects and interaction terms",x="",y="") +
  theme_classic() +
  theme(legend.position="none",title=element_text(size=8),axis.line=element_blank(), axis.text.y.left = element_text(hjust=0,size=8), axis.ticks=element_blank(),axis.text.x=element_blank())

gc2 <- ggplot(markt_long,aes(x=pos,y=var)) +
  geom_tile(na.rm=T,color=NA,fill=NA) +
  ylim(rev(levels(markt_long$var))) +
  geom_point(aes(size=fe),na.rm=T,shape=15,color="gray50") +
  labs(title="Excluded market",x="",y="") +
  theme_classic() +
  theme(legend.position="none",title=element_text(size=8),axis.line=element_blank(), axis.text.y.left = element_text(hjust=0,size=8), axis.ticks=element_blank(),axis.text.x=element_blank())

gg_comb <- plot_grid(gg1,gc1,gc2,align="v",ncol=1,rel_heights=c(12,6,10))

## Figure
ggsave("sensitivity.png",ggcomb,width=6.5,height=6.5)


library(ggplot2)

data <- read.csv(file="../data/hanziDB.csv",sep=",",head=TRUE, nrows=1000)

data$stroke_count <- as.numeric(as.character(data$stroke_count))
plot <- ggplot(data) + geom_point(aes(x=frequency_rank, y=stroke_count), color='blue', alpha=0.3) + geom_point(aes(x = frequency_rank, y = hsk_level), color = 'red', alpha=0.2)

print(plot)


#==============================================================================
#	Test for glmmML
#==============================================================================

source("tests.r")

iris2 <- make.test.data.frame()

test.data <- list(
	call = list(
		substitute(
			glmmML(n ~ Petal.Length, family = poisson, data = iris2, cluster = Species)
		),
		substitute(
			glmmML(bin ~ Petal.Length, family = binomial, data = iris2, cluster = Species)
		)
	),
	formula = list(
		n ~ Petal.Length,
		bin ~ Petal.Length
	),
	model.type = list("regression", "classification"),
	family = c("poisson", "binomial"),
	link = list(poisson()$linkfun, binomial()$linkfun),
	linkinv = list(poisson()$linkinv, binomial()$linkinv)
)

test.model.adapter("glmmML", iris2, test.data)

rm(test.data, iris2)


## ----echo = FALSE----------------------------------------------------------------------
knitr::opts_chunk$set(
  message = FALSE,
  warning = FALSE,
  collapse = TRUE,
  comment = "",
  fig.height = 4,
  fig.width = 8,
  fig.align = "center",
  cache = FALSE
)

## ----load packages, echo=FALSE---------------------------------------------------------
library(tidyverse)
library(lubridate)
library(broom)

## ----example 6 what are the factors measurements and experimental units, echo = FALSE----
load(here::here("data/french_fries.rda"))

## ----your turn to work on the french fries data, echo=FALSE----------------------------
head(french_fries)

## ----put french fries in long form-----------------------------------------------------
ff_long <- french_fries %>%
  pivot_longer(potato:painty, names_to = "type", values_to = "rating")
head(ff_long)

## ----spread it back into wide form-----------------------------------------------------
head(ff_long, 3)

french_fries_weeks <- ff_long %>%
  pivot_wider(names_from = "time", values_from = "rating")

head(french_fries_weeks)

## ----spread----------------------------------------------------------------------------
head(french_fries_weeks)

## ----week 1 vs week 9, fig.width=5, fig.height = 5-------------------------------------
french_fries_weeks %>%
  ggplot(aes(x = `1`, y = `9`)) + geom_point()

## ----solution to do the replicates look like each other, echo=FALSE, eval=FALSE--------
## ff.s <- ff_long %>% pivot_wider(names_from=rep, values_from=rating)
## ggplot(data=ff.s, aes(x=`1`, y=`2`)) + geom_point() +
##   theme(aspect.ratio=1)
## ggplot(data=ff.s, aes(x=`1`, y=`2`)) + geom_point() +
##   theme(aspect.ratio=1) +
##   xlab("Rep 1") + ylab("Rep 2") + facet_wrap(~type, ncol=5)

## ----ratings on the different scales---------------------------------------------------
ff.m <- french_fries %>%
pivot_longer(-(time:rep), names_to="type", values_to="rating")
head(ff.m)

## ----ratings on the different scales too-----------------------------------------------
ff.m <- french_fries %>%
pivot_longer(-(time:rep), names_to="type", values_to="rating")
head(ff.m)

## ---- fig.height=2, fig.width=8--------------------------------------------------------
ggplot(data=ff.m, aes(x=rating)) + geom_histogram(binwidth=2) +
facet_wrap(~type, ncol=5)

## ----side-by-Side boxplots, fig.width=8, fig.height=5----------------------------------
ggplot(data=ff.m, aes(x=type, y=rating, fill=type)) +
geom_boxplot()

## ----solution to whether scales look like each other, echo=FALSE, eval=FALSE-----------
## ff.scales <- ff_long %>% pivot_wider(names_from=type, values_from=rating)
##
## cor(ff.scales[,5:9], use="pairwise.complete")
##
## ggplot(data=ff.scales, aes(x=potato, y=buttery)) + geom_point() +
##   theme(aspect.ratio=1)

## ----ratings by week, fig.width=8, fig.height=5----------------------------------------
ff.m$time <- as.numeric(ff.m$time)
ggplot(data=ff.m, aes(x=time, y=rating, colour=type)) +
geom_point(size=.75) +
geom_smooth() +
facet_wrap(~type)

## ----ratings by week again, echo=FALSE, fig.width=8, fig.height=5----------------------
ff.m$time <- as.numeric(ff.m$time)
ggplot(data=ff.m, aes(x=time, y=rating, colour=type)) +
geom_point(size=.75) +
geom_smooth() +
facet_wrap(~type)

## ----solution to model, echo=FALSE, eval=FALSE-----------------------------------------
## # long model is fine to use for a single model:
##
## model <- lm(rating ~ type*time-1, data = ff_long)
##
## ggplot(data=ff.m, aes(x=time, y=rating, colour=type)) +
## geom_smooth(method="lm", se=FALSE, aes(colour = type))


## Author: Yunchuan Kong
## Copyright Reserved 2018

manyZeros<-function(x){
    zeroRate=0.1
    if (length(which(x==min(x)))/length(x)>zeroRate)
    # if (length(which(x==0))/length(x)>zeroRate)
        return(1)
    else
        return(0)
}

deleteZeros <- function(array){
  z=apply(array,1,manyZeros)
  zeroRows=which(z==1)
  if (length(zeroRows)!=0){
    dat=array[-zeroRows,]
  } else {
    dat=array
  }
  return(dat)
}

normalizeData <- function(dat){
  library(coin)
  rowTrans = function(x)normal_trafo(rank(x, ties.method="random"))
  return(t(apply(dat,1,rowTrans)))
}

penalizeCorr <- function(corr, thres=1){
  v=corr[lower.tri(corr,diag=F)]
  mu_v=mean(v)
  sd_v=sd(v)
  dict=ifelse((corr>mu_v-1*sd_v & corr<mu_v+1*sd_v) , 1, 0)
#   cat("Correlation thresholds:",c(mu_v-thres*sd_v,mu_v+thres*sd_v),"\n")
  return(dict)
}

one_gene_LA<-function(array, x){ # x is a row of the array, i.e. nog*nos
    b<-x*t(array)
    d<-array%*%b
    d
    # diaganol elements and elements of x.(index) in array are of no use
    # the matrix is symmetric
    # the result should be divided by nos to get LAs
}

extractVector<-function(mat){ # extracting the upper triangular into a vector
    return( as.vector(mat[upper.tri(mat, diag=F)]) )
}

pfdrBounds<-function(i,dat,nos,one_vec,naRec, fdr=0.1){
    library(ks)
	  threshold_pfdr = fdr
    n_sample_pairs = 1000
    n_perm = 1
    pairID = sample(which(naRec==FALSE),n_sample_pairs)
    ## Below is not fast. Use the for loop
    # perm = replicate(n_perm,one_gene_LA(dat,sample(dat[i,]))/nos)
    # perm_vec = matrix(unlist(alply(perm,3,extractVector)),ncol=n_perm)
    # perm_vec = perm_vec[pairID,]
    perm_vec=NULL
    for (j in 1:n_perm){ # use this loop when n_perm>1
        perm=one_gene_LA(dat,sample(dat[i,]))/nos
        perm_vec=extractVector(perm)[pairID]
        perm_vec=c(perm_vec,perm_vec)
    }
    est_true = kde(one_vec[pairID]
                   ,eval.points = sort(one_vec[pairID])
                   )
    dens_true = est_true$estimate
    ep = est_true$eval.points
    est_perm = kde(perm_vec
                   ,eval.points = ep
                   )
    dens_perm = est_perm$estimate

    ratio = dens_perm/dens_true
    idx_low=which(ratio[1:(n_sample_pairs/2)]<threshold_pfdr)
    idx_upp=which(ratio[-(1:(n_sample_pairs/2))]<threshold_pfdr)
    if (length(idx_low)==0){
        lb = NA
    } else
        lb = ep[max(idx_low)]
    if (length(idx_upp)==0){
        ub = NA
    } else
        ub = ep[min(idx_upp+n_sample_pairs/2)]
    perm=NULL;perm_vec=NULL;est_perm=NULL;dens_perm=NULL
    est_true=NULL;dens_true=NULL;ratio=NULL
    return(c(lb,ub))
}

make3<-function(x,i,nog){
# LA will not be recorded in triplet list any more for saving space (can be modified)
    tri=NULL
    not=length(x[!(is.na(x))]) # Number Of Triplets
    x[!(is.na(x))]=1
	  x[is.na(x)]=0
    tuples=rep(0,2*not)
    tuples=.C('make3',tuples=as.integer(tuples)
                     ,x=as.integer(x)
                     ,theOne=as.integer(i)
                     ,nog=as.integer(nog)
					 ,not=as.integer(not))$tuples
    tuples=matrix(tuples,ncol=2,nrow=not,byrow=T)
    tuples=tuples[apply(tuples,1,sum)!=0,]
    if (i %% 100==0)
        cat("Number of triplets:",not,'.    ')
    if ( length(tuples)!=2 ){
        not=nrow(tuples)
        tri=cbind(rep(i,not),tuples)
    }
    else {
        # cat("Hey! I found you!\n")
        tri=c(i,tuples)
    }
    # free the memory
    tuples=NULL
    return(tri)
}

makeTriplets <- function(nog, nos, dat, dict, fdr){
  triplets <- NULL
  for (i in 1:nog ){
  # for (i in 1:15){
    dicti=dict[i,]*t(dict[i,]*dict)
    one=one_gene_LA(dat,dat[i,])/nos
    one[dicti==0]=NA
    one_vec = extractVector(one)
    naRec = is.na(one_vec)
    bounds = pfdrBounds(i,dat,nos,one_vec,naRec, fdr=0.1)

    if (is.na(bounds[1]) & !is.na(bounds[2])){
      one_vec[ one_vec<bounds[2] ] = NA
    }
    else if (!is.na(bounds[1]) & is.na(bounds[2])){
      one_vec[ one_vec>bounds[1] ] = NA
    }
    else if (!is.na(bounds[1]) & !is.na(bounds[2])) {
      one_vec[ one_vec>bounds[1] & one_vec<bounds[2] ]=NA
    }
    else {
      # cat("Gene:", i, "No effective triplets - passed.\n")
      next
    }

    triplets=rbind(triplets,make3(one_vec,i,nog))
    if (i %% 100==0)
      cat("*** Gene ",i," calculated. ***\n")
    # free the memory
    one=NULL;one_vec=NULL;naRec=NULL;
    # subOne=NULL;x=NULL
  } # for
  cat("\n**** Finished calculating assigned genes. ****\n")
  return(triplets)
}

count<-function(triplet,N){
	n=nrow(triplet)
	flow=rep(0,N*N)
	.C("count",tri=as.integer(as.vector(t(triplet))),
		n=as.integer(n),
		flow=as.integer(flow),
		N=as.integer(N))$flow
}

createFlow<-function(triplets, nog, save=F, corMat=F){
    k=nog
    flow_vec=count(triplets,k)
    flow=matrix(flow_vec,k,k)
    if (save==TRUE)
      save(flow,file="flow.bin")
    return(flow)
}

createLabels_unsup <- function(distMat, save=F){
# return the one-hot label matrix, with one additional column recording the sum of each row
  library(dynamicTreeCut)
  N=ncol(distMat)
  d=as.dist(distMat)
  h=hclust(d, method="average")
  label_vec=cutreeDynamic(h,distM = distMat,verbose=4,
                                    minClusterSize = 20, # let's do 20 for yeast, 100 for human
                                    deepSplit = 1,
                                    pamStage =F)
	K=length(unique(label_vec))-1
	cat("Number of clusters: ",K,"\n")
  label=matrix(0,ncol=K,nrow=N)
  for (i in 1:K){
	  label[which(label_vec==i),i]=1
  }
  label=cbind(label,apply(label,1,sum))
  colnames(label)=c(1:(ncol(label)-1),'rowSum')
  if (save==TRUE){
    save(label,file='label_unsup.bin')
  }
	return(label)
}

createLabels_sup <- function(GO.select, glist, save=F){
## input a list object GO.select
  N=length(glist)
	K=length(GO.select)
	label=matrix(0,ncol=K,nrow=N)
	for (i in 1:K){
		label[match(GO.select[[i]],glist),i]=1

		# len_act=length(which(label[,i]!=0))
		# len_tgt=length(GO.select[[i]])
		# if (len_act!=len_tgt)
			# cat("WARNING: length inconsistent. Module:",i,len_act,len_tgt,"\n")
	}
  label=cbind(label,apply(label,1,sum))
  colnames(label)=c(1:(ncol(label)-1),'rowSum')
  if (save==TRUE){
    save(label,file='label_sup.bin')
  }
  return(label)
}

shrink<-function(triplet,label){
  n=dim(triplet)[1]
	K=ncol(label) # num of clusters + 1
	adjacency=rep(0,(K-1)^3)
  .C('shrink',tri=as.integer(as.vector(t(triplet))),
              n=as.integer(n),
              adj=as.integer(adjacency),
              lab=as.integer(as.vector(t(label))),
              k=as.integer(K))$adj
}

fullyConnect<-function(labelSum){
	K=length(labelSum) # num of clusters
	adjacency=rep(0,(K)^3)
	.C("fullyConnect",adj=as.integer(adjacency),
	          			  labSum=as.integer(labelSum),
					          k=as.integer(K))$adj
}

normalize<-function(noc,net_vec,fullNet_vec){
  K=noc # num of clusters
  adjacency=rep(0,(K)^3)
  .C("normalize", net=as.double(net_vec),
                  full=as.double(fullNet_vec),
                  k=as.integer(K),
                  adj=as.double(adjacency))$adj
}

GOen<-function(glist,label){
    library(GOstats)
    all.entrez=glist
    res=list()
    k=ncol(label)-1
    for (i in 1:k){
        sel.entrez=glist[which(label[,i]==1)]
        params <- new("GOHyperGParams", geneIds=sel.entrez
                        ,universeGeneIds=all.entrez, ontology="BP"
                        ,pvalueCutoff=0.01,conditional=F
                        ,testDirection="over"
                        ,annotation="org.Sc.sgd.db") # yeast
                        # ,annotation="org.Hs.eg.db") # human/skin
        over.pres<-hyperGTest(params)
        sum = summary(over.pres)
        id = sum$Size %in% 5:500
        res[[i]] <- sum[id,]
        cat(i,"out of",k,'done.\n')
    }
    return(res)
}


#Data preprocess template

#Importing the dataset
dataset = read.csv('Data.csv')

# Split the dataset into the Training set and test set
library(caTools)
set.seed(123)
split = sample.split(dataset$Purchased, SplitRatio = 0.8)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Featured Scaling
training_set[, 2:3] = scale(training_set[, 2:3])
test_set[, 2:3] = scale(test_set[, 2:3])

Machine Learning A-Z Template Folder/Part one - Data Preprocessing/pre_data_template.r


#==============================================================================
#	Test for has.offset method in model.adapter.
#==============================================================================

library(testthat)
library(model.adapter)

#------------------------------------------------------------------------------
#	Create test data
#------------------------------------------------------------------------------
set.seed(12345)
test.data <- data.frame(
	x = rnorm(1000, 1000, 100),
	offset = runif(1000, 1, 10) %/% 1,
	random = runif(1000, 1, 100) %/% 1
)
test.data$y.norm <- rnorm(1000, test.data$x) * test.data$offset
test.data$y.pois <- rpois(1000, test.data$x) * test.data$offset
test.data$y.norm.with.random <- (
	rnorm(1000, test.data$x) * test.data$offset + rnorm(100)[test.data$random]
)
test.data$y.pois.with.random <- (
	rpois(1000, test.data$x + rnorm(100)[test.data$random]) * test.data$offset
)
test.data$random <- factor(test.data$random)
test.data$log.offset <- log(test.data$offset)
test.data[["log(offset)"]] <- log(test.data$offset)

#------------------------------------------------------------------------------
#	Test function
#------------------------------------------------------------------------------
test_get.data_with_offset <- function(
	model.call, expected.call, expected.object = expected.call
) {
	test_that(
		deparse(substitute(model.call)), {
			expect_equal(
				model.adapter$new(model.call)$data, expected.call
			)
			expect_equal(
				model.adapter$new(eval(model.call))$data, expected.object
			)
		}
	)
}

#------------------------------------------------------------------------------
#	party::cforest
#------------------------------------------------------------------------------
library(party)
test_get.data_with_offset(
	substitute(
		party::cforest(
			y.pois ~ x + offset(offset),
			data = test.data, control = party::cforest_unbiased(mtry = 1)
		)
	),
	test.data, test.data[c("x", "offset", "y.pois")]
)

#------------------------------------------------------------------------------
#	party::ctree
#------------------------------------------------------------------------------
test_get.data_with_offset(
	substitute(party::ctree(y.pois ~ x + offset(offset),data = test.data)),
	test.data, test.data[c("x", "offset", "y.pois")]
)

#------------------------------------------------------------------------------
#	gam::gam
#------------------------------------------------------------------------------
library(gam)
test_get.data_with_offset(
	substitute(
		gam::gam(
			y.pois ~ x + offset(log(test.data$offset)), data = test.data,
			family = poisson(log)
		)
	),
	test.data
)

test_get.data_with_offset(
	substitute(
		gam::gam(
			y.pois ~ x , data = test.data, family = poisson(log),
			offset = log(offset), control = gam::gam.control(maxit = 100)
		)
	),
	test.data
)

#------------------------------------------------------------------------------
#	mgcv::gam
#------------------------------------------------------------------------------
library(mgcv)
test_get.data_with_offset(
	substitute(
		mgcv::gam(
			y.pois ~ x + offset(log(offset)), data = test.data,
			family = poisson(log)
		)
	),
	test.data
)

test_get.data_with_offset(
	substitute(
		mgcv::gam(
			y.pois ~ x, data = test.data, offset = log(offset),
			family = poisson(log)
		)
	),
	test.data
)

#------------------------------------------------------------------------------
#	mgcv::gamm
#------------------------------------------------------------------------------
test_get.data_with_offset(
	substitute(
		mgcv::gamm(
			y.pois.with.random ~ x + offset(log.offset),
			random = list(random = ~ 1), data = test.data,
			family = poisson(log)
		)
	),
	test.data, test.data[c("y.pois.with.random", "x", "log.offset")]
)

#------------------------------------------------------------------------------
#	gbm::gbm
#------------------------------------------------------------------------------
library(gbm)
test_get.data_with_offset(
	substitute(
		gbm::gbm(
			y.pois ~ x + offset(log(offset)),
			data = test.data, distribution = "poisson", n.trees = 100
		)
	),
	test.data
)

#------------------------------------------------------------------------------
#	stats::glm
#------------------------------------------------------------------------------
test_get.data_with_offset(
	substitute(
		stats::glm(
			y.pois ~ x + offset(log(offset)), data = test.data,
			family = poisson
		)
	),
	test.data
)

test_get.data_with_offset(
	substitute(
		stats::glm(
			y.pois ~ x, offset = log(offset), data = test.data,
			family = poisson
		)
	),
	test.data
)

#------------------------------------------------------------------------------
#	lme4::glmer
#------------------------------------------------------------------------------
library(lme4)
test_get.data_with_offset(
	substitute(
		lme4::glmer(
			y.pois.with.random ~ x + (1 | random) + offset(log(offset)),
			data = test.data, family = poisson
		)
	),
	test.data,
	test.data[c("y.pois.with.random", "x", "random", "log(offset)")]
)

test_get.data_with_offset(
	substitute(
		lme4::glmer(
			y.pois.with.random ~ x + (1 | random), offset = log(offset),
			data = test.data, family = poisson
		)
	),
	test.data,
	test.data[c("y.pois.with.random", "x", "random", "log(offset)")]
)

#------------------------------------------------------------------------------
#	glmmADMB::glmmadmb
#------------------------------------------------------------------------------
library(glmmADMB)
test_get.data_with_offset(
	substitute(
		glmmADMB::glmmadmb(
			y.norm ~ x + offset(offset), data = test.data, family = "gaussian"
		)
	),
	test.data, test.data[c("y.norm", "x", "offset")]
)

#------------------------------------------------------------------------------
#	stats::lm
#------------------------------------------------------------------------------
test_get.data_with_offset(
	substitute(stats::lm(y.norm ~ x + offset(offset), data = test.data)),
	test.data
)

test_get.data_with_offset(
	substitute(stats::lm(y.norm ~ x, offset = offset, data = test.data)),
	test.data
)

#------------------------------------------------------------------------------
#	nlme::lme
#------------------------------------------------------------------------------
library(nlme)
test_get.data_with_offset(
	substitute(
		nlme::lme(
			y.norm.with.random ~ x + offset(offset), data = test.data,
			random = ~ 1 | random
		)
	),
	test.data
)

#------------------------------------------------------------------------------
#	lme4::lmer
#------------------------------------------------------------------------------
test_get.data_with_offset(
	substitute(
		lme4::lmer(
			y.norm.with.random ~ x + (1 | random) + offset(offset),
			data = test.data
		)
	),
	test.data, test.data[c("y.norm.with.random", "x", "random", "offset")]
)

test_get.data_with_offset(
	substitute(
		lme4::lmer(
			y.norm.with.random ~ x + (1 | random), offset = offset,
			data = test.data
		)
	),
	test.data,
	test.data[c("y.norm.with.random", "x", "random", "offset")]
)

#------------------------------------------------------------------------------
#	MCMCglmm::MCMCglmm
#------------------------------------------------------------------------------
library(MCMCglmm)
test_get.data_with_offset(
	substitute(
		MCMCglmm::MCMCglmm(
			y.pois ~ x + offset(log(offset)), data = test.data,
			family = "poisson", verbose = FALSE
		)
	),
	test.data, NULL
)

#------------------------------------------------------------------------------
#	randomForest::randomForest
#------------------------------------------------------------------------------
library(randomForest)
test_get.data_with_offset(
	substitute(
		randomForest::randomForest(
			y.norm ~ x + offset(offset), data = test.data
		)
	),
	test.data
)

#------------------------------------------------------------------------------
#	rpart::rpart
#------------------------------------------------------------------------------
library(rpart)
test_get.data_with_offset(
	substitute(rpart::rpart(y.norm ~ x + offset(offset), data = test.data)),
	test.data
)

#------------------------------------------------------------------------------
#	e1071::svm
#------------------------------------------------------------------------------
library(e1071)
test_get.data_with_offset(
	substitute(e1071::svm(y.norm ~ x + offset(offset), data = test.data)),
	test.data
)

#------------------------------------------------------------------------------
#	tree::tree
#------------------------------------------------------------------------------
library(tree)
test_get.data_with_offset(
	substitute(tree::tree(y.norm ~ x + offset(offset), data = test.data)),
	test.data
)


genNums <- function() {
  empty <- list()
  l <- c(100:999) #the question is only interested in three digit numbers.  Lowest three digit number is 100.
  for (i in l){
    result <- i * l  #,multiply each item in list l by list l to obtain the set of possible products
    empty <-  c(empty, result)  #concatonate the multiplication results into a list
  }#end for loop
  return(empty)
}#end function

findPalindromes <- function(){
  full <- genNums()
  pals <- list()
  print("I made it through genNums")
  for (i in full){
    if (i == rev(i)){
    pals <- c(pals, i)
    }
  }#end for loop

  maximum <-  max(pals)
  print(c("The largest palindrome is " + maximu))
}#end function


#R version 3.3.2

i <- 1

# O(maxN)
while (i <= 1000000000) {
    if (i %% 2 == 0 && i %% 3 == 0 && i %% 4 == 0 && i %% 5 == 0 && i %% 6 == 0 && i %% 7 == 0 && i %% 8 == 0 &&
                            i %% 9 == 0 && i %% 10 == 0 && i %% 11 == 0 && i %% 12 == 0 &&
                            i %% 13 == 0 && i %% 14 == 0 && i %% 15 == 0 && i %% 16 == 0 &&
                            i %% 17 == 0 && i %% 18 == 0 && i %% 19 == 0 && i %% 20 == 0) {
        print(i)
        break
    }
    i <- i + 1
}

i <- 2*3*5*7*11*13*17*19

# O(n / (f(k))
while (i <= 1000000000) {
    if (i %% 4 == 0 && i %% 6 == 0 && i %% 8 == 0 &&
                            i %% 9 == 0 && i %% 10 == 0 && i %% 12 == 0 &&
                            i %% 14 == 0 && i %% 15 == 0 && i %% 16 == 0 &&
                            i %% 18 == 0 && i %% 20 == 0) {
        print(i)
        break
    }
    i <- 2*3*5*7*11*13*17*19
}


#@author: Hoofar Pourzand
#This file is copyright protected - do not redistribute
#For R style exercise https://google.github.io/styleguide/Rguide.xml

library(arules)
trans = read.transactions(
  file=
    url(
      "https://raw.githubusercontent.com/romeokienzler/developerWorks/master/market_baskets.csv"),
        sep = ",")
inspect(trans)
trans.matrix <- as(trans,"matrix") * 1
articles <- colnames(trans.matrix)
buy.frequency <- 30
minimum.support <- buy.frequency/length(trans)
minimum.support
confidence <- 0.33
itemFrequencyPlot(trans, support = minimum.support)
itemFrequencyPlot(trans, topN = 10)

rules <- apriori(trans.matrix, parameter = list(supp = minimum.support, conf = confidence, target = "rules"))
rules
summary(rules)
inspect(rules)
inspect(sort(rules, by = "support")[1:10])
inspect(sort(rules, by = "confidence")[1:10])
inspect(sort(rules, by = "lift")[1:10])
rules
require("arulesViz")
plot(sort(rules, by = "confidence")[1:10], method="graph", control=list(type="items"))

eclat.itemsets <- eclat(trans.matrix, parameter = list(supp = minimum.support, maxlen = 7))
inspect(eclat.itemsets)
plot(eclat.itemsets)