#Author: Leyton Taylor

##alphaN(t) = planar curve s.t. alphaN(t)=[x(t),y(t),-1]
##Notation: calcIterate(alphaN(t))=[curvatureIAlphaN(t), torsionIAlphaN(t)] where IAlpha(t) = Image of alpha(t) when stereographically projected to
##the unit sphere
##betaMap(alpha(t))=projection map of alpha to unit sphere i.e. alphaI(t)
##gammaMap(alpha(t))=osculating circle of alphaI(t)
##dataSet=matrix(alphaN(t)=(x(t),y(t),z=-1), nrow=N, ncol=3)
#dataSet= matrix(c(expression(1+.5*cos(t)),expression(1+.1*sin(t)),expression(-1)), nrow=1,ncol=3,byrow=TRUE)
#dataSet= matrix(c(expression(-.5 + sin(t)*cos(t)),expression(-1 + sin(t)),expression(-1)), nrow=1,ncol=3,byrow=TRUE)
#alphaN=dataSet[1,]
#alphaNP= c(expression(D(alphaN[1],'t')), expression(D(alphaN[2],'t')),expression(0))
#alphaNDP = c(expression(D(alphaNP[1],'t')), expression(D(alphaNP[2],'t')),expression(0))
#alphaNPrimeVec = matrix(
#+     c(),
#+     nrow=3,
#+     ncol=3
#+ )
# alphaNPrimeVec = matrix(
#   +     c(alphaN,alphaNP,alphaNDP),
#   +     nrow=3,
#   +     ncol=3
#   + )

# main <- function(dataSet){
#     tRange <- data.frame(t=seq(0,2*pi,.1))
#     nIterates=10
#     for(i in 0:nrow(dataSet)){
#         ##Output matrix of nIterate rows and 2 columns = corresponding to [curvature(Ialpha(t)),torsion(Ialpha(t))]
#         output=calcOrbit(c(dataSet[i,1],dataSet[i,2],dataSet[i,3]),nIterates,tRange)
#         print(output)
#     }
# }

##Output matrix of corresponding iterates of alphaN
# calcOrbit <- function(alphaN,nIterates,tRange){
#     tRange<-seq_along(tRange)
#     orbitMatrix = matrix(c(),nrow = nIterates, ncol=3,dimnames = list(, c("x(t)","y(t)","z=-1")))
#     outputOrbit = matrix(c(),nrow = length(tRange), ncol=3,dimnames = list(, c("x(t)","y(t)","z=-1")))
#     rbind(orbitMatrix, calcIterate(alphaN))
#     orbitPlot <- matrix(c(),nrow=nI)
#     #k=order of orbit
#     for (k in 1:nIterates){
#         ktVectorFunction=calcIterate(orbitMatrix[c(k-1)])
#         #Binds each consecutive iterate to orbitMartix
#         rbind(orbitMatrix,ktVectorFunction)
#         for(t in tRange){
#           rbind(outputOrbit,c(ktVectorFunction[1](t),ktVectorFunction[2](t),-1))
#         }
#
#     }
# }

options(digits = 15)

#parameter t and returns a parametric function that corresponds
#to the projection of Curvature and Torsion for each t
calcIterate <- function(alphaN){
  return(projectionKT(alphaN, pi/8))
}

#Returns corresponding curvature(t) and torsion(t)
#of the projected Parametric function passed to it
projectionKT <- function(alphaN,t){
  t=t
  #First deriveative of curve [k(t),T(t)]
  alphaNP <- c(D(alphaN[1],'t'), D(alphaN[2],'t'),0)
  #Second derivative of curve [k(t),T(t)]
  alphaNDP <- c(D(D(alphaN[1],'t'),'t'),D(D(alphaN[2],'t'),'t'),0)
  alphaNTP <- c(D(D(D(alphaN[1],'t'),'t'),'t'),D(D(D(alphaN[2],'t'),'t'),'t'),0)

  #vector containing ktVec,ktVecP, ktVecDP
  alphaNPrimeVec <-matrix(
    c(alphaN,alphaNP,alphaNDP,alphaNTP),
    nrow=4,
    ncol=3,
    byrow=TRUE
    )

  dimnames(alphaNPrimeVec)=list(c("alphaN","alphaNP","alphaNDP","alphaNTP"),c("X","Y","Z"))
  print("alphaN")
  print(alphaNPrimeVec["alphaN",])
  print("AlphaNp")
  print(alphaNPrimeVec["alphaNP",])
  print("alphaNDP")
  print(alphaNPrimeVec["alphaNDP",])
  print("alphaNTP")
  print(alphaNPrimeVec["alphaNTP",])
  print("done")
  return(c(ktCalculation(alphaNPrimeVec,t)))

}

ktCalculation <- function(alphaNPrimeVec, t){

  A <- curvatureI(alphaNPrimeVec,t)
  curvature <- A$curvature
  torsion <- A$torsion

  return(c(curvature,torsion))

}

arcLengthGamma <- function(gammaMatrix, Xo, Yo, kAlpha, t){
  gammaEnv <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv)
  assign("Yo",value=Yo,envir=gammaEnv)
  assign("kAlpha",value=kAlpha,envir=gammaEnv)
  t <- t
  Xo <- Xo
  Yo <- Yo
  kAlpha <- kAlpha
  xfunc <- function(u){eval(gammaMatrix[1,1], gammaEnv)}
  yfunc <- function(u){eval(gammaMatrix[1,2], gammaEnv)}
  zfunc <- function(u){eval(gammaMatrix[1,3], gammaEnv)}
  f <- function(u) c(xfunc(u),yfunc(u),zfunc(u))

  return(arclength(f, t, (t)+2*pi))

}

arcLengthBeta <- function(betaMatrix, a, alphaNPrimeVec){
  betaEnv <- new.env(hash=TRUE,size=2)
  assign("X",value<-deparse(alphaNPrimeVec[1,1]),envir=betaEnv)
  assign("Y",value<-deparse(alphaNPrimeVec[1,2]),envir=betaEnv)
  b <- deparse(betaMatrix[1])
  print("tt")
  print(alphaNPrimeVec)
  b1 <- substitute(b, list(X = deparse(alphaNPrimeVec[1,1])))
  print(eval(b1))
  t<-t
  xfunc <- function(t){substitute(betaMatrix[1], betaEnv)}
  yfunc <- function(t){substitute(betaMatrix[2], betaEnv)}
  zfunc <- function(t){substitute(betaMatrix[3], betaEnv)}
  f <- function(t) c(xfunc(t),yfunc(t),zfunc(t))

  return(arclength(f, 0, a))

}

#parameter ktVecDeriv=[alpha(t),alpha'(t),alpha''(t)]
#Returns curvature of projected image of alpha on the unit sphere
#at point t
curvatureI <- function(alphaNPrimeVec, t){
  print(alphaNPrimeVec)
  print(alphaNPrimeVec[1,1])
  print(alphaNPrimeVec[1,2])
  print(alphaNPrimeVec[2,1])
  print(alphaNPrimeVec[2,2])
  print(alphaNPrimeVec[3,1])
  print(alphaNPrimeVec[3,2])
  print(alphaNPrimeVec)
  betaEnv <- new.env(hash=TRUE,size=2)
  print("blah")
  print(deparse(alphaNPrimeVec[1,1]))
  assign("X",value<-deparse(alphaNPrimeVec[1,1]),envir=betaEnv)
  assign("Y",value<-deparse(alphaNPrimeVec[1,2]),envir=betaEnv)

  alpha <-c(eval(alphaNPrimeVec[1,1]),eval(alphaNPrimeVec[1,2],-1))
  alphaP <- c(eval(alphaNPrimeVec[2,1]),eval(alphaNPrimeVec[2,2]),0)
  alphaDP <- c(eval(alphaNPrimeVec[3,1]),eval(alphaNPrimeVec[3,2]),0)
  betaMatrix <- betaAlpha()
  print(substitute(deparse(betaMatrix[2,1]), list(X=10)))
  print("beta")

  substitute_q <- function(x, env) {
    call <- substitute(substitute(y, env), list(y = x))
    eval(call)
  }

  print(substitute_q(betaMatrix[2,1], betaEnv))
  arcLengthBet <- arcLengthBeta(betaMatrix[2,], 2*pi, alphaNPrimeVec)
  print("Arc Length Beta")
  print(arcLengthBet)
  #X value corresponding to alpha(t)
  xAlpha= alpha[1]
  #Y value corresponding to alpha(t)
  yAlpha= alpha[2]

  #X value corresponding to alpha(t)
  xpAlpha= alphaP[1]
  #Y value corresponding to alpha(t)
  ypAlpha= alphaP[2]

  normX<-norm(as.matrix(alphaDP[1]),"F")
  normY<-norm(as.matrix(alphaDP[2]),"F")
  #Curvature of planar curve alpha(t)
  kAlpha<-curvaturePlaneCurve(alphaP,alphaDP,t)
  #Tprime x direction
  Tprime = c(-alphaP[2], alphaP[1])
  magTprime <- norm(as.matrix(Tprime),"F")
  TprimeUnit <- c(Tprime / magTprime)
  xyNot = c(TprimeUnit / kAlpha)
  Xo = xyNot[1]+xAlpha
  Yo = xyNot[2]+yAlpha

  #Returns matrix containing the projected osculating circle of alpha
  #at some t

  gammaMatrix <-gammaAlphaF()
  betaAlphaTP <- betaAlpha()
  print("Gamma Matrix")
  print(gammaMatrix)

  print(kAlpha)

  print("XoYo")
  print(alphaP[1])
  print(alphaP[2])
  print(Tprime)
  print(TprimeUnit)
  print(Xo)
  print(Yo)
  print(magTprime)

  print("t")
  print(t)
  print("Arc Length")
  arcLengthA = arcLengthGamma(gammaMatrix, Xo, Yo, kAlpha, t)
  arcLength = arcLengthA$length
  print(arcLength)

  #Environment
  gammaEnv1 <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv1)
  assign("Yo",value=Yo,envir=gammaEnv1)
  assign("kAlpha",value=kAlpha,envir=gammaEnv1)
  assign("u",value=t,envir=gammaEnv1)

  gammaEnv2 <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv2)
  assign("Yo",value=Yo,envir=gammaEnv2)
  assign("kAlpha",value=kAlpha,envir=gammaEnv2)
  assign("u",value=t+.01,envir=gammaEnv2)

  gammaEnv3 <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv3)
  assign("Yo",value=Yo,envir=gammaEnv3)
  assign("kAlpha",value=kAlpha,envir=gammaEnv3)
  assign("u",value=t+.02,envir=gammaEnv3)

  #Environment
  betaEnv <- new.env(hash=TRUE,size=4)
  assign("X",value=xAlpha,envir=betaEnv)
  assign("Y",value=yAlpha,envir=betaEnv)
  assign("Xp",value=xpAlpha,envir=betaEnv)
  assign("Yp",value=ypAlpha,envir=betaEnv)

  #Projection point P on Alpha
  Pprime<- c(eval(gammaMatrix[1,1],gammaEnv1),eval(gammaMatrix[1,2],gammaEnv1),eval(gammaMatrix[1,3],gammaEnv1))
  #Arbitrary point on Gamma curve
  Aprime<- c(eval(gammaMatrix[1,1],gammaEnv2),eval(gammaMatrix[1,2],gammaEnv2),eval(gammaMatrix[1,3],gammaEnv2))
  #Arbitrary point on Gamma curve
  Bprime<- c(eval(gammaMatrix[1,1],gammaEnv3),eval(gammaMatrix[1,2],gammaEnv3),eval(gammaMatrix[1,3],gammaEnv3))

  betaPrimeN <-c(eval(betaAlphaTP[1,1],betaEnv),eval(betaAlphaTP[1,2],betaEnv),eval(betaAlphaTP[1,3],betaEnv))
  GammaPrimeA <-c(eval(gammaMatrix[2,1],gammaEnv2),eval(gammaMatrix[2,2],gammaEnv2),eval(gammaMatrix[2,3],gammaEnv2))
  GammaPrimeB <-c(eval(gammaMatrix[2,1],gammaEnv3),eval(gammaMatrix[2,2],gammaEnv1),eval(gammaMatrix[2,3],gammaEnv3))

  gammaPAlphaA <- c(GammaPrimeA * alphaP)
  gammaPAlphaB <- c(GammaPrimeB * alphaP)

  print(betaPrimeN)

  betaPrimeAlpha <- c(betaPrimeN * alphaP)

  ##P'-A'
  v1 <-c(Aprime-Pprime)
  ##P'-B'
  v2 <-c(Bprime-Pprime)

  v1Prime <-c(betaPrimeAlpha - gammaPAlphaA)
  v2Prime <- c(betaPrimeAlpha - gammaPAlphaB)

  normVec <- xprod(v1, v2)
  magNorm <- norm(as.matrix(normVec),"F")

  v1PCrossv2 <- xprod(v1Prime,v2)
  v2PCrossv1 <- xprod(v2Prime,v1)

  Nprime <- c(v1PCrossv2 + v2PCrossv1)

  pPrimeDn <- c(-Pprime * Nprime)
  #-P'*N'
  pPrimedotDn <- sum(pPrimeDn)

  nbetaPrime <- c(normVec * betaPrimeAlpha)
  #N*-P''
  ndotbetaPrime <- sum(nbetaPrime)
  #N*-P''+ -P'*N'
  const1 <- -pPrimedotDn + ndotbetaPrime
  #mag(N)*(N*-P''+ -P'*N')
  magNdotConst<- magNorm * const1
  #mag(N)*(N*-P''+ -P'*N')/mag(N)^2
  finalCons <- magNdotConst / (magNorm^2)

  #-P'*N/(magNorm)= p == signed distance from center of sphere to c
  p4 <- c(-Pprime*normVec)
  p4dotn <- sum(p4)
  p <- p4dotn / magNorm

  #sqrt(R^2-p^2)
  p7 <- p^2
  r1 = 1 - p7

  #r== 1/k(BetaAlpha(t))

  #Curvature of Image of Alpha at t
  kIAlpha= (2*pi)/arcLength
  r = 1/kIAlpha

  cI <- c(p * normVec)
  c <- c(cI/ magNorm)

  N <- c(c-Pprime)

  nNorm <- norm(as.matrix(N),"F")
  #.5/(sqrt(1-p^2))
  Rprimecons1 <- .5 / sqrt(1-p7)
  rPrime <- Rprimecons1 *(-2*p*(finalCons))

  #1-r(t)
  torsionI1 = 1-r
  torsionI2 =torsionI1/(rPrime^2)
  torsion <- -1*(1 / sqrt(torsionI2))

  print("R")
  print(r)

  uN <- c(N / nNorm)
  B<- normVec / magNorm

  Tv <- xprod(uN,B)
  uT <- Tv
  print("BTN")
  print(B)
  print(uT)
  print(uN)

  Tv<- Tv*-kIAlpha
  Ntp <- c(Nprime-Tv)

  return(list("curvature"=kIAlpha,"normVec"=normVec,"center"= c,"torsion"=torsion))
}

# curvatureI <- function(alphaNPrimeVec, t){
#   print(alphaNPrimeVec)
#   print(alphaNPrimeVec[1,1])
#   print(alphaNPrimeVec[1,2])
#   print(alphaNPrimeVec[2,1])
#   print(alphaNPrimeVec[2,2])
#   print(alphaNPrimeVec[3,1])
#   print(alphaNPrimeVec[3,2])
#   print(alphaNPrimeVec)
#   alpha <-c(eval(alphaNPrimeVec[1,1]),eval(alphaNPrimeVec[1,2],-1))
#   alphaP <- c(eval(alphaNPrimeVec[2,1]),eval(alphaNPrimeVec[2,2]),0)
#   alphaDP <- c(eval(alphaNPrimeVec[3,1]),eval(alphaNPrimeVec[3,2]),0)
#
#   #X value corresponding to alpha(t)
#   xAlpha= alpha[1]
#   #Y value corresponding to alpha(t)
#   yAlpha= alpha[2]
#
#   #X value corresponding to alpha(t)
#   xpAlpha= alphaP[1]
#   #Y value corresponding to alpha(t)
#   ypAlpha= alphaP[2]
#   normX<-norm(as.matrix(alphaDP[1]),"F")
#   normY<-norm(as.matrix(alphaDP[2]),"F")
#   #Tprime x direction
#   Tprimex=alphaDP[1]
#   #Tprime y direction
#   Tprimey=alphaDP[2]/normY
#
#   print(Tprimex)
#   print(Tprimey)
#   #Returns matrix containing the projected osculating circle of alpha
#   #at some t
#
#
#   gammaMatrix <-gammaAlphaF()
#   betaAlphaTP <- betaAlpha()
#
#   print(gammaMatrix)
#
#   #Curvature of planar curve alpha(t)
#   kAlpha<-curvaturePlaneCurve(alphaP,alphaDP,t)
#   print(kAlpha)
#   #(Xo,Yo)= center of osculating circle of alpha(t) at t
#   Xo<-xAlpha+(Tprimex/kAlpha)
#   Yo<-yAlpha+(Tprimey/kAlpha)
#   print(Xo)
#   print(Yo)
#
#   arcLengthGamma <- function(gammaMatrix){
#     Xo <- Xo
#     Yo <- Yo
#     kAlpha <- kAlpha
#     xfunc <- function(u){eval(gammaMatrix[1,1])}
#     yfunc <- function(u){eval(gammaMatrix[1,2])}
#     zfunc <- function(u){eval(gammaMatrix[1,3])}
#     f <- function(u) c(xfunc(u),yfunc(u),zfunc(u))
#
#     return(arclength(f, t, (t)+2*pi))
#
#
#   }
#   print("Arc Length")
#   arcLengthA = arcLengthGamma(gammaMatrix)
#   arcLength = arcLengthA$length
#
#   #Environment
#   gammaEnv1 <- new.env(hash=TRUE,size=4)
#   assign("Xo",value=Xo,envir=gammaEnv1)
#   assign("Yo",value=Yo,envir=gammaEnv1)
#   assign("kAlpha",value=kAlpha,envir=gammaEnv1)
#   assign("u",value=t,envir=gammaEnv1)
#
#   gammaEnv2 <- new.env(hash=TRUE,size=4)
#   assign("Xo",value=Xo,envir=gammaEnv2)
#   assign("Yo",value=Yo,envir=gammaEnv2)
#   assign("kAlpha",value=kAlpha,envir=gammaEnv2)
#   assign("u",value=t+.01,envir=gammaEnv2)
#
#   gammaEnv3 <- new.env(hash=TRUE,size=4)
#   assign("Xo",value=Xo,envir=gammaEnv3)
#   assign("Yo",value=Yo,envir=gammaEnv3)
#   assign("kAlpha",value=kAlpha,envir=gammaEnv3)
#   assign("u",value=t+.02,envir=gammaEnv3)
#
#   #Environment
#   betaEnv <- new.env(hash=TRUE,size=4)
#   assign("X",value=xAlpha,envir=betaEnv)
#   assign("Y",value=yAlpha,envir=betaEnv)
#   assign("Xp",value=xpAlpha,envir=betaEnv)
#   assign("Yp",value=ypAlpha,envir=betaEnv)
#
#
#   Pprime<- c(eval(gammaMatrix[1,1],gammaEnv1),eval(gammaMatrix[1,2],gammaEnv1),eval(gammaMatrix[1,3],gammaEnv1))
#   Aprime<- c(eval(gammaMatrix[1,1],gammaEnv2),eval(gammaMatrix[1,2],gammaEnv2),eval(gammaMatrix[1,3],gammaEnv2))
#   Bprime<- c(eval(gammaMatrix[1,1],gammaEnv3),eval(gammaMatrix[1,2],gammaEnv3),eval(gammaMatrix[1,3],gammaEnv3))
#
#
#   betaPrimeN <-c(eval(betaAlphaTP[1,1],betaEnv),eval(betaAlphaTP[1,2],betaEnv),eval(betaAlphaTP[1,3],betaEnv))
#   GammaPrimeA <-c(eval(gammaMatrix[2,1],gammaEnv2),eval(gammaMatrix[2,2],gammaEnv2),eval(gammaMatrix[2,3],gammaEnv2))
#   GammaPrimeB <-c(eval(gammaMatrix[2,1],gammaEnv3),eval(gammaMatrix[2,2],gammaEnv1),eval(gammaMatrix[2,3],gammaEnv3))
#
#
#
#   gammaPAlphaA <- c(GammaPrimeA * alphaP)
#   gammaPAlphaB <- c(GammaPrimeB * alphaP)
#
#
#
#   print(betaPrimeN)
#   betaPrimeAlpha <- c(betaPrimeN * alphaP)
#
#   ##n
#
#
#
#   ##P'-A'
#   v1 <-c(Aprime-Pprime)
#   ##P'-B'
#   v2 <-c(Bprime-Pprime)
#
#   v1Prime <-c(betaPrimeAlpha - gammaPAlphaA)
#   v2Prime <- c(betaPrimeAlpha - gammaPAlphaB)
#
#   normVec <- xprod(v1,v2)
#
#   magNorm <- norm(as.matrix(normVec),"F")
#
#   v1PCrossv2 <- xprod(v1Prime,v2)
#   v2PCrossv1 <- xprod(v2Prime,v1)
#
#   Nprime <- c(v1PCrossv2 + v2PCrossv1)
#
#   pPrimeDn <- c(-Pprime * Nprime)
#   pPrimedotDn <- sum(pPrimeDn)
#
#   nbetaPrime <- c(normVec * betaPrimeAlpha)
#   ndotbetaPrime <- sum(nbetaPrime)
#
#   const1 <- -pPrimedotDn + ndotbetaPrime
#   magNdotConst<- magNorm * const1
#   finalCons <- magNdotConst / (magNorm^2)
#
#
#   p4 <- c(-Pprime*normVec)
#   p4dotn <- sum(p4)
#   p <- p4dotn / magNorm
#
#   cI <- c(p * normVec)
#   c <- c(cI/ magNorm)
#
#   p7 <- p^2
#
#   Rprimecons1 <- .5 * sqrt(1-p7)
#   Rprimecons2 <- Rprimecons1 *(-2*p*(finalCons))
#
#   rPrime = Rprimecons1*Rprimecons2
#   #Curvature of Image of Alpha at t
#   kIAlpha= (2*pi)/arcLength
#   r = 1/kIAlpha
#   print("R")
#   print(r)
#   print(kIAlpha)
#   N <- c(-Pprime-c)
#   uN <- c(N / r)
#   B<- normVec / magNorm
#
#   Tv <- xprod(uN,B)
#   uT <- Tv
#   print("BTN")
#   print(B)
#   print(uT)
#   print(uN)
#
#
#
#
#   Tv<- Tv*-kIAlpha
#   Ntp <- c(Nprime-Tv)
#
#   torsionI1 = 1-r
#   torsionI2 =torsionI1/(rPrime^2)
#   torsion <- -1*(1 / sqrt(torsionI2))
#
#   return(list("curvature"=kIAlpha,"normVec"=normVec,"center"= c,"torsion"=torsion))
# }

funins <- function(f, expr = expression(x<-2*x), after=1) {
  body(f)<-as.call(append(as.list(body(f)), expr, after=after))
  f
}

##Beta mapping represents the stereographic projection of alpha onto the
##Unit sphere
betaAlpha <- function(){
  betaAlpha <- c(expression((4*X)/(X^2+Y^2+4)),
                 expression((4*Y)/(X^2+Y^2+4)),
                 expression((X^2+Y^2-4)/(X^2+Y^2+4)))

  betaAlphaP<- c(expression((((X^2+Y^2+4)*(Xp))-((4*X)*((2*X)*Xp+(2*Y)*Yp)))/(X^2+Y^2+4)^2),
                 expression((((X^2+Y^2+4)*(Yp))-((4*Y)*((2*X)*Xp+(2*Y)*Yp)))/(X^2+Y^2+4)^2),
                 expression(((X^2+Y^2+4)*((2*X)*Xp +(2*Y)*Yp)-((X^2+Y^2+4)*((2*X)*Xp +(2*Y)*Yp)))/(X^2+Y^2+4)^2))

  betaAlphMat = matrix(
    c(betaAlphaP,betaAlpha),
    nrow=2,
    ncol=3,
    byrow = TRUE
  )

  print("sup")
  print(betaAlphMat)
  return(betaAlphMat)

}

##Parametric function defining osculating circle of a curve alpha(t)
##at some t. ==> radius of osculatingAlpha= (1/kAlpha)
##further we know [x_0,y_0]=[x(t),y(t)]+[T'_alpha(t)/kAlpha)]
##0<=u<=2pi with will be the parameter of the osculating circle
##uRange=data.frame(u=seq(0,2*pi,.1))

#(x,y) represent values of osculating circle of some curve alphaN(t) at
#some value t. gammaAlpha(t) gives the corresponding (x,y,z)
#values of the osculating circle of the image of alphaN(t) or alphaNI(t)
#at the same value t. Note x,y are depent on alphaN(t)
#that is
# if alphaN(t) = x(t),y(t)==> x=x(t)+((T'alpha(t)_x)/k(t))+(1/k(t))cos(u))
## essentially x and y are functions of 0<=u<=2pi at each t on the curve ##alphaN

##For simplicity sake know that ##(x,y)=gamma(u,v=1)=[(1)*(x_0+rcos(u)),(1)*(y_0+rsin(u)),1-2*(1)]
##This mapping creates a surface of a cone. The projection mapping
##gammAlpha gives us the intersection of the cone and the unit sphere.
##this intersection happens at v=4/(x)^2+(y)^2+4

gammaAlphaF <- function(){

  #Vector of expressions corresponding to the gamma mapping applied to alpha
  gammaAlpha <- c(expression((4*(Xo+(1/kAlpha)*cos(u)))/((Xo+(1/kAlpha)*cos(u))^2+(Yo+(1/kAlpha)*sin(u))^2+4)),
                expression((4*(Yo+(1/kAlpha)*sin(u)))/((Xo+(1/kAlpha)*cos(u))^2+(Yo+(1/kAlpha)*sin(u))^2+4)),
                expression(1+(-8/((Xo+(1/kAlpha)*cos(u))^2+(Yo+(1/kAlpha)*sin(u))^2+4))))

  gammaAlphaP <- c(DD(gammaAlpha[1], 'u',1),DD(gammaAlpha[2], 'u',1),DD(gammaAlpha[3], 'u',1))

  #gammaMatrix of expressions by row
  gammaMatrix = matrix(
    c(gammaAlpha,gammaAlphaP),
    nrow=2,
    ncol=3,
    byrow=TRUE,
    )

  dimnames(gammaMatrix)=list(c("GammaAlpha: ","GammaAlphaDP"),c("X_gamma","Y_gamma","Z_gamma"))

  return(gammaMatrix)

}

#parameter ktVecDeriv=[alpha(t),alpha'(t),alpha''(t)]
#returns ||alpha'(t) x alpha''(t) ||/ ||(alpha'(t))^3||==K_alpha(t)
curvaturePlaneCurve <- function(alphaP,alphaDP,t){
  normCross <-xprod(alphaP,alphaDP)
  normAD <-norm(as.matrix(normCross),"F")
  normAP <-norm(as.matrix(alphaP),"F")
  kAlpha = normAD /(normAP^3)
  print(kAlpha)
  return(kAlpha)

}

# torsionI <- function(alphaNPrimeVec,t,normVec){
#
#   alpha <-c(eval(alphaNPrimeVec[1,1]),eval(alphaNPrimeVec[1,2],-1))
#   alphaP <- c(eval(alphaNPrimeVec[2,1]),eval(alphaNPrimeVec[2,2]),0)
#   alphaDP <- c(eval(alphaNPrimeVec[3,1]),eval(alphaNPrimeVec[3,2]),0)
#   betaAlphMat = betaAlpha(alphaNPrimeVec,t)
#
#   print(betaAlphaTP)
#
#   print(normVec)
#   print("norm")
#   num <-c(normVec)
#
#   dotNum <- sum(num)
#   denom <- norm(as.matrix(normVec),"F")
#   torsionI <- dotNum/(denom^2)
#   print(denom^2)
#   print(dotNum)
#
#
#   return(torsionI)
#
# }

##DD for calculation of high order derivatives
DD <- function(expr, name, order=1) {
  if(order < 1) stop("'order' must be >= 1")
  if(order == 1)
    return(D(expr, name))
  else DD(D(expr, name), name, order - 1)}

xprod <- function(...) {
  args <- list(...)

  # Check for valid arguments

  if (length(args) == 0) {
    stop("No data supplied")
  }
  len <- unique(sapply(args, FUN=length))
  if (length(len) > 1) {
    stop("All vectors must be the same length")
  }
  if (len != length(args) + 1) {
    stop("Must supply N-1 vectors of length N")
  }

  # Compute generalized cross product by taking the determinant of sub-matricies

  m <- do.call(rbind, args)
  sapply(seq(len),
         FUN=function(i) {
           det(m[,-i,drop=FALSE]) * (-1)^(i+1)
         })
}


x <- c(2,2,0,2,1,2,1.5,2.5,3.5,3,4,3,5,3,3)
y <- c(0,1,1,3,3,4,4,5,4,4,3,3,1,1,0)
plot(x,y,type = "b",lty = 1,lwd = 4,pch = 10,cex= 1.5,main = "Merry Christmas")

rn <-function(min,max){
	return (floor(runif(1,min,max)));
}

normdis <- function(amount,mean1,sd1,diff1,diff2){
	for (i in 1:amount){
		x <- rnorm(1,mean1,sd1);
		y <- rnorm(1,(x+diff1+diff2)/2,0.7*(x+diff1-diff2)/2);
		points(x,y,col=rgb(runif(1,0,1),runif(1,0,1),runif(1,0,1)));
		points(5-x,y,col = rgb(runif(1,0,1),runif(1,0,1),runif(1,0,1)));
		}
		}

normdis(300,2.25,0.25,2.5,0);
normdis(100,1.75,0.25,2.5,4);
normdis(200,1.5,0.5,2,3);
normdis(400,1,1,1,1);


huen <- function(steps,final)
{
	# RungeKutta Approximation and Heun's Method
	r     <- -5;
	a     <- 1/2;
	b     <- 1/2;
	alpha <- 1;
	beta  <- 1;

	#final <- 25;
	#steps <- 1000;
	dt    <- final/steps;

	n    <- 0;
	y    <- 1;
	#i    <- double(steps);
	#j    <- double(steps);

	while(n < steps) {
	    k1     <- dt*r*y;
	    k2     <- dt*r*(y + beta*k1);
	    y      <- y + a*k1 + b*k2;
	    #i[n+1] <- dt*(n+1);
	    #j[n+1] <- abs(y - exp(r*dt*(n + 1)));
	    n      <- n + 1;
	}

	#plot(
    #  i,
    #  j,
    #  type = 'l',
    #  xlim = c(0,25),
    #  ylim = c(0,5),
    #  # log = 'xy',
    #  ylab = 'Error',
    #  xlab = 'Time',
    #  main = 'r = -5 and dt = ')

	return(y)
}

x <- data.frame(,i,j);

file.create("/Users/kylemcgrath/Documents/SDE-REU-2015/SUNY-SDE-2015/REU15/Runge-Kutta/R/error-dat.csv");
data <- file("/Users/kylemcgrath/Documents/SDE-REU-2015/SUNY-SDE-2015/REU15/Runge-Kutta/R/error-dat.csv");
write.table(c("dt", "step", "error"), file = data, row.names=FALSE, col.names=FALSE);
write.table(x, file = data, row.names=FALSE, col.names=FALSE);


#keep track of all movements
mov<-c()

#VACCINATION STRATEGY
strategy<-c('mobility','mortality')

#INITIAL AMOUNT OF PEOPLE IN EACH SUBGROUP

#age group 0-20
I_1<- 26
S_1<- 44403 - I_1
#age group 21-40
I_2<- 179
S_2<- 40992 - I_2
#age group 41-60
I_3<- 148
S_3<- 29839 - I_3
#age group 60+
I_4<- 56
S_4<- 15029 - I_4

#Put them in vectors for easier access
S<-c(S_1, S_2, S_3, S_4)
I<-c(I_1, I_2, I_3, I_4)

#total dead
D<- 0
#total recuperated
R<- 4018

#average daily vaccination capacity (consider efficacy)
V<- 10

#SUBGROUP parameters

#death rate
k<-c(0.01,0.02,0.09,0.13)
#recuperation rate
b<-(1-k)
#mobility
a<-c(2.25,3,2.75,2)

#vaccines per group per day, set to 0 initially
lambda<-c(0,0,0,0)

#population in a vector
pop<-as.vector(c(rbind(S,I),D,R))
names(pop)<-c('S1','I1','S2','I2','S3','I3','S4','I4','D','R')

#this way we can simply add the vector of the event to our pop counter
poss<-data.frame(inf1=c(-1,1,rep(0,8)),
                 inf2=c(0,0,-1,1,rep(0,6)),
                 inf3=c(rep(0,4),-1,1,rep(0,4)),
                 inf4=c(rep(0,6),-1,1,0,0),
                 die1=c(0,-1,rep(0,6),1,0),
                 die2=c(rep(0,3),-1,rep(0,4),1,0),
                 die3=c(rep(0,5),-1,0,0,1,0),
                 die4=c(rep(0,7),-1,1,0),
                 rec1=c(0,-1,rep(0,7),1),
                 rec2=c(rep(0,3),-1,rep(0,5),1),
                 rec3=c(rep(0,5),-1,rep(0,3),1),
                 rec4=c(rep(0,7),-1,0,1),
                 vac1=c(-1,rep(0,8),1),
                 vac2=c(0,0,-1,rep(0,6),1),
                 vac3=c(rep(0,4),-1,rep(0,4),1),
                 vac4=c(rep(0,6),-1,0,0,1))

#put subgroup parameters into a data frame too, for easier handling
params<-data.frame(a, b, k, lambda)

#we will call this function every time we iterate inside the simulation
get_times<-function(pop,params){
  times<-c(rep(0,16))
  #population
  N<-sum(pop)
  #all infected
  infected<-sum(pop[c(2,4,6,8)])
  #iterate over each group
  for (i in 1:4){
    #infection
    times[i]<-rexp(n=1,rate=(0.06)*params$a[i]*pop[(2*i-1)]*infected/N)
    #death
    times[i+4]<-rexp(n=1,rate=params$k[i]*pop[(2*i)]*(1/17))
    #vaccination
    times[i+12]<-rexp(n=1,rate=params$lambda[i]*pop[2*i-1]/pop[2*i-1])
    #recuperation
    times[i+8]<-rexp(n=1,rate=params$b[i]*pop[(2*i)]*(1/14))
  }
  return(times)
}

get_lambda <- function(V, N, P){
  #distribute and normalize
  lambda<-c(0,0,0,0)
  lambda [ which(P*N==max(P*N))] <- V
  return(lambda)
}

set_lambda<-function(S, params, strategy, V){
  #id parameter of interest from strategy
  if (strategy=='mobility'){
    interest<-params$a
  }else if(strategy=='mortality'){
    interest<-params$k
  }
  #get lambda values according to priority parameter
  lambda<-get_lambda(P=interest,V=V,N=S)
  #return new lambda vector
  return(lambda)
}

#MAIN SIMULATION ITERATORS
#We will fluctuate between strategies with different probability values (limit)
#Each probability combination will be run e simulations
#each simulation will run until herd immunity is achieved or no active cases remain
#At the end of each simulation, a report will be printed

#report titles
print(c('mobility','pandemic_time','death_toll','vaccines','total_cases'))

#number of iterations on strategy probability
limit<-5
#number of repetitions on with each strategy parameters
reps<-10
#amount of rec people needed for pandemic to end
herd_immunity<-sum(pop[c(1:8,10)])*0.7

#we will run the simulations with a range of probabilities
for (j in 0:limit){
  #new probability parameters for iteration
  strategyR<-c(j/limit,1-j/limit)

  #repetitions per value
  for (e in 1:reps){

    #time accumulator
    t<-0

    #run simulation
    while( sum(pop[c(2,4,6,8,10)]) < herd_immunity ){

      #select strategy according to probabilities
      strat<-sample(strategy, size=1, prob=strategyR)
      #update lambda values according to strategy
      params$lambda<-set_lambda(S=pop[c(1,3,5,7)],params=params,strategy=strat, V=V)
      #obtain times
      times<-get_times(pop,params)
      #identify next event
      chosen<-which(times==min(times[which(times>0)]))[1]
      #execute next event
      pop<-pop+(poss[,chosen])
      #accumulate time
      t<-t+times[chosen]
      #update amount of susceptible people needed for pandemic to end
      herd_immunity<-sum(pop[c(1:8,10)])*0.7
      #register event
      mov<-append(mov,chosen)

    }#end of simulation

    #save important output info for analysis
    tot_vacc<-sum(mov>=13)
    tot_cases<-sum(mov<=4)
    output<-c(strategyR[1],t,pop[[9]],tot_vacc,tot_cases)

    #print and save output
    print(output)

    #reset population values for new simulation repetitions
    pop<-as.vector(c(rbind(S,I),D,R))
    mov<-c()

  }#end of value repetitions

}#end of whole enchilada

print('DONE')


## this is an ugly script -- not meant to be "source'd"
gDat <- read.delim("data/gapminderDataFiveYear.txt")
str(gDat)

## function that returns estimated intercept and slope from linear regression of
## lifeExp on year
## anticipated input: Gapminder data for one country
## see block03 script for development of this
jFun <- function(z) {
  jCoef <- coef(lm(lifeExp ~ I(year - yearMin), z))
  names(jCoef) <- c("intercept", "slope")
  return(jCoef)
}

## get intercept and slope for each country
library(plyr)
yearMin <- min(gDat$year)
gCoef <- ddply(gDat, .(country, continent), jFun)
str(gCoef)
tail(gCoef)

## reordering the continent factor rationally (vs. alphabetically)
library(lattice)
bwplot(slope ~ continent, gCoef)
## alphabetical order is rarely justified

gCoef$continent <- reorder(gCoef$continent, gCoef$slope)
str(gCoef)
bwplot(slope ~ continent, gCoef)
levels(gCoef$continent)
## much more logical
## tables and plots sorted this way will give more insight!

## drop Oceania ... too few countries
gCoef <- subset(gCoef, continent != "Oceania")
levels(gCoef$continent)
## Oceania is still there as factor level?!?
subset(gCoef, continent == "Oceania")
## but no observation have continent Oceania!
gCoef <- droplevels(gCoef)
## gets rid of unused factor levels
levels(gCoef$continent)

## how to store data.frames for posterity

## plain text is always good!
## we slowly built up the arguments below
## you may not want all of these?
write.table(gCoef, "results/gCoef.txt", quote = FALSE, row.names = FALSE, sep = "\t")

## bad news about plain text storage:
## upon re-import via read.table, factors levels revert to alphabetical order
levels(gCoef$continent) # rational level order
rm(gCoef)
gCoef <- read.delim("results/gCoef.txt")
levels(gCoef$continent) # back to alphabetical!!

## let's re-reorder the continent factor levels
gCoef$continent <- reorder(gCoef$continent, gCoef$slope)
bwplot(slope ~ continent, gCoef)
levels(gCoef$continent)

## how to store a data.frame in a plain text file WITH factor level order being
## preserved?
dput(gCoef, "results/gCoef_DPUT.txt")
rm(gCoef)
gCoef <- dget("results/gCoef_DPUT.txt")
levels(gCoef$continent)
## success!
## but the file written by dput() is not easy to browse or open
## in Excel or anywhere outside of R, for that matter

## if we abandon plain text, there is an R-specific binary format
saveRDS(gCoef, "results/gCoef.rds")
rm(gCoef)
gCoef <- readRDS("results/gCoef.rds")
levels(gCoef$continent)
## success!

## bottom line:
## I usually save as plain text AND via (dput|saveRDS|save)
## plain text is for long-term, language-agnostic storage
## *.rds is for my short-/medium-term reuse with R


##
## Calculate Jaccard similarities between the advice, help, sharing and gift networks
##
source("init if necessary.r")

library(igraph)
library(proxy)

flog.info("Started social network analysis - similarities")

# make adjacency matrices from graphs of each type of net-map
adj.advice  = get.adjacency( graph.data.frame( net.maps.advice,  vertices=herders, directed=T), sparse=F )
adj.help    = get.adjacency( graph.data.frame( net.maps.help,    vertices=herders, directed=T), sparse=F )
adj.sharing = get.adjacency( graph.data.frame( net.maps.sharing, vertices=herders, directed=T), sparse=F )
adj.gifts   = get.adjacency( graph.data.frame( gifts,            vertices=herders, directed=T), sparse=F )

# shorthand function to calculate Jaccard similarity between adjacency matrices a and b
jaccard = function(a, b) proxy::simil(list(as.vector(a), as.vector(b)), method="jaccard")

jacs = matrix(NA, nrow=4, ncol=4, dimnames=list(c("Advice", "Help", "Sharing", "Gifts"), c("Advice", "Help", "Sharing", "Gifts")))

# calculate similarities
jacs["Advice", "Help"]    = jaccard(adj.advice, adj.help)
jacs["Advice", "Sharing"] = jaccard(adj.advice, adj.sharing)
jacs["Advice", "Gifts"]   = jaccard(adj.advice, adj.gifts)

jacs["Help", "Sharing"] = jaccard(adj.help, adj.sharing)
jacs["Help", "Gifts"]   = jaccard(adj.help, adj.gifts)

jacs["Sharing", "Gifts"] = jaccard(adj.sharing, adj.gifts)

# save table
write.csv(round(jacs, 3), file.path(results.dir, "Network similarities.csv"), row.names=T)

flog.info("Finished society network analysis - similarities")


PATH <- 'D:/mse/BI/02_data-analytics/02_workshop/00_data/WINE.CSV'

WINE <- read.csv(PATH)
WINE <- scale(WINE[2:14])

WINE_PC <- prcomp(WINE)

biplot(WINE_PC)

PRED <- predict(WINE_PC)
plot(PRED)

WINE_COR <- cor(cbind(WINE, WINE_PC$x[, 1:2]))

library(corrplot)
corrplot(WINE_COR)


a <- c(1, 1, 1)
b <- c(1/sqrt(2), 1/sqrt(3), 1/2)
agm <- arithmeticGeometricMean(a, b)
print(format(agm, digits=16))


# Tree illustrated in Gomez 2013
tree.toy <- make_empty_graph(n=9)
tree.toy <- add_edges(tree.toy, c(2,1,
                                3,1,
                                4,2,
                                5,1,
                                6,5,
                                7,2,
                                8,1,
                                9,6))
V(tree.toy)$user <- 1

###################################################
# Generates trees of correct size?
tree.synthetic <- gen.thread.Lumbreras2016(n=100,
                                          z=c(1,2,3),
                                          alphas = c(1,2,3),
                                          betas = c(1,2,3),
                                          taus = c(0.25, 0.5, 0.75))

expect_that(vcount(tree.synthetic), equals(100))

#################################################
# Creates the dataframe correctly
df.tree <- tree.to.data(tree.toy)
expect_that(nrow(df.tree), equals(vcount(tree.toy)-1))
expect_that(df.tree$post, equals(df.tree$t+1)) # post with k=t+1 added at time t
expect_that(df.tree$lag, equals(df.tree$t-df.tree$parent+1)) # lag = t - k + 1
expect_that(df.tree$popularity[1], equals(1)) # root has popularity 1 when first comment arrives


# Example : 1   Chapter : 5.2     Page No: 255
# Determinant of matrices by multiplying pivots
A<-matrix(c(0,0,4,0,2,5,1,3,6),ncol=3)
P<-matrix(c(0,0,1,0,1,0,1,0,0),ncol=3)
PA<-P%*%A
print(PA)
detA<--1*PA[1,1]*PA[2,2]*PA[3,3]
print(detA)
det(A)
print("detA is the determinant of the given matrix")


library(e1071)
library(randomForest)
library(pROC)
library(ggplot2)
library(caret)

setwd("/Users/Colin/Desktop/Teamwork")
Attr = c("Existing_checking_account",
         "Duration",
         "Credit_history",
         "Purpose",
         "Credit_amount",
         "Savings_account",
         "Present_employment",
         "Installment_rate",
         "Personal_status",
         "Other_debtors",
         "Present_residence",
         "Property",
         "Age",
         "Other_installment_plans",
         "Housing",
         "Existing_credits",
         "Job",
         "Liable_to_provide_maintenance",
         "Telephone",
         "Foreign_worker",
         "Credit")

data = read.csv(file = "GermanCreditData.csv",
                header = TRUE,
                col.names = Attr
)
data$Credit = as.factor(data$Credit)

#resampling for a balance
balance <- function(data,yval) {
  y.vector <- with(data,get(yval))
  index.0 <- which(y.vector==1)
  index.1 <- which(y.vector==2)
  index.1 <- sample(index.1, length(index.0), replace = TRUE)
  result <- data[sample(c(index.0,index.1)),]
  result
}
data <- balance(data, "Credit")

set.seed(12345)
train_RowIDs = sample(1:nrow(data), nrow(data)*0.7)
train_Data = data[train_RowIDs,]
test_Data = data[-train_RowIDs,]

table(data$Credit)
table(train_Data$Credit)
table(test_Data$Credit)

model = svm(Credit ~ .,
            data = train_Data,
            type = "C-classification",
            kernel = "radial",
            #            kernel = "linear",
            cost = 10, gamma = 0.1)
summary(model)
ind_train_data = train_Data[,1:20]
pred_Train = predict(model, ind_train_data)
cm_Train = table(train_Data$Credit, pred_Train)
print(cm_Train)

ind_test_data = test_Data[,1:20]
pred_Test = predict(model, ind_test_data)
cm_Test = table(test_Data$Credit, pred_Test)
print(cm_Test)
accu_Test= sum(diag(cm_Test))/sum(cm_Test)

rf = randomForest(Credit ~ ., data = train_Data, importance = TRUE)
DrawL<-par()
par(mfrow=c(2,1),mar=c(5,5,3,1))
plot(rf,main="Random Forest Error VS Number of Decision Trees")
plot(margin(rf),type="h",main="Margin Detection",
     xlab="Observations",ylab="Ration")

rf1 = randomForest(Credit ~ ., data = train_Data, importance = TRUE, ntree = 140)
importance(rf1,type=1)
varImpPlot(x=rf1, sort=TRUE, n.var=nrow(rf$importance),main="Importance of Variables")

rm(list = ls())
setwd("/Users/Colin/Desktop/Teamwork")
Attr = c("Existing_checking_account",
         "Duration",
         "Credit_history",
         "Purpose",
         "Credit_amount",
         "Savings_account",
         "Present_employment",
         "Installment_rate",
         "Personal_status",
         "Other_debtors",
         "Present_residence",
         "Property",
         "Age",
         "Other_installment_plans",
         "Existing_credits",
         "Job",
         "Telephone",
         "Credit")

data = read.csv(file = "Credit.csv",
                header = TRUE,
                col.names = Attr
)
data$Credit = as.factor(data$Credit)

#resampling for a balance
balance <- function(data,yval) {
  y.vector <- with(data,get(yval))
  index.0 <- which(y.vector==1)
  index.1 <- which(y.vector==2)
  index.1 <- sample(index.1, length(index.0), replace = TRUE)
  result <- data[sample(c(index.0,index.1)),]
  result
}
data <- balance(data, "Credit")

set.seed(12345)
train_RowIDs = sample(1:nrow(data), nrow(data)*0.7)
train_Data = data[train_RowIDs,]
test_Data = data[-train_RowIDs,]

table(data$Credit)
table(train_Data$Credit)
table(test_Data$Credit)

model = svm(Credit ~ .,
            data = train_Data,
            type = "C-classification",
            kernel = "radial",
            #            kernel = "linear",
            cost = 100, gamma = 0.01)
summary(model)
ind_train_data = train_Data[,1:17]
pred_Train = predict(model, ind_train_data)
cm_Train = table(train_Data$Credit, pred_Train)
print(cm_Train)

ind_test_data = test_Data[,1:17]
pred_Test = predict(model, ind_test_data)
cm_Test = table(test_Data$Credit, pred_Test)
print(cm_Test)
accu_Test= sum(diag(cm_Test))/sum(cm_Test)


library("car")
data("Leinhardt")

head(Leinhardt)
str(Leinhardt)
pairs(Leinhardt)

plot(infant ~ income, data=Leinhardt)
hist(Leinhardt$infant)
hist(Leinhardt$income)

Leinhardt$loginfant = log(Leinhardt$infant)
Leinhardt$logincome = log(Leinhardt$income)

plot(loginfant ~ logincome, data=Leinhardt)

###Modeling
lmod = lm(loginfant ~ logincome, data=Leinhardt)
summary(lmod) # estimates of coefficents very large in comparison to their standard error, showing statistical significance
              #r-squared tells us how much of the variability is explained by model

dat = na.omit(Leinhardt)
#Leinhardt

library("rjags")

# likelyhood is a normal distribution  p(y|mu)
# use a linearn model to draw mu
# prior on the leniar model coeficents is a normal distribution with 2 coefecients, mean =0 and a variance = 1m
# sig^2: inverse gamma for the variance == gamma prior on precision
# lower the sample size of prior if we are not so confident in guess
mod2_string =" model {
    for (i in 1:n){
        y[i] ~ dnorm(mu[i], prec)
        mu[i] = b[1] + b[2]*log_income[i] + b[3]*is_oil[i]
    }

    for (j in 1:3){
        b[j] ~ dnorm(0.0, 1.0/1.0e6)
    }

    prec ~ dgamma(5.0/2.0, 5.0*10.0/2.0)
    sig2 = 1.0 / prec
    sig = sqrt(sig2)

} "

set.seed(75)
data2_jags = list(y=dat$loginfant, n=nrow(dat), log_income=dat$logincome, is_oil=as.numeric(dat$oil=="yes"))

data2_jags$is_oil

# choose to monitor standard dev
params2 = c("b", "sig")

inits2 = function() {
    inits = list("b"=rnorm(3, 0.0, 100.0), "prec"=rgamma(1,1.0,1.0))
}

# run the model with 3 chains each starting with inits1 params
mod2 = jags.model(textConnection(mod2_string), data=data2_jags, inits=inits2, n.chains=3)

dic.samples(mod1, n.iter=1e3)

# burn in period
update(mod2, 1000)

mod2_sim = coda.samples(model=mod2, variable.names=params2, n.iter=5e3)

# stack matrices vertically
mod2_csim = do.call(rbind, mod2_sim)

### Convergence
plot(mod2_sim)
gelman.diag(mod2_sim)
autocorr.diag(mod2_sim)
effectiveSize(mod2_sim)
summary(mod2_sim)
summary(lmod)

### Residuals differece between response the actual obsevation and the models prediction for each value
# very important as they revieal violations with our assumptions to specify mode
# looking for signs of non liniarity, not normally distributed, obsevation are not independent from one another
lmod0 = lm(infant ~ income, data=Leinhardt)
plot(resid(lmod0)) # assume independence if no patterns seen
plot(predict(lomd0), resid(lmod0)) # want to see randomness
qqnorm(resid(lmod0)) # check for normality, if nomal posint follow straight line, curves shows squew

X = cbind(rep(1.0, dat2_jags$n), data2_jags$log_income, data2_jags$is_oil)

pm_params2 = colMeans(mod2_csim)

yhat = drop(X %*% pm_params2[1:3]) #vector of predicated values from model
resid2 = data2jags$y - yhat

plot(resid2)
plot(yhat, resid2)
qqnorm(resid2)

head(rownames(dat)[order(resid2, decreasing=TRUE)])

#tau = scale parameter
# df= degrees of freedom, smaller give heavier tail
# for the model (likeylihood) to have a mea nand variance we force the df to be greater than 2
mod3_string =" model {
    for (i in 1:n){
        y[i] ~ dt(mu[i], rau, df)
        mu[i] = b[1] + b[2]*log_income[i] + b[3]*is_oil[i]
    }

    for (j in 1:3){
        b[j] ~ dnorm(0.0, 1.0/1.0e6)
    }

    df = nu + 2.0
    nu ~ dexp(1.0)

    tau ~ dgamma(5.0/2.0, 5.0*10.0/2.0)
    sig = sqrt(1.0/tau * df/(df-2.0))
} "


# obtaining RMST for unmatched and then matched datasets.

library(easypackages)
libraries(c("survival","survRM2","tidyverse",
	"tidylog"))

df <- read_csv("D:/lita_bita3/complete_dataset.csv")

# some small changes before tables...

df$diabetes[df$diabetes == 8]<- 0

df$left_main_disease[df$left_main_disease == 2]<- 0

df <- df %>% filter(distals_n != 1)

# km

df$surv_years <- (df$survival_days + 1)/365.24

s <- survfit(Surv(surv_years, died) ~ bima, data = df)

summary(s, times = c(0,5,10,15))

survdiff(Surv(surv_years, died) ~ bima, data = df)

# rmst

survRM2::rmst2(time = df$surv_years,
status = df$died,
arm = df$bima,
tau = 5)

survRM2::rmst2(time = df$surv_years,
status = df$died,
arm = df$bima,
tau = 10)

survRM2::rmst2(time = df$surv_years,
status = df$died,
arm = df$bima,
tau = 15)

# now for the matched dataset.

dfm = read_csv("D:/lita_bita3/matched_data.csv")

dfm$surv_years <- (dfm$survival_days + 1)/365.24

# rmst

survRM2::rmst2(time = dfm$surv_years,
status = dfm$died,
arm = dfm$bima,
tau = 5)

survRM2::rmst2(time = dfm$surv_years,
status = dfm$died,
arm = dfm$bima,
tau = 10)

survRM2::rmst2(time = dfm$surv_years,
status = dfm$died,
arm = dfm$bima,
tau = 15)

# now to do the same for ROMA unmatched and then matched data.

rm = read_csv("D:/lita_bita3/df_roma_dataset.csv")

glimpse(rm)

rm$surv_years = ( 1 + rm$survival_days)/365.24

survRM2::rmst2(time = rm$surv_years,
status = rm$died,
arm = rm$bima,
tau = 5)

survRM2::rmst2(time = rm$surv_years,
status = rm$died,
arm = rm$bima,
tau = 10)

survRM2::rmst2(time = rm$surv_years,
status = rm$died,
arm = rm$bima,
tau = 15)

ROMA matched :-

rm_m <- read_csv("D:/lita_bita3/matched_data_roma.csv")

glimpse(rm_m)

survRM2::rmst2(time = rm_m$surv_years,
status = rm_m$died,
arm = rm_m$bima,
tau = 5)

survRM2::rmst2(time = rm_m$surv_years,
status = rm_m$died,
arm = rm_m$bima,
tau = 10)

survRM2::rmst2(time = rm_m$surv_years,
status = rm_m$died,
arm = rm_m$bima,
tau = 15)


#function( rna ) {

rna = c ( .9, .8, .7, .88, .65, .75 );

no_rna = 1 - rna;

#Initialize the vector of probabilities for different number of mRNAs
prob = rep( 0, length(rna)+1 );
allInds = 1:length(rna);

#Zero RNAs
prob[1] = prod( no_rna );

library( 'gregmisc' )
# 1 RNA
for (i in 2:length(rna)){

	 ind = combinations( length(rna), i );

	 for (j in 1:attr( ind, "dim")[1] ){

			prob[1+i] = prob[1+i] +  prod( rna[ ind[j,] ] ) * prod( no_rna[  setdiff( allInds, ind[j,] ) ] );
	}

}

plot( prob, type="b", col = "red",  )
print(  sum( prob ) )

#}
#<environment: namespace:base>


gig_lpdf <- function(x,p,a,b) {
  (p * 0.5 * log(a / b)
      - log(2 * besselK(sqrt(a * b), p))
      + (p - 1) * log(x)
      - (a * x + b / x) * 0.5
  )
}

x <- exp(seq(-10,log(10),length.out=200))
plot(x,exp(gig_lpdf(x,2,1,1)))


# Data Wrangling in R
# 5.2 Missing and Special Values in R
#

# Load the tidyverse and the food inspections dataset
library(tidyverse)

names <- c("ID", "DBAName", "AKAName", "License", "FacilityType", "Risk", "Address",
           "City", "State", "ZIP", "InspectionDate", "InspectionType", "Results",
           "Violations", "Latitude","Longitude","Location")

inspections <- read_csv('http://594442.youcanlearnit.net/inspections.csv',
                        col_names=names, skip=1)

# Look at a summary of the data
summary(inspections)

# Which inspections have NA values for license?

is.na(inspections$License)
which(is.na(inspections$License))
nolicense<-which(is.na(inspections$License))
inspections[nolicense,]

# Create two new tibbles, one for licensed facilities and one for unlicensed facilities
unlicensed <- inspections[nolicense,]
licensed <- inspections[-nolicense,]

# What happens if I divide a number by 0

badmath <- c(1,2,3,4/0,0/0,NA)
badmath
is.na(badmath)
is.nan(badmath)
is.infinite(badmath)
is.finite(badmath)


# preamble (options, installs, imports & custom functions) ----

options(warn=1) # really should be default in R

# specify the packages used:
required_packages = c(
	'github.com/rmcelreath/rethinking' # for rlkjcorr & rmvrnom2
	, 'github.com/stan-dev/cmdstanr' # for Stan stuff
	, 'github.com/stan-dev/posterior' # for posterior diagnostics & summaries
	, 'tidyverse' # for all that is good and holy
)

# load the helper functions:
for(file in fs::dir_ls('r_helpers')){
	cat('Loading function: ',fs::path_ext_remove(fs::path_file(file)),'()\n',sep='')
	source(file)
}
install_if_missing(required_packages)

# load the tidyverse (instead of imports bc lazy)
library(tidyverse)
library(magrittr) #for other pipes

# simulate data ----
set.seed(1) # change this to make different data

# setting the data simulation parameters
lst(
	# parameters you can play with
	num_subj = 3e1 # number of subjects, must be an integer >1
	, num_vars = 3 # number of 2-level variables manipulated as crossed and within each subject, must be an integer >0
	#num_trial will determine whether the cp or ncp models will sample better
	, num_trials = 1e3 # number of trials per subject/condition combo, must be an integer >1
	# the rest of these you shouldn't touch
	, num_coef = 2^(num_vars)
	, coef_means = rep(0,num_coef) #rnorm(num_coef)
	, coef_sds = rep(1,num_coef) #rweibull(num_coef,2,1)
	, cor_mat = diag(nrow=num_coef,ncol=num_coef) #rethinking::rlkjcorr(1,num_coef,eta=1)
	, noise = rweibull(1,2,1)
) -> sim_pars
sim_pars$cor_mat
summary(sim_pars$cor_mat[lower.tri(sim_pars$cor_mat)])
hist(sim_pars$cor_mat[lower.tri(sim_pars$cor_mat)],br=100,xlim=c(-1,1))

y = rethinking::rmvnorm2(
	n = 1e5 # yes, many more than we actually need; will eventually subset to sim_pars$num_subj
	, Mu = sim_pars$coef_means
	, sigma = sim_pars$coef_sds
	, Rho = sim_pars$cor_mat
)

#create odd/even as slight deviates from y
odd = y
dimnames(odd)=list(NULL,paste0('odd_v',1:ncol(odd)))
even = y
dimnames(odd)=list(NULL,paste0('even_v',1:ncol(even)))
for(i_k in 1:sim_pars$num_coef){
	odd[,i_k] = y[,i_k] + rnorm(nrow(y),0,sim_pars$coef_sds[i_k]/3)
	even[,i_k] = y[,i_k] + rnorm(nrow(y),0,sim_pars$coef_sds[i_k]/3)
}
y = cbind(odd,even)
dimnames(y) = list(
	NULL
	, c(
		paste0('odd_v',1:ncol(odd))
		, paste0('even_v',1:ncol(even))
	)
)

#now estimate the true values given this large-N set
sim_pars$num_coef = 2*sim_pars$num_coef
sim_pars$coef_means = apply(y,2,mean)
sim_pars$coef_sds = apply(y,2,sd)
sim_pars$cor_mat = cor(y)
summary(sim_pars$cor_mat[lower.tri(sim_pars$cor_mat)])
hist(sim_pars$cor_mat[lower.tri(sim_pars$cor_mat)],br=100,xlim=c(-1,1))

#now we trim down to the requested N
(
	y[1:sim_pars$num_subj,]
	%>% as_tibble()
	%>% mutate(
		subj = 1:n()
	)
) -> subj_coef

# compute the contrast matrix
(
	1:sim_pars$num_vars
	%>% map(.f=function(x){
		factor(c('lo','hi'))
	})
	%>% (function(x){
		names(x) = paste0('v',1:sim_pars$num_vars)
		return(x)
	})
	%>% cross_df()
	%>% get_contrast_matrix(
		formula = as.formula(paste('~1+',paste0('v',1:sim_pars$num_vars,collapse='*')))
		, contrast_kind = halfsum_contrasts
	)
) -> contrast_matrix

# get condition means implied by subject coefficients and contrast matrix
(
	subj_coef
	%>% pivot_longer(
		cols = -subj
		, names_to = c('split','name')
		, names_sep = '_'
	)
	%>% pivot_wider()
	%>% group_by(subj,split)
	%>% summarise(
		(function(x){
			out = attr(contrast_matrix,'data')
			out$cond_mean = as.vector(contrast_matrix %*% t(x))
			return(out)
		})(cur_data())
		, .groups = 'drop'
	)
) -> subj_cond

# get noisy measurements in each condition for each subject
(
	subj_cond
	%>% expand_grid(trial = 1:sim_pars$num_trials)
	%>% mutate(
		obs = rnorm(n(),cond_mean,sim_pars$noise)
	)
	%>% select(-cond_mean)
) -> dat

# dat is now what one would have if a real dataset had been collected
print(dat)

# Compute inputs to model ----

# W: the full trial-by-trial contrast matrix
(
	dat
	%>% mutate(dat_row=1:n())
	%>% group_by(subj,split)
	%>% summarise(
		dat_row = dat_row
		, as_tibble(get_contrast_matrix(
			data = cur_data()
			, as.formula(paste0('~1+',paste0('v',1:sim_pars$num_vars,collapse='*')))
			, contrast_kind = halfsum_contrasts
		))
		, .groups = 'drop'
	)
	%>% pivot_longer(
		cols = c(-split,-subj,-dat_row)
	)
	%>% unite(col='name',split,name)
	%>% pivot_wider(values_fill=0)
	%>% arrange(dat_row)
) -> W

# quick glimpse; lots of rows
glimpse(W)

# get the unique entries in W
(
	W
	%>% select(-subj,-dat_row)
	%>% distinct()
) -> uW
glimpse(uW)
# far fewer rows!

# for each unique condition specified by uW, the stan model will
# work out values for that condition for each subject, and we'll need to index
# into the resulting subject-by-condition matrix. So we need to create our own
# subject-by-condition matrix and get the indices of the observed data into a
# the array produced when that matrix is flattened.
(
	uW
	%>% mutate(
		uW_row = 1:n()
	)
	# first repeat the matrix so there's a copy for each subject
	%>% slice(
		rep(
			row_number()
			, each=length(unique(dat$subj))
		)
	)
	# add subject labels
	%>% mutate(
		subj = rep(sort(unique(dat$subj)),times=nrow(uW))
	)
	%>% arrange(uW_row,subj)
	# add a row index
	%>% mutate(
		uW_by_subj_row = 1:n()
	)
	# join to the full contrast matrix W
	%>%	right_join(
		W
		, by = c(names(uW),'subj')
	)
	# ensure ordered as the original data
	%>% arrange(dat_row)
	# pull the row label
	%>%	pull(uW_by_subj_row)

) -> obs_index

# package for stan & sample ----

data_for_stan = lst( # lst permits later entries to refer to earlier entries

	####
	# Entries we need to specify ourselves
	####

	# W: within predictor matrix
	w = as.matrix(uW)

	# num_subj: number of subjects
	, n = length(unique(dat$subj))

	# outcome: outcome on each trial
	, obs = dat$obs

	# obs_index: index of each trial in flattened version of subject-by-condition value matrix
	, obs_index = obs_index

	####
	# Entries computable from the above
	####

	# num_obs: total number of observations
	, o = length(obs)

	# num_rows_W: num rows in within predictor matrix W
	, kw = nrow(w)

	, is_intercept = as.numeric(guess_if_intercept(w))
)

# double-check:
glimpse(data_for_stan)

# sample the posterior ----
mod = cmdstanr::cmdstan_model(
	'stan/mvn_cp.stan'
	# 'stan/pairwise_mvn_cp.stan'
	, include = 'stan'
)
iter_warmup = 1e3
iter_sampling = 1e3
fit = mod$sample(
	data = data_for_stan
	, chains = parallel::detectCores()/2
	, parallel_chains = parallel::detectCores()/2
	, iter_warmup = iter_warmup
	, iter_sampling = iter_sampling
	, seed = 1
	, refresh = (iter_warmup+iter_sampling)/10
)

#save in case we want to look at the fit later
fit$save_object(
	paste(
		str_remove(fit$metadata()$model_name,'_model')
		, sim_pars$num_subj
		, sim_pars$num_vars
		, sim_pars$num_trials
		, 'fit.rds'
		, sep='_'
		, collapse='_'
	)
)
# see ?CmdStanMCMC for methods available for `fit`

#run cmdstan diagnostics for divergences, E-BFMI, etc
fit$cmdstan_diagnose()

# gather summary for core parameters (inc. rhat & ess)
(
	c('lp__','noise','z_m','z_s','r')
	%>% fit$draws()
	%>% posterior::summarise_draws(
		'rhat'
		, 'ess_bulk'
		, 'ess_tail'
		, 'median'
		, 'quantile2'
	)
	#adjust names a bit so proper_level_order works
	%>% mutate(
		variable = str_remove(variable,']')
		, variable = str_replace(variable,fixed('['),fixed('.'))
		, variable = str_replace(variable,',',fixed('.'))
	)
) -> fit_summary

# check the range of rhat & ess
(
	fit_summary
	%>% select(rhat,contains('ess'))
	%>% summary()
)

# show the full tibble
# print(fit_summary,n=nrow(fit_summary))

# plot the group-level parameters
(
	fit_summary
	%>% filter(str_starts(variable,'z_m'))
	%>% mutate(
		variable = factor(variable,levels=proper_level_order(variable))
	)
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = median
			, fill = rhat
		)
		, shape=21
		, size = 5
	)
	+ coord_flip()
	+ scale_color_gradient(
		high = 'white'
		, low = scales::muted('red')
	)
	+ scale_fill_gradient(
		low = 'white'
		, high = scales::muted('red')
	)
	+ labs(y = 'posterior')
	+ theme(
		panel.background = element_rect(fill='grey50')
		, panel.grid = element_blank()
	)
)

(
	fit_summary
	%>% filter(str_starts(variable,'z_s'))
	%>% mutate(
		variable = factor(variable,levels=proper_level_order(variable))
	)
	%>% ggplot()
	+ geom_hline(yintercept=1)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = median
			, fill = rhat
		)
		, shape=21
		, size = 5
	)
	+ coord_flip()
	+ scale_color_gradient(
		high = 'white'
		, low = scales::muted('red')
	)
	+ scale_fill_gradient(
		low = 'white'
		, high = scales::muted('red')
	)
	+ labs(y = 'posterior')
	+ theme(
		panel.background = element_rect(fill='grey50')
		, panel.grid = element_blank()
	)
)

(
	fit$summary('r')
	%>% mutate(
		variable = factor(variable,levels=proper_level_order(variable))
	)
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = median
			, fill = rhat
		)
		, shape = 21
		, size = 5
	)
	+ coord_flip()
	+ scale_color_gradient(
		high = 'white'
		, low = scales::muted('red')
	)
	+ scale_fill_gradient(
		low = 'white'
		, high = scales::muted('red')
	)
	+ labs(y = 'posterior')
	+ scale_y_continuous(limits=c(-1,1))
	+ theme(
		panel.background = element_rect(fill='grey50')
		, panel.grid = element_blank()
	)
)

# plot the subject-level deviations-from-true
(
	fit$summary('z')
	%>% left_join(
		(
			subj_coef
			%>% (function(x){
				ncxm1 = ncol(x) - 1
				names(x)[names(x)!='subj'] = as.character(1:ncxm1)
				return(x)
			})
			%>% pivot_longer(
				-subj
				# , names_prefix = 'v'
			)
			%>% mutate(
				variable = paste0('z[',subj,',',name,']')
			)
		)
	)
	%>% mutate(
		median = median - value
		, q5 = q5 - value
		, q95 = q95 - value
		, name = factor(name,levels=proper_level_order(name))
	)
	%>% group_by(name)
	%>% arrange(median)
	%>% mutate(x=1:n())
	%>% ggplot()
	+ facet_grid(
		name~.
		, scales = 'free'
	)
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = x
			, ymin = q5
			, ymax = q95
			, colour = median
		)
	)
	+ scale_color_gradient2(guide=F)
	+ theme(
		panel.background = element_rect(fill='grey50')
		, panel.grid = element_blank()
	)
)


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 2.7B   Chapter : 2.7   Pageno : 115
# Symmetric Factorisation
library(pracma)
A<-matrix(c(1,4,5,4,2,6,5,6,3),ncol=3)
L<-lu(A)$L
D<-lu(A)$U
for(i in 1:3){
  j<-i+1
  while(j<=3){
    D[i,j]<-0
    j<-j+1
  }
}
LT<-t(L)
print("Symmetric factorisation of A=LDLT")
print(L)
print(D)
print(LT)
print(L%*%D%*%LT)


# Thanks: Kai Chen. M.D.
# Resident
# Dept of Breast surgery,
# Breast Tumor Center;
# Sun Yat-sen Memorial Hospital
# chenkai23@mail.sysu.edu.cn

# Fit logistic model on 100 observations simulated from the actual
# model given by Prob(Y=1 given X1, X2, X3) = 1/(1+exp[-(-1 + 2X1)]),
# where X1 is a random uniform [0,1] variable.  Hence X2 and X3 are
# irrelevant.  After fitting a linear additive model in X1, X2,
# and X3, the coefficients are used to predict Prob(Y=1) on a
# separate sample of 100 observations.  Note that data splitting is
# an inefficient validation method unless n > 20,000.

require(rms)
set.seed(1)
n <- 200
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
logit <- 2*(x1-.5)
P <- 1/(1+exp(-logit))
y <- ifelse(runif(n)<=P, 1, 0)
d <- data.frame(x1,x2,x3,y)
f <- lrm(y ~ x1 + x2 + x3, subset=1:100)
pred.logit <- predict(f, d[101:200,])
phat <- 1/(1+exp(-pred.logit))

val.prob(phat, y[101:200], m=20, cex=.5)  # subgroups of 20 obs.

val.prob(x2[101:200], y[101:200], m=20, cex=.5)  # subgroups of 20 obs.


#!/usr/bin/Rscript
##
## Simulate data for UG with causal judgments
##
library(ggplot2)
library(tidyr)
library(dplyr)
library(lme4)
library(lmerTest)
library(ggeffects)

cat('\nSetting up priors...')
## prior definitions for AI players
N <- 10
priors.ai <- data.frame(player=c('A', 'B', 'C'),
                        rate=c(0.8, 0.5, 0.2)) %>%
    mutate(offer.s1=rate*N,
           offer.s2=(1-rate)*N,
           accept.s1=(1-rate)*N,
           accept.s2=rate*N)

## Display densities of AI priors for proposing/accepting offers
priors.ai %>% crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(poffer=dbeta(offer, offer.s1, offer.s2)) %>%
    ggplot(aes(x=offer, y=poffer, color=player)) +
    geom_line() + theme_classic() + ylab('P(offer=X | player)') +
    ggtitle('When AI proposes, P(offer=X | player)')
ggsave('ai-proposal-prior.png')

priors.ai %>% crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(paccept=pbeta(offer, accept.s1, accept.s2)) %>%
    ggplot(aes(x=offer, y=paccept, color=player)) +
    geom_line() + theme_classic() +
    ylab('P(Accept | offer=X, player)') +
    ggtitle('When AI accepts, P(Accept | offer=X, player)')
ggsave('ai-acceptance-prior.png')

priors.ai %>% crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(cause=(1 - dbeta(offer, offer.s1, offer.s2) / 10)) %>%
    ggplot(aes(x=offer, y=cause, color=player)) + ylim(0, 1) +
    geom_line() + theme_classic() + ylab('Approx. Causal Judgment')
ggsave('cause-accept.png')

priors.ai %>% crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(cause=(1 - pbeta(offer, accept.s1, accept.s2)/2)) %>%
    ggplot(aes(x=offer, y=cause, color=player)) +
    geom_line() + theme_classic() + ylim(0, 1) +
    ylab('Approx. Causal Judgment | AI rejected offer')
ggsave('cause-propose-accept.png')

priors.ai %>% crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(cause=(1 + pbeta(offer, accept.s1, accept.s2))/2) %>%
    ggplot(aes(x=offer, y=cause, color=player)) +
    geom_line() + theme_classic() + ylim(0, 1) +
    ylab('Approx. Causal Judgment | AI accepted offer')
ggsave('cause-propose-reject.png')

## Define subject-level priors for acceptance
##
## Here we're assuming that subjects are approximately fair, with
##   priors ~ B(s1, s2), s1 ~ N(10, 2), s2 ~ N(10, 2).
##
## We're also assuming that subjects behave identically with different partners
##
## These can be changed in the future to better match human behavior
N <- 100  # number of participants
priors.subj <- data.frame(id=1:N,
                          condition=rep(c('propose', 'accept'), each=N/2),
                          subj.s1=rnorm(N, mean=10, sd=3),
                          subj.s2=rnorm(N, mean=10, sd=3))

## Display subject priors
png('human-proposal-prior.png')
priors.subj %>% filter(condition == 'propose') %>%
    crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(poffer=dbeta(offer, subj.s1, subj.s2)) %>%
    ggplot(aes(x=offer, y=poffer)) +
    stat_smooth(method="loess", span=0.1, se=TRUE, alpha=0.3) + theme_classic() +
    ylab('P(offer=X | player)') +
    ggtitle('When Participant proposes, P(offer=X)')
dev.off()
png('human-acceptance-prior.png')
priors.subj %>% filter(condition == 'accept') %>%
    crossing(offer=seq(from=0, to=1, by=0.01)) %>%
    mutate(paccept=pbeta(offer, subj.s1, subj.s2)) %>%
    ggplot(aes(x=offer, y=paccept)) +
    stat_smooth(method="loess", span=0.1, se=TRUE, alpha=0.3) + theme_classic() +
    ylab('P(Accept | offer=X, player)') +
    ggtitle('When Participant accepts, P(Accept | offer=X)')
dev.off()

cat('done.\n')

## Simulate trial-level data
##
cat('Simulating data...')
TRIALS <- 25 # number of trials per subj/AI
df <- priors.subj %>% crossing(priors.ai) %>%
    mutate(ai.s1=ifelse(condition == 'propose', accept.s1, offer.s1),
           ai.s2=ifelse(condition == 'propose', accept.s2, offer.s2)) %>%
    select(-offer.s1, -offer.s2, -accept.s1, -accept.s2) %>%
    crossing(trial=1:TRIALS) %>%
    rowwise %>%
    mutate(offer=ifelse(condition=='propose',
                        rbeta(1, subj.s1, subj.s2),
                        rbeta(1, ai.s1, ai.s2)),
           accept=ifelse(condition=='propose',
                         rbinom(1, 1, pbeta(offer, ai.s1, ai.s2)),
                         rbinom(1, 1, pbeta(offer, subj.s1, subj.s2))),
           earning=ifelse(accept, offer, 0),
           cause=(1 - dbeta(offer)/10))
cat('done.\n')

cat('Fitting lmer...')
m <- glmer(accept ~ player * offer * condition + (1 | id),
           family=binomial(link='logit'),
           data=df)
summary(m)
png('lmer.png')
m %>% ggpredict(terms=c('offer [all]', 'player', 'condition')) %>% plot()
dev.off()
cat('done.')


## Absolute error vals for the whole range (including outliers)
rf_error_vals = abs(w$Time.s. - w$pred_rfe)
#hist(rf_error_vals, main = "", xlab = "", ylab="")

## Relative error including outliers
rf_rel_ev = sapply(rf_error_vals, function(x) x/253)
#hist(rf_rel_ev, main = "", xlab = "", ylab="")
#rug(rf_rel_ev)

library(dplyr)

## Eliminate outliers
no_outliers_0 = quantile(w$Time.s., probs = c(0.00, 1.0))
no_outliers_df_0 = data.frame(w$Time.s., w$pred_rfe)
dd_0 = no_outliers_df_0 %>% filter(no_outliers_df_0$w.Time.s. >= no_outliers_0[1] & no_outliers_df_0$w.Time.s. <= no_outliers_0[2])
range_no_outliers_0 = max(dd_0$w.Time.s.) - min(dd_0$w.Time.s.)
no_outliers_rf_error_0 = abs(dd_0$w.Time.s. - dd_0$w.pred_rfe)
no_outliers_rf_rel_error_0 = sapply(no_outliers_rf_error_0, function(x) x/range_no_outliers_0)

## Plot the maximum relative error per quantile
cdf_0 = quantile(no_outliers_rf_rel_error_0, seq(0.01,1,0.01))
no_outliers_median_rel_error_0 = sapply(seq(1,100,1), function(x) median(no_outliers_rf_rel_error_0[no_outliers_rf_rel_error_0 < cdf_0[x]]))
lines(cdf_0, lty=5, lwd=3, col="#aa6666")

## Add median error
lines(no_outliers_median_rel_error_0, col="#aa6666", lwd=3, lty=4)

## Add legend
legend("topleft", title="Type of error", c("Maximum error with 10% of outliers removed",
                                           "Maximum error with 4% of outliers removed",
                                           "Maximum error with 0% of outliers removed",
                                           "Median error with 10% of outliers removed",
                                           "Median error with 4% of outliers removed",
                                           "Median error with 0% of outliers removed"),
       col=c("black", "#999999", "#aaaaaa", "black", "#999999", "#aaaaaa"),
       lwd=c(2,3,3,2,3,3),
       lty=c(1,2,5,6,3,4))


# Run the code below to set up the data

library(tidyverse)
library(babynames)
y2015 <- filter(babynames, year==2015)
y2015

# Create a histogram of the number of babies with a name in 2015
# Pick an appropriate number of bins (no right answer)
# Log the x axis
# Facet the graph by sex
# Set the axis labels and title appropriately

# Note: there are a lot of names; it could take a second to plot

ggplot(y2015, aes(n)) +
  geom_histogram(bins=20) +
  scale_x_log10() +
  facet_wrap(~sex) + # you could use other facet functions
  labs(x="Number of Babies with Name",
       y="Number of Names, 2015",
       title="Distribution of Baby Name Frequencies")

# Bonus: Change the facet labels to Female and Male

ggplot(y2015, aes(n)) +
  geom_histogram(bins=20) +
  scale_x_log10() +
  facet_wrap(~factor(sex, levels=c("F", "M"), labels=c("Female","Male"))) +
  labs(x="Number of Babies with Name",
       y="Number of Names, 2015",
       title="Distribution of Baby Name Frequencies")

# Alternative Bonus Answer (not shown in workshop)
ggplot(y2015, aes(n)) +
  geom_histogram(bins=20) +
  scale_x_log10() +
  facet_wrap(~sex, labeller=as_labeller(c("F"="Female", "M"="Male"))) +
  labs(x="Number of Babies with Name",
       y="Number of Names, 2015",
       title="Distribution of Baby Name Frequencies")


library(quantmod)

rm(list=ls())
par(mfrow=c(1, 2))

# Transaction commission fee is 0.1425%.
# Seller must also pay 0.3% government tax.
long <- function(price) {
    return(price * (1 + 0.001425))
}

short <- function(price) {
    return(price * (1 - 0.001425 - 0.003))
}

# Prepare data.
stock <- na.omit(get(getSymbols('AMZN')))
opp <- Op(stock) # [op]en [p]rices
clp <- Cl(stock) # [cl]ose [p]rices
hi_max <- lag( runMax( Hi(stock), 6) )
lo_min <- lag( runMin( Lo(stock), 4) )

# Strategy 1: Long one short one.
pl <- setNames( rep( 0, length(clp) ), time(stock) )
flag <- FALSE
for ( m in 7:( nrow(stock) - 1 ) ) {
    if (flag == FALSE && clp[m] > hi_max[m]) {
        cur_long <- long( as.numeric( opp[m+1] ) )
        flag <- TRUE
    }
    else if (flag == TRUE && clp[m] < lo_min[m]) {
        pl[m] <- short( as.numeric( opp[m+1] ) ) - cur_long
        flag <- FALSE
    }
}
#plot( cumsum(pl), type='l', col='red', lwd=2 )
win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
gain_rate <- mean( pl[pl > 0] ) / abs(mean( pl[pl < 0] ))
profit_factor <- sum( sum(pl[pl > 0]) ) / abs( sum(pl[pl < 0]) )
#View(cbind(win_rate, gain_rate, profit_factor))
dd <- cumsum(pl) - cummax( cumsum(pl) )
y_range <- range( dd, cumsum(pl) )
plot(dd, type='h', col='green', ylim=y_range)
par(new=T)
plot(cumsum(pl), type='h', col='orange', lwd=2, ylim=y_range)
points(which(dd == 0), cummax( cumsum(pl) )[which(dd == 0)], pch=4, col='red')
tail(sort(diff(which(dd==0))), 5)

# Strategy 2: Long accumulatively short all.
pl <- setNames( rep( 0, length(clp) ), time(stock) )
cum_long <- 0
n <- 0 # [n]umber of stocks long.
for ( m in 7:( nrow(stock) - 1 ) ) {
    if (clp[m] > hi_max[m]) {
        cum_long <- cum_long + long( as.numeric( opp[m+1] ) )
        n <- n + 1
    }
    else if (clp[m] < lo_min[m]) {
        pl[m] <- short( as.numeric( opp[m+1] ) * n ) - cum_long
        cum_long <- 0
        n <- 0
    }
}
#plot( cumsum(pl), type='l', col='red', lwd=2 )
win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
gain_rate <- mean( pl[pl > 0] ) / abs(mean( pl[pl < 0] ))
profit_factor <- sum( sum(pl[pl > 0]) ) / abs( sum(pl[pl < 0]) )
#View(cbind(win_rate, gain_rate, profit_factor))
dd <- cumsum(pl) - cummax( cumsum(pl) )
y_range <- range( dd, cumsum(pl) )
plot(dd, type='h', col='green', ylim=y_range)
par(new=T)
plot(cumsum(pl), type='h', col='pink', lwd=2, ylim=y_range)
points(which(dd == 0), cummax( cumsum(pl) )[which(dd == 0)], pch=4, col='red')


# A minimalistic Echo State Networks demo with Mackey-Glass (delay 17) data
# in "plain" R.
# by Mantas Lukosevicius 2012-2018
# http://mantas.info

# load the data
trainLen = 2000
testLen = 2000
initLen = 100
data = as.matrix(read.table('MackeyGlass_t17.txt'))

# plot some of it
while( dev.cur() != 1 ) dev.off() # close all previous plots
dev.new()
plot(data[1:1000],type='l')
title(main='A sample of data')

# generate the ESN reservoir
inSize = outSize = 1
resSize = 1000
a = 0.3 # leaking rate

set.seed(42)
Win = matrix(runif(resSize*(1+inSize),-0.5,0.5),resSize)
W = matrix(runif(resSize*resSize,-0.5,0.5),resSize)

# normalizing and setting spectral radius
cat('Computing spectral radius...')
rhoW = abs(eigen(W,only.values=TRUE)$values[1])
print('done.')
W = W * 1.25 / rhoW

# allocated memory for the design (collected states) matrix
X = matrix(0,1+inSize+resSize,trainLen-initLen)
# set the corresponding target matrix directly
Yt = matrix(data[(initLen+2):(trainLen+1)],1)

# run the reservoir with the data and collect X
x = rep(0,resSize)
for (t in 1:trainLen){
    u = data[t]
    x = (1-a)*x + a*tanh( Win %*% rbind(1,u) + W %*% x )
    if (t > initLen)
        X[,t-initLen] = rbind(1,u,x)
}

# train the output
reg = 1e-8  # regularization coefficient
X_T = t(X)
Wout = Yt %*% X_T %*% solve( X %*% X_T + reg*diag(1+inSize+resSize) )

# run the trained ESN in a generative mode. no need to initialize here,
# because x is initialized with training data and we continue from there.
Y = matrix(0,outSize,testLen)
u = data[trainLen+1]
for (t in 1:testLen){
    x = (1-a)*x + a*tanh( Win %*% rbind(1,u) + W %*% x )
    y = Wout %*% rbind(1,u,x)
    Y[,t] = y
    # generative mode:
    u = y
    # this would be a predictive mode:
    #u = data[trainLen+t+1]
}

# compute MSE for the first errorLen time steps
errorLen = 500
mse = ( sum( (data[(trainLen+2):(trainLen+errorLen+1)] - Y[1,1:errorLen])^2 )
	/ errorLen )
print( paste( 'MSE = ', mse ) )

# plot some signals
dev.new()
plot( data[(trainLen+1):(trainLen+testLen+1)], type='l', col='green' )
lines( c(Y), col='blue' )
title(main=expression(paste('Target and generated signals ', bold(y)(italic(n)),
	' starting at ', italic(n)==0 )))
legend('bottomleft',legend=c('Target signal', 'Free-running predicted signal'),
	col=c('green','blue'), lty=1, bty='n' )

dev.new()
matplot( t(X[(1:20),(1:200)]), type='l' )
title(main=expression(paste('Some reservoir activations ', bold(x)(italic(n)))))

dev.new()
barplot( Wout )
title(main=expression(paste('Output weights ', bold(W)^{out})))


#' @export
#' @title createTS
#' @description creates a random time series of data of length N, not perfect but works
#' @param \code{N} = the number of values desired (Defaults to 100)
#' @param \code{seed} (Defaults to \code{null})
#' @param \code{nonstationary} (Defaults to T)
#' @param \code{all.positive} = if you want all values positive set all.positive=T to rescale (Defaults to T)
#' @return \code{x}
#' @author unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @family random data
#' @examples
#' createTS(8,nonstationary=T,all.positive=F)
#' [1]  0.0000000  0.6036440  0.8781622  0.8489549  1.3040091  0.5772213  0.2788312 -0.2574978 -0.6370382
#' @references \url{http://stats.stackexchange.com/questions/29239/creating-auto-correlated-random-values-in-r}
#' @export
createTS <- function(N=100,seed=NULL, nonstationary=T,all.positive=T) {
if(!is.null(seed)) set.seed(seed)
		if(nonstationary) {
			#brownian motion
				x = diffinv(rnorm(N))
			}
		if(!nonstationary) {
				x = filter(rnorm(N), filter=rep(1,3), circular=TRUE)
			}
		if(all.positive & min(x)<0) {
			x = x-min(x)+abs(min(x)*0.25)
			}
	return(x)
}


##########################################################################################################
#
#  Exercise 2 - Fit and Evaluate Models in R tutorial
#  Author: Ryan McWay
#  Appendix 1 - Leave-one-out cross validation
#
##########################################################################################################

## SECTION 1:  Input Data - Edit these

setwd("local")
lidarData <- read.csv("BA_lidarData.csv")
respVar = 'BAtotal'
modelFormula = lm(BAtotal~P70*all_1st_cover_mean, data = lidarData)
##########################################################################################################

## SECTION 2: Leave-one-out cross-validation

## specify the data for the cross validation
dataFrame = lidarData
## pull the observed values for the specified response variable
observedRV = dataFrame[,which(colnames(dataFrame)==respVar)]

#Create empty vectors to hold the calculated residuals and another to for the predictions
respVar.cv.resid=numeric(length=nrow(dataFrame))
respVar.cv.fitted=numeric(length=nrow(dataFrame))

#Attach the dataset names - Simplifies the lm formula
attach(dataFrame)

#Loop through each row in the dataset, drop one observation, refit the model, predict, calculate error, save
for (i in 1:nrow(dataFrame)) {
  #Refit the linear model with all the observations except one (left out for validation)
  crossMod=lm(modelFormula, data = dataFrame[-i,])
  #crossMod=randomForest(modelFormula, data = dataFrame[-i,])
  #crossMod=glm(modelFormula, data = dataFrame[-i,], family=Gamma())

  #Predict the left out value
  #respVar.pred=predict(crossMod, dataFrame[i,])
  respVar.pred=predict(crossMod, dataFrame[i,],type="response")

  #Save the prediction to the new vector
  respVar.cv.fitted[i]=respVar.pred
  #Calculate the difference between the predicted and actual (error)
  observed = observedRV[i]
  respVar.cv.resid[i]=observed-respVar.pred
}

detach(dataFrame)

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

## SECTION 3: Get the cross-validated error estimate - R-squared and RMSE

##################### Optional - Define a function to calculate Root Mean Square Error (RMSE) ###########
rmse = function(sim, obs){
  sqrt( mean( (sim - obs)^2, na.rm = TRUE) )
}
#########################################################################################################

## Get the cross-validate r-square
cv_rsq <- cor(observedRV,respVar.cv.fitted)**2

##Optional - remove comments below to get the r-square from the model for comparison
#raw_rsq <-cor(observedRV,Lm1$fitted)**2

## Optional- Calculate the rmse between the observed and cv predicted
rmseCV = rmse(respVar.cv.fitted, observedRV)

## SECTION 4: Plot the cross-validation results
## Round R-square value for better display
cv_rsq=round(cv_rsq, digits=3)
rmseCV=round(rmseCV, digits=2)

## Make a plot with the cv results
plot(dataFrame[,which(colnames(dataFrame)==respVar)] ~ respVar.cv.fitted,
     ylim=c(0,max(observedRV)),
     xlim=c(0,max(observedRV)),main="Cross Validation Results" ,
     xlab="Predicted by leave-one-out cross validation", ylab="Total BA observed (Kg/ha)")
## Add a 1:1 line for reference
abline(0,1,col="darkred",lwd=2)

## Optional - Add the R-Squared value to the plot
text(max(observedRV)-30, 20, substitute(paste(italic(R-Squared), " = ", x, sep=""), list(x=cv_rsq)))
## Optional - Add the rmse value to the plot
text(max(observedRV)-30, 10, substitute(paste(italic(RMSE), " = ", x, sep=""), list(x=rmseCV)))


#' LibstableR: Fast and accurate evaluation, random number generation
#' and parameter estimation of skew stable distributions.
#'
#' LibstableR provides functions to work with skew stable distributions
#' in a fast and accurate way \[1]. It performs:
#'
#' * Fast and accurate evaluation of the probability density function (PDF) and cumulative density function (CDF).
#' * Fast and accurate evaluation of the quantile function (CDF^{-1}).
#' * Random numbers generation \[2].
#' * Skew stable parameter estimation with:
#'     * McCulloch's method of quantiles \[3].
#'     * Koutrouvellis' method based on the characteristic function \[4].
#'     * Maximum likelihood estimation.
#'     * Modified maximum likelihood estimation as described in \[1].
#' *The evaluation of the PDF and CDF is based on the formulas provided by John P Nolan in \[5].
#'
#' @md
#' @author Javier Royuela del Val, Federico Simmross Wattenberg and Carlos Alberola López;\cr\cr
#'         Maintainer: Javier Royuela del Val <jroyval@@lpi.tel.uva.es>
#' @references
#' * \[1] Royuela-del-Val J, Simmross-Wattenberg F, Alberola López C (2017). libstable: Fast, Parallel and High-Precision Computation of alpha-stable Distributions in R, C/C++ and MATLAB. Journal of Statistical Software, 78(1), 1-25. doi:10.18637/jss.v078.i01
#' * \[2] Chambers JM, Mallows CL, Stuck BW (1976). A Method for Simulating Stable Random Variables. Journal of the American Statistical Association, 71(354), 340-344. doi:10.1080/01621459.1976.10480344
#' * \[3] McCulloch JH (1986). Simple Consistent Estimators of Stable Distribution Parameters. Communications in Statistics - Simulation and Computation, 15(4), 1109-1136. doi:10.1080/03610918608812563
#' * \[4] Koutrouvelis IA (1981). An Iterative Procedure for the Estimation of the Parameters of Stable Laws. Communications in Statistics - Simulation and Computation, 10(1), 17-28. doi:10.1080/03610918108812189
#' * \[5] Nolan JP (1997). Numerical Calculation of Stable Densities and Distribution Functions. Stochastic Models, 13(4), 759-774. doi:10.1080/15326349708807450
#' @name libstableR
#' @docType package
#' @keywords package
#' @useDynLib libstableR, .registration=TRUE
#' @importFrom Rcpp sourceCpp evalCpp
#' @examples
#' # Set alpha, beta, sigma and mu stable parameters in a vector
#' pars <- c(1.5, 0.9, 1, 0)
#'
#' # Generate an abscissas axis and probabilities vector
#' x <- seq(-5, 10, 0.05)
#' p <- seq(0.01, 0.99, 0.01)
#'
#' # Calculate pdf, cdf and quantiles
#' pdf <- stable_pdf(x, pars)
#' cdf <- stable_cdf(x, pars)
#' xq  <- stable_q(p, pars)
#'
#' # Generate 300 random values
#' rnd <- stable_rnd(300, pars)
#'
#' # Estimate the parameters of the skew stable distribution given
#' # the generated sample:
#'
#' # Using the McCulloch's estimator:
#' pars_est_M <- stable_fit_init(rnd)
#'
#' # Using the Koutrouvelis' estimator:
#' pars_est_K <- stable_fit_koutrouvelis(rnd, pars_est_M)
#'
#' # Using maximum likelihood estimator, with McCulloch estimation
#' # as a starting point:
#' # pars_est_ML <- stable_fit_mle(rnd, pars_est_M)
#'
#' # Using modified maximum likelihood estimator (See [1]):
#' # pars_est_ML2 <- stable_fit_mle2d(rnd, pars_est_M)
NULL


# library(rgl)

euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

w1 <- function(k, dist) {
  return (1 ^ k)
}

kwNN <- function(dataset, points, k, dist = euclidean, weight = w1) {
  answer <- array(dim = c(length(points[,1])))
  classes = unique(dataset$class)

  for (i in 1:length(points[,1])) {
    distance <- array(dim = c(length(dataset[,1])))
    for (j in 1:length(dataset[,1])) {
      distance[j] = dist(points[i, ], dataset[j, 1:2])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    scores <- rep(x = 0, times = length(classes))
    names(scores) = classes
    for (j in 1:k) {
      scores[sortedDataset$class[j]] = scores[sortedDataset$class[j]] + weight(j, distance[j])
    }

    answer[i] = names(which.max(scores))[1]
  }

  return (answer)
}

kwNN_point <- function(dataset, point, k, dist = euclidean, weight = w1) {
  distances <- array(dim = c(length(dataset[,1])))
  for (i in 1:length(distances)) {
    distances[i] <- dist(point[,3:4], dataset[i,3:4])
  }

  sortedDataset <- dataset[order(distances),]
  distances <- sort(distances)
  scores <- array(0L, length(unique(dataset$Species)))
  names(scores) = unique(dataset$Species)
  for (i in 1:k) {
    scores[sortedDataset$Species[i]] = scores[sortedDataset$Species[i]] + weight(i, distances[i])
  }

  return (names(which.max(scores)))
}

kwnn_loo <- function(k, dset) {

  classes = unique(dset$class)
  qs <- seq(from = 0.0, to = 1.0, by = 0.05)
  result <- array(0L, dim = c(length(qs)))
  for (i in 1:length(dset[,1])) {
    cat("\rProcessing sample", i, "of", length(dset[,1]))
    dataset <- dset[-i,]
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:2], dset[i, 1:2])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    classesCount <- array(0L, dim = c(length(classes)))
    dimnames(classesCount) = list(classes)

    classesCount <- array(0L, dim = c(length(classes), length(qs)))
    dimnames(classesCount) = list(classes)
    for (j in 1:k) { # k's
      index <- 1
      for (q in qs) {
        classesCount[sortedDataset$class[j],index] <- classesCount[sortedDataset$class[j],index] + (q ^ j)
        classForCurrentK = names(which.max(classesCount[,index]))[1]

        index <- index + 1
      }
    }
    for (j in 1:length(qs)) {
      ans = names(which.max(classesCount[,j]))[1]

      if (ans == paste(dset$class[i])) {
        result[j] <- result[j] + 1
      }
    }
  }
  cat("\n")

  for (i in 1:length(result)) {
    result[i] <- result[i] / length(dset[,1])
  }

  return (result)
}

df = data.frame(x = double(), y = double(), class = character())

df <- rbind(df, data.frame(x = 122, y = 2208, class = "class-1"))
df <- rbind(df, data.frame(x = 148, y = 1136, class = "class-2"))
df <- rbind(df, data.frame(x = 270, y = 2186, class = "class-1"))
df <- rbind(df, data.frame(x = 271, y = 2016, class = "class-1"))
df <- rbind(df, data.frame(x = 306, y = 1023, class = "class-2"))
df <- rbind(df, data.frame(x = 413, y = 1153, class = "class-2"))
df <- rbind(df, data.frame(x = 503, y = 2013, class = "class-1"))
df <- rbind(df, data.frame(x = 541, y = 971, class = "class-2"))
df <- rbind(df, data.frame(x = 706, y = 1018, class = "class-2"))
df <- rbind(df, data.frame(x = 837, y = 867, class = "class-2"))
df <- rbind(df, data.frame(x = 875, y = 1011, class = "class-2"))
df <- rbind(df, data.frame(x = 927, y = 1915, class = "class-1"))
df <- rbind(df, data.frame(x = 997, y = 897, class = "class-2"))
df <- rbind(df, data.frame(x = 1005, y = 529, class = "class-2"))
df <- rbind(df, data.frame(x = 1028, y = 1176, class = "class-2"))
df <- rbind(df, data.frame(x = 1050, y = 1429, class = "class-1"))
df <- rbind(df, data.frame(x = 1125, y = 781, class = "class-2"))
df <- rbind(df, data.frame(x = 1144, y = 1061, class = "class-2"))
df <- rbind(df, data.frame(x = 1146, y = 1751, class = "class-1"))
df <- rbind(df, data.frame(x = 1192, y = 1601, class = "class-1"))
df <- rbind(df, data.frame(x = 1264, y = 888, class = "class-2"))
df <- rbind(df, data.frame(x = 1275, y = 1412, class = "class-1"))
df <- rbind(df, data.frame(x = 1329, y = 576, class = "class-2"))
df <- rbind(df, data.frame(x = 1366, y = 1586, class = "class-1"))
df <- rbind(df, data.frame(x = 1405, y = 386, class = "class-2"))
df <- rbind(df, data.frame(x = 1432, y = 1226, class = "class-1"))
df <- rbind(df, data.frame(x = 1597, y = 279, class = "class-2"))
df <- rbind(df, data.frame(x = 1615, y = 1604, class = "class-1"))
df <- rbind(df, data.frame(x = 1631, y = 1200, class = "class-1"))
df <- rbind(df, data.frame(x = 1638, y = 1365, class = "class-1"))
df <- rbind(df, data.frame(x = 1765, y = 1262, class = "class-1"))
df <- rbind(df, data.frame(x = 1806, y = 1444, class = "class-1"))
df <- rbind(df, data.frame(x = 1821, y = 1056, class = "class-1"))
df <- rbind(df, data.frame(x = 1896, y = 877, class = "class-1"))
df <- rbind(df, data.frame(x = 1993, y = 695, class = "class-1"))
df <- rbind(df, data.frame(x = 2027, y = 1415, class = "class-1"))
df <- rbind(df, data.frame(x = 2087, y = 889, class = "class-1"))
df <- rbind(df, data.frame(x = 2189, y = 674, class = "class-1"))

z = array(c(c(1164, 1232)), dim = c(1,2))

# m <- fast_cvloo_kwnn()
k <- 6

qs <- (seq(from = 0.0, to = 1.0, by = 0.05))
acc = kwnn_loo(6, df)

par(mfrow=c(1,2), pty="s")

print(qs[which.max(acc)])

plot(qs, acc, type = "l", xlab = "q", ylab="Accuracy")
points(qs[which.max(acc)], max(acc), pch = 19, col = "red")

bestQ <- qs[which.max(acc)]

cat("Best accuracy:", max(acc), "for q =", qs[which.max(acc)])

colors <- c("class-1" = "blue", "class-2" = "red")
plot(df[, 1:2], bg = colors[paste(df$class)], pch=23, asp=1)

result <- kwNN(df, z, 5, euclidean, function(k, dist) { return(bestQ ^ k) })
points(z[,1], z[,2], bg = colors[result], pch = 22)

1 - Nearest neighbors algorithm/kwnn-loocv-img-exp.r


library(nloptr)
library(rlist)

get_expected_I = function(N0, C0, beta, gamma, lambda) {
  "
  Calculates expected new case counts for each step in the time series.

  Parameters
  ----------
  N0 : numeric
    Initial number of contagious patients.
  C0 : numeric
    Initial number of infected but non-contagious patients.
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  gamma : numeric
    Probability that an infected, non-contagious patient will turn infectious in
    the next time step.
  lambda : numeric
    (1 / mean) number of days an individual will continue to be infectious.

  Returns
  -------
  expected_I : numeric vector
    Daily expected number of new cases.
  "
  steps = length(beta)
  expected_I = rep(0, steps)
  expected_N = rep(0, steps)
  expected_C = rep(0, steps)
  N_previous = N0
  C_previous = C0
  for(t in 1:steps) {
    expected_I[t] = gamma * C_previous
    expected_N[t] = N_previous * pexp(1, rate=lambda, lower.tail=FALSE) + expected_I[t]
    expected_C[t] = (1 - gamma) * C_previous + beta[t] * N_previous
    N_previous = expected_N[t]
    C_previous = expected_C[t]
  }
  return(expected_I)
}

fit = function(observed_I, beta0, beta_min, beta_max, gamma0, gamma_min,
               gamma_max, lambda0, lambda_min, lambda_max, N00, N0_min, N0_max,
               C00, C0_min, C0_max, alpha, ignore_beta_diff) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, gamma0, lambda0, N00, C00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), gamma_min, lambda_min, N0_min, C0_min)
  ub = c(rep(beta_max, steps), gamma_max, lambda_max, N0_max, C0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7,
              "maxeval" = 10000000)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    gamma = x[steps + 1]
    lambda = x[steps + 2]
    N0 = x[steps + 3]
    C0 = x[steps + 4]
    # calculate loss
    expected_I = get_expected_I(N0, C0, beta, gamma, lambda)
    beta_diff = diff(beta)
    beta_diff = beta_diff[!1:length(beta_diff) %in% ignore_beta_diff]
    loss = mean((expected_I - observed_I) ^ 4) + alpha * mean(beta_diff ^ 2)
  }
  result = nloptr(x0=x0, eval_f=loss, eval_grad_f=NULL, lb=lb, ub=ub, opts=opts)
  model = list()
  model$beta = result$solution[1:steps]
  model$gamma = result$solution[steps + 1]
  model$lambda = result$solution[steps + 2]
  model$N0 = result$solution[steps + 3]
  model$C0 = result$solution[steps + 4]
  model$loss = result$objective
  return(model)
}


isLeapYear <- function(year) {
    ifelse(year%%100==0, year%%400==0, year%%4==0)
}

for (y in c(1900, 1994, 1996, 1997, 2000)) {
  cat(y, ifelse(isLeapYear(y), "is", "isn't"), "a leap year.\n")
}


#' Path costs based on BPR link cost function
#'
#' This function calculates the path costs as a function of link flows over network. BPR link cost functions are assumed.
#' @param x Traffic flow on all links of network
#' @param A link-path incidence matrix
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @return Vector of path costs
#' @keywords path route cost
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' Alpha <- rep(10,7)
#' Beta <- rep(2,7)
#' pow <- rep(4,7)
#' path_flow <- c(10,20,15,15)
#' x <- A%*%path_flow
#' PathCost(x,A,Alpha,Beta)
#' @export

PathCost <- function(x,A=diag(length(x)),Alpha,Beta,pow=4){
 	c(t(A)%*%LinkCost(A%*%x,Alpha,Beta,pow=pow))
}


library(shiny)
library(matrixcalc)
library(plotly)

gaussPdf <- function (x, mu, E) {
  k <- length(x)
  ans <- exp(-0.5 * t(x - mu) %*% solve(E) %*% (x - mu)) /
    sqrt((2 * pi) ^ k * det(E))
  return (ans)
}

function(input, output, session, ...) {
  output$err <- function() {
    E <- matrix(c(input$E1, input$E3, input$E2, input$E4), nrow = 2)
    if (!matrixcalc::is.positive.definite(E)) {
      return("Error: covariance matrix has to be positive definite.")
    }
    return("")
  }

  output$p <- renderPlotly({
    mu = c(input$mu1, input$mu2)
    E <- matrix(c(input$E1, input$E3, input$E2, input$E4), nrow = 2)

    if (!matrixcalc::is.positive.definite(E)) {
      plot_ly()
      return()
    }

    xs <- seq(from = mu[1] - 5, to = mu[1] + 5, by = 0.1)
    ys <- seq(from = mu[2] - 5, to = mu[2] + 5, by = 0.1)
    z <- c()

    for (y in ys) {
      curr <- c()
      for (x in xs) {
        arg <- c(x, y)
        value <- gaussPdf(arg, mu, E)

        curr <- c(curr, value)
      }
      z <- rbind(z, curr)
    }

    fig <- plot_ly(
      type = 'surface',
      x = ~xs,
      y = ~ys,
      z = ~z) %>% add_surface(
        contours = list(
          z = list(
            show=TRUE,
            usecolormap=TRUE,
            highlightcolor="#ff0000",
            project=list(z=TRUE)
          )
        )
      )
    fig
  })
}

5 - Contour lines of the Gaussian distribution PDF/shiny/server.r


    require(quantreg)
    data("engel")
    require(dplyr)
    engel$grp <- trunc(runif(nrow(engel), min=0, max=3))

    group_by(engel,grp) %>% do(summary(rq(foodexp~income,data=.,tau=c(.05, .25, .5, .75, .95)),se="boot"))

    rqm <- group_by(engel,grp) %>% do(mdl=rq(foodexp~income,data=.,tau=c(.05, .25, .5, .75, .95)))
    summarise(rqm, coef(summary(mdl,se="boot")))

    f <-group_by(engel,grp) %>% do(as.data.frame(lapply(summary(rq(foodexp~income,data=.,tau=c(.05, .25, .5, .75, .95)),se="boot"), coef)))

    f <-group_by(engel,grp) %>%
      do(as.data.frame(do.call(rbind,
                               lapply(summary(rq(foodexp~income,data=.,tau=c(.05, .25, .5, .75, .95)), se="boot"), coef)
      ), row.names = NULL))


suppressPackageStartupMessages(library(float))
set.seed(1234)

sd = stats::sd

### uniform
s = flrunif(500)
x = dbl(s)
stopifnot(min(x) >= 0)
stopifnot(max(x) <= 1)

s = flrunif(500, min=50, max=60)
x = dbl(s)
stopifnot(min(x) >= 50)
stopifnot(max(x) <= 60)

m = 10L
n = 5L
s = flrunif(m, n)
stopifnot(identical(dim(s), c(m, n)))

### normal
s = flrnorm(5000)
x = dbl(s)
stopifnot(abs(mean(x)-0) < 1e-1)
stopifnot(abs(sd(x)-1) < 1e-1)

s = flrnorm(5000, mean=10, sd=5)
x = dbl(s)
stopifnot(abs(mean(x)-10) < 1e-1)
stopifnot(abs(sd(x)-5) < 1e-1)

m = 5L
n = 10L
s = flrnorm(m, n)
stopifnot(identical(dim(s), c(m, n)))


baseball <- read.csv("baseball.csv")
str(baseball)

moneyball <- subset(baseball, Year < 2002)
str(moneyball)

moneyball$RD <- moneyball$RS - moneyball$RA
str(moneyball)

plot(moneyball$RD, moneyball$W)
WinsReg <- lm(W ~ RD, data = moneyball)
summary(WinsReg)

# W = 80.88 + 0.105*(RD)
# 80.88 + 0.1058(RD) >= 95, hence RD >= 135 =)

# Quiz


=begin
  # sample-groebner03.rb

  require "algebra"
  F5 = ResidueClassRing(Integer, 2)
  F = AlgebraicExtensionField(F5, "a") {|a| a**3 + a + 1}
  a = F.var
  P = MPolynomial(F)

  x, y, z = P.vars("xyz")
  f1 = x + y**2 + z**2 - 1
  f2 = x**2 + z**2 - y * a
  f3 = x - z - a

  f = x**3 + y**3 + z**3
  q, r = f.divmod_s(f1, f2, f3)
  p f == q.inner_product([f1, f2, f3]) + r #=> true
((<_|CONTENTS>))
=end


library(npowerPrioR)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

source("data_Gaussian.r")

#### Sampling from the "prior"
prior <- stan_model("stan/simple_Gaussian_prior.stan")

gs.data <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = 1
)

####################
J <- 20
maxA <- 10
epsilon <- 0.05

#
uniform.a0s <- seq(epsilon, maxA, length.out = J)
uniform.time <- system.time(
  uniform.ca0.estimates <- create_lc_df(a0_grid = uniform.a0s, compiled.model.prior = prior,
                                        stan.list = gs.data, pars = c("mu", "sigma"))
)

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10, stan.list = gs.data, pars = c("mu", "sigma"))
)

adaptive.derivOnly.time <- system.time(
  adaptive.ca0.estimates.derivOnly <- build_grid_derivOnly(compiled.model.prior = prior, eps = epsilon,
                                                           M = maxA, J = J, v1 = 10, v2 = 10,
                                                           stan.list = gs.data, pars = c("mu", "sigma"))
)
## Exporting
write.csv(uniform.ca0.estimates$result, row.names = FALSE,
          file =  paste("../data/constant_data/Gaussian_logCA0_uniform", "_J=", J, ".csv", sep = ""))
write.csv(adaptive.ca0.estimates$result, row.names = FALSE,
          file = paste("../data/constant_data/Gaussian_logCA0_adaptive", "_J=", J, ".csv", sep = ""))
write.csv(adaptive.ca0.estimates.derivOnly$result, row.names = FALSE,
          file = paste("../data/constant_data/Gaussian_logCA0_adaptive_derivOnly", "_J=", J, ".csv", sep = ""))

## Exporting sensitivity stuff

summaries.uniform <- uniform.ca0.estimates$summaries
for (i in 1:length(summaries.uniform)){
  summaries.uniform[[i]] <- data.frame(summaries.uniform[[i]], a_0 = uniform.ca0.estimates$result$a0[i])
}
summaries.uniform.dt <- do.call(rbind, summaries.uniform)

summaries.adaptive <- adaptive.ca0.estimates$summaries
for (j in 1:length(summaries.adaptive)){
  summaries.adaptive[[j]] <- data.frame(summaries.adaptive[[j]], a_0 = adaptive.ca0.estimates$result$a0[j])
}
summaries.adaptive.dt <- do.call(rbind, summaries.adaptive)

write.csv(summaries.uniform.dt,
          file = paste("../data/sensitivity_data/priorSensitivity_simpleGaussian_uniform_J=", J, ".csv", sep = ""))

write.csv(summaries.adaptive.dt,
          file = paste("../data/sensitivity_data/priorSensitivity_simpleGaussian_adaptive_J=", J, ".csv", sep = ""))


#############
# ARS for the sampling of alpha in GMM and IGMM
############
library(ars)

# function
f_y <- function(y, K=3, U=10){
  y*(K-3/2) - 1/(2*exp(y)) + lgamma(exp(y)) - lgamma(exp(y)+U)
}

# first derivative function
f_y_prima <- function(y, K=3, U=10){
  (K-3/2) + 1/(2*exp(y)) + exp(y)*digamma(exp(y)) - exp(y)*digamma(exp(y)+U)
}

# Wrapper for ARS function
sample_alpha <- function(K=3, U=10){
  y <- ars2(1, f_y, f_y_prima, x=c(-2,0,30), K=K, U=U)
  exp(y)
}

###############################################################################
# Hack ARS function so that it returns the ifault codes and not just print them
# so that we can handle it like an exception
###############################################################################

ars2 <- function (n = 1, f, fprima, x = c(-4, 1, 4), ns = 100, m = 3,
                  emax = 64, lb = FALSE, ub = FALSE, xlb = 0, xub = 0, ...)
{
  mysample <- rep(0, n)
  iwv <- rep(0, ns + 7)
  rwv <- rep(0, 6 * (ns + 1) + 9)
  hx <- f(x, ...)
  hpx <- fprima(x, ...)
  initial <- .C("initial_", as.integer(ns), as.integer(m),
                as.double(emax), as.double(x), as.double(hx), as.double(hpx),
                as.integer(lb), as.double(xlb), as.integer(ub), as.double(xub),
                ifault = as.integer(0), iwv = as.integer(iwv), rwv = as.double(rwv))
  if (initial$ifault == 0) {
    h <- function(x) f(x, ...)
    hprima <- function(x) fprima(x, ...)
    for (i in 1:n) {
      sample <- .C("sample_", as.integer(initial$iwv),
                   as.double(initial$rwv), h, hprima, new.env(),
                   beta = as.double(0), ifault = as.integer(0))
      if (sample$ifault == 0) {
        if (i < ns) {
          x <- c(x, sample$beta)
          h <- function(x) f(x, ...)
          hprima <- function(x) fprima(x, ...)
        }
        mysample[i] <- sample$beta
      }
      else {
        cat("\nError in sobroutine sample_...")
        cat("\nifault=", sample$ifault, "\n")
        stop(paste("\nError in sobroutine sample_...", sample$ifault))
      }
    }
  }
  else {
    cat("\nError in sobroutine initial_...")
    cat("\nifault=", initial$ifault, "\n")
    stop(paste("\nError in sobroutine initial_...", initial$ifault))
  }
  return(mysample)
}

environment(ars2) <- environment(ars)