#' Function to rescale a polygon such that it keeps the "original" aspec ratio.
#' @param coordinates A two-column matrix or data frame with coordinates (xy).
#' @param yorigin Reference point in the y-axis.
#' @param adj Rescale factor (scalar). By default the adjustment is computed
#' using `graphics::par()` `usr` and `pin`.
#' @export
rescale_polygon <- function(
  coordinates,
  yorigin = mean(coordinates[,2]),
  adj = NULL
) {

  # Adjustment value
  if (!length(adj)) {
    usr_adj <- with(graphics::par(), (usr[2] - usr[1])/(usr[4] - usr[3]))
    dev_adj <- with(graphics::par(), pin[2]/pin[1])
    adj <- 1/dev_adj/usr_adj
  }

  # If it is multiple polygons (adj is passed by scoping)
  if (!is.data.frame(coordinates) && is.list(coordinates))
    return(mapply(rescale_polygon, coordinates=coordinates, yorigin=yorigin,
                  SIMPLIFY = FALSE))

  # Adjusting
  if ((is.matrix(coordinates) | is.data.frame(coordinates)) && ncol(coordinates) > 1)
    coordinates[,2] <- yorigin + (coordinates[,2] - yorigin)*adj
  else
    return(yorigin + (coordinates - yorigin)*adj)

  coordinates
}

pieslice <- function(a0, a1, r, d, x0, y0, edges, off) {

  # Intermideate points
  mid <- seq(a0, a1, by = 2*pi/edges*sign(a1 - a0))

  # In case that the points are not sufficient
  if (length(mid) < 3)
    mid <- seq(a0, a1, length.out = 3)
  if (utils::tail(mid, 1) != a1)
    mid <- seq(a0, a1, length.out = length(mid))

  # Computing midpoints
  mid <- cbind(cos(mid), sin(mid))
  m <- nrow(mid)

  if (d != 0) {
    pbase <- (mid*d)[m:1,]
  } else pbase <- c(0,0)

  ans <- rbind.data.frame(
    mid*r,
    pbase,
    make.row.names=FALSE
  )

  # Translating to the origin
  ans[,1] <- x0 + ans[,1]
  ans[,2] <- y0 + ans[,2]

  # Setting off
  ans[,1] <- ans[,1] + cos((a1 + a0)/2)*off
  ans[,2] <- ans[,2] + sin((a1 + a0)/2)*off

  colnames(ans) <- c("x", "y")
  ans

}

#' Computes the coordinates to plot a circle
#'
#' It actually does it by creating a polygon with 100 edges.
#' @param x0,y0 Numeric scalars. Center of the circle
#' @param r Numeric scalar. Radius of the circle.
#' @param rescale Logical scalar. When [TRUE], rescales the polygon
#' coordinates such that it preservers its aspect ratio once plotted.
#'
#' @export
circle <- function(x0, y0, r, rescale=TRUE) {
  ans <-  pieslice(0, 2*pi, r=r, d=0, x0, y0, edges=100, off=0)
  ans <- ans[-nrow(ans), ]

  if (rescale)
    ans <- rescale_polygon(ans, y0)

  ans
}

#' A flexible piechart.
#'
#' While similar to [graphics::pie()], this function is much more
#' flexible as it allows providing different parameters for each slice of the pie.
#' Furthermore, it allows adding the plot to the current device, making it possible
#' to create compound piecharts.
#'
#' @param x Numeric vector. Values that specify the area of the slices.
#' @param add Logical scalar. When `TRUE` it is added to the current device.
#' @param radius Numeric vector. Radious of each slice (can be a scalar).
#' @param doughnut Numeric scalar. Radious of each inner circle (doughnut) (can be a scalar).
#' @param origin Numeric vector of length 2. Coordinates of the origin.
#' @param edges Numeric scalar. Smoothness of the slices curve (can be a vector).
#' @param slice.off Numeric vector. When `!=0`, specifies how much to
#' move the slice away from the origin. When scalar is recycled.
#' @param labels Character vector of length `length(x)`. Passed to
#' [graphics::text()].
#' @param tick.len Numeric scalar. Size of the tick marks as proportion of the radius.
#' @param text.args List. Further arguments passed to [graphics::text()].
#' @param segments.args List. Further arguments passed to [graphics::segments()]
#' when drawing the tickmarks.
#' @param init.angle Numeric scalar. Angle from where to start drawing in degrees.
#' @param last.angle Numeric scalar. Angle where to finish drawing in degrees.
#' @param skip.plot.slices Logical scalar. When `FALSE`, slices are not drawn.
#' This can be useful if, for example, the user only wants to draw the labels.
#' @param rescale Logical scalar. When `TRUE` (default), the y-coordinates of
#' the polygons (slices), text and tickmarks will be rescaled such that the
#' aspect ratio is preserved, i.e. looks like a circle.
#' @param ... Further arguments passed to [graphics::polygon()]
#' (see details).
#'
#' @return
#' A list with the following elements:
#' \item{slices}{A list of length `length(x)` with the coordinates of each
#'   slice.}
#' \item{textcoords}{A numeric matrix of size `length(x)*2` with
#'   coordinates where the labels can be put at.}
#' \item{alpha0}{A numeric vector of size `length(x)` with the starting
#' degree in radians of the slice.}
#' \item{alpha1}{A numeric vector of size `length(x)` with the ending
#' degree in radians of the slice.}
#'
#' @details The function is a wrapper of [graphics::polygon()],
#' so all parameters such as color, density, border, etc. are passed directly
#' by [mapply()] so that are specified one per slice. The coordinates
#' of the slices are computed internally.
#'
#'
#' @seealso https://commons.wikimedia.org/wiki/File:Nightingale-mortality.jpg
#' @export
#' @examples
#'
#' # Example 1 -----------------------------------------------------------------
#' # A set of 3 nested rings rings starting at 315 deg. and ending at 270 deg.
#'
#' # Values to plot
#' vals <- c(1,2,3,10)
#'
#' # Outer (includes labels)
#' piechart(vals, col=grDevices::blues9[5:8], border=NA, doughnut = .5,
#'     radius=.75, labels=vals, init.angle = 315, last.angle = 270)
#'
#' # Middle
#' piechart(vals, col=grDevices::blues9[3:6], border=NA, doughnut = .3,
#'     radius=.5, add=TRUE, init.angle = 315, last.angle = 270)
#'
#' # Inner
#' piechart(vals, col=grDevices::blues9[1:4], border="gray", doughnut = .1,
#'     radius=.3, add=TRUE, init.angle = 315, last.angle = 270)
#'
#' # Example 2 -----------------------------------------------------------------
#' # Passing values to polygon and playing with the radius and slice.off
#'
#' piechart(1:10, density=(1:10)^2/2, slice.off = (1:10)/30, doughnut = .5,
#'   radius = sqrt(10:1),
#'   # Here we are setting random labels...
#'   labels=sapply(1:10, function(x) paste(sample(letters, x, TRUE), collapse=""))
#'   )
#'
piechart <- function(
  x,
  labels = names(x),
  radius = 1,
  doughnut = 0,
  origin = c(0,0),
  edges = 200,
  slice.off = 0,
  init.angle = 0,
  last.angle = 360,
  tick.len = .1,
  text.args = list(),
  segments.args = list(),
  skip.plot.slices=FALSE,
  add = FALSE,
  rescale = TRUE,
  ...) {

  # X must be numeric
  if (!is.numeric(x))
    stop("-x- must be numeric")
  x <- tryCatch(as.vector(x), error = function(e) e)
  if (inherits(x, "error"))
    stop("Coercion of -x- as vector failed:\n", x)

  # Assigning alpha
  init.angle <- init.angle/360*2.0*pi # as radians
  last.angle <- last.angle/360*2.0*pi

  alpha1 <- cumsum(x/sum(x)*ifelse(
    init.angle >= last.angle, 2*pi - init.angle + last.angle,
    last.angle - init.angle
  )) + init.angle
  alpha0 <- c(init.angle, alpha1[-length(x)])

  ans <- mapply(
    pieslice,
    a0 = alpha0,
    a1 = alpha1,
    r = radius, d=doughnut, x0=origin[1], y0=origin[2],
    edges = edges,
    off = slice.off,
    SIMPLIFY = FALSE
  )

  # Fetching size
  cex <- if (length(labels) && ("cex" %in% names(text.args)))
    text.args[["cex"]]
  else 1

  # Creating the device
  maxradius <- max(radius)
  if (!add) {
    graphics::plot.new()

    # Adjusting so that we get nice circles
    adj <- graphics::par()$pin
    adj <- adj[1]/adj[2]

    # Adjusting the size... including the labels
    ran <- if (length(labels))
      max(
        c(
          graphics::strwidth(labels, units="user", cex=cex),
          graphics::strheight(labels, units="user", cex=cex)
        ),
        na.rm=TRUE)*2
    else 0

    ran <- (ran + maxradius*1.1 + tick.len/2 + max(slice.off))*c(-1,1)

    # Adjustment depending on the asp
    if (adj > 1)
      graphics::plot.window(xlim=ran*adj, ylim = ran)
    else
      graphics::plot.window(xlim=ran, ylim = ran*adj)
  }

  # Adjusting the polygon
  if (rescale)
    ans <- rescale_polygon(ans, origin[2])

  # Adding the slices
  if (!skip.plot.slices)
    mapply(graphics::polygon,
           x = lapply(ans, "[", j=1, i=),
           y = lapply(ans, "[", j=2, i=),
           ..., SIMPLIFY = FALSE
    )

  # Midpoints
  angles     <- (alpha0 + alpha1)/2
  textcoords <- cbind(
    origin[1] + cos(angles)*(radius*1.05 + tick.len/2 + slice.off) ,
    origin[2] + sin(angles)*(radius*1.05 + tick.len/2 + slice.off)
  )

  # If labels are passed
  if (length(labels)) {

    # Adjusting according to string lenght
    textcoords <- textcoords +
      cbind(
        cos(angles)*graphics::strwidth(labels, cex=cex)/2,
        sin(angles)*graphics::strwidth(labels, cex=cex)/2
      )

    if (rescale)
      textcoords <- rescale_polygon(textcoords, origin[2])

    # Drawing the text
    do.call(mapply,
            c(list(FUN = graphics::text,
                   x=textcoords[,1],
                   y=textcoords[,2],
                   labels=labels,SIMPLIFY = FALSE),
              text.args
            ))

    # Here should go the tick marks...
    x0 <- origin[1] + cos(angles)*(radius - tick.len/2 + slice.off)
    x1 <- origin[1] + cos(angles)*(radius + tick.len/2 + slice.off)
    y0 <- origin[2] + sin(angles)*(radius - tick.len/2 + slice.off)
    y1 <- origin[2] + sin(angles)*(radius + tick.len/2 + slice.off)

    if (rescale) {
      y0 <- rescale_polygon(y0, origin[2])
      y1 <- rescale_polygon(y1, origin[2])
    }

    toplot <- which(!is.na(labels))
    do.call(graphics::segments,
            c(
              list(
                x0 = x0[toplot],
                y0 = y0[toplot],
                x1 = x1[toplot],
                y1 = y1[toplot]
              ),
              segments.args
            ))

  }

  # Returning
  invisible(
    list(
      slices     = ans,
      textcoords = textcoords,
      alpha0     = alpha0,
      alpha1     = alpha1
    )
  )

}

#' Function to create a color key
#'
#' @param x0,x1,y0,y1 Numeric scalars. Coordinates of the lower left and
#' upper right points where the color key will be drawn as proportion of
#' the plotting region.
#' @param label.from,label.to Character scalar. Labels of the lower and
#' upper values of the color key.
#' @param tick.range,tick.marks Numeric vectors specifying the range and
#' the tickmarks respectively.
#' @param cols Character scalar. Colors specifications to create the
#' color palette.
#' @param nlevels Integer scalar. Number of levels to extrapolate.
#' @param main Character scalar. Title of the colorkey.
#' @param relative Logical scalar. When `TRUE` the color key is drawn relative
#' to the plotting region area taking `x0, x1, y0, y1` as relative location.
#' @param tick.args,label.args,main.args Lists of arguments passed to
#' [graphics::text] for drawing ticks, labels and main respectively.
#' @export
colorkey <- function(
  x0,y0,x1,y1,
  cols       = c("white", "steelblue"),
  tick.range = c(0, 1),
  tick.marks = seq(tick.range[1], tick.range[2], length.out = 5L),
  label.from = NULL,
  label.to   = NULL,
  nlevels    = 100,
  main       = NULL,
  relative   = TRUE,
  tick.args  = list(),
  label.args = list(),
  main.args  = list()
) {

  # If relative (the default, will be added to )
  if (relative) {
    usr <- graphics::par("usr")
    xpd <- graphics::par("xpd")
    on.exit({
      graphics::plot.window(
        usr[1:2],
        usr[3:4],
        new=FALSE,
        xpd=xpd,
        xaxs="i",
        yaxs="i"
        )
    })
    graphics::plot.window(c(0,1), c(0,1), new=FALSE, xpd=NA)

  }

  # Adjusting to textsize
  x0 <- x0 + graphics::strwidth(label.from)
  x1 <- x1 - graphics::strwidth(label.to)
  y0 <- y0 + max(graphics::strheight(tick.marks))
  y1 <- y1 - graphics::strheight(main)

  # Writing labels
  do.call(
    graphics::text,
    c(list(
    x      = c(
      x0 - graphics::strwidth(label.from)/2,
      x1 + graphics::strwidth(label.to)/2
    ),
    y      = rep((y1+y0)/2, 2),
    labels = c(label.from, label.to)
    ), label.args)
  )

  # Readjusting for more space
  x0 <- x0 + (x1-x0)/40
  x1 <- x1 - (x1-x0)/40

  # Computing coordinates
  cols <- grDevices::colorRampPalette(cols)(nlevels)
  n  <- length(cols)
  xsize <- (x1 - x0)/n

  xcoords <- seq(x0 + xsize/2, x1 - xsize/2, length.out = n)
  ycoords <- rep((y1+y0)/2, n)

  # xcoords[1] <- xcoords[1] + xsize

  # Drawing rectangles
  graphics::symbols(
    x          = xcoords,
    y          = ycoords,
    inches     =FALSE,
    bg         = cols,
    fg         = "transparent",
    rectangles = cbind(rep(xsize, n), y1-y0),
    add        = TRUE
  )

  # Bouding box
  graphics::symbols(
    x = (x1 + x0)/2,
    y = (y1 + y0)/2,
    rectangles = cbind((x1 - x0), y1 - y0),
    add=TRUE, inches = FALSE
  )

  # Top tickmarks
  tick.pos <- (tick.marks - tick.range[1])/(tick.range[2] - tick.range[1])*(x1-x0) + x0
  graphics::segments(
    x0 = tick.pos,
    y0 = y0 - (y1 - y0)/5 ,
    x1 = tick.pos,
    y1 = y0 + (y1 - y0)/5
  )

  do.call(
    graphics::text,
    c(
      list(
    x = tick.pos,
    y = y0 - (y1 - y0)/5 - graphics::strheight(max(tick.marks, na.rm=TRUE))/1.5,
    labels = tick.marks
  ), tick.args))

  if (length(main))
    do.call(
      graphics::text,
      c(list(
      x = (x1 + x0)/2,
      y = y1,
      pos = 3,
      labels = main
      ), main.args)
    )

}


# Get data
digits.train <- read.table(url("http://www.amlbook.com/data/zip/features.train"))
digits.test <- read.table(url("http://www.amlbook.com/data/zip/features.test"))

colnames(digits.train) <- c("digit", "symmetry", "intensity")
colnames(digits.test) <- c("digit", "symmetry", "intensity")

digits.train$digit <- factor(digits.train$digit)
digits.test$digit <- factor(digits.test$digit)

# Visualize
ggplot(digits.train, aes(x = symmetry, y = intensity, color = digit)) +
  geom_point()

summary(digits.train)
summary(digits.train$digit)

q2_4 <- t(sapply(0:9, function(myDigit) {
  fit <- svm(digit == myDigit ~ ., data = digits.train,
             scale = FALSE,
             kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.01,
             type = "C-classification")

  # fit
  pred <- predict(fit, digits.train[-1])

  Ein = sum(pred != (digits.train$digit == myDigit))/nrow(digits.train)
  table(pred, (digits.train$digit == myDigit))
  cbind(myDigit, Ein, fit$tot.nSV)
}))

digits.train.sub <- subset(digits.train, digit == 1 | digit == 5)
digits.test.sub <- subset(digits.test, digit == 1 | digit == 5)

q5 <- t(sapply(c(0.0001, 0.001, 0.01, 0.1, 1), function(cst) {
  myDigit = 5
  fit <- svm(digit == myDigit ~ ., data = digits.train.sub,
             scale = FALSE,
             kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = cst,
             type = "C-classification")
  pred <- predict(fit, digits.train.sub[-1])

  Ein = sum(pred != (digits.train.sub$digit == myDigit))/nrow(digits.train.sub)

  pred <- predict(fit, digits.test.sub[-1])
  Eout = sum(pred != (digits.test.sub$digit == myDigit))/nrow(digits.test.sub)

  cbind(cst, Ein, Eout, fit$tot.nSV)
}))

# q6, run q5 with degree = 5

myDigit = 5
q7 <- tune(svm,digit == myDigit ~ ., data = digits.train.sub,
           scale = FALSE,      type = "C-classification",
           kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1,
           ranges = list(cost = c(.0001, .001, .01, .1, 1)),
           tunecontrol = tune.control(sampling = "cross", cross = 10, nrepeat = 100))

q7

# Another way
rslts <- lapply(1:100, function(x) {
  ordIdx <- sample(nrow(digits.train.sub))
  fit.0001 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
                  scale = FALSE, seed = x,
                  kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.0001,
                  type = "C-classification", cross = 10)

  fit.001 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
                 scale = FALSE, seed = x,
                 kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.001,
                 type = "C-classification", cross = 10)

  fit.01 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
                scale = FALSE, seed = x,
                kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.01,
                type = "C-classification", cross = 10)

  fit.1 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
               scale = FALSE, seed = x,
               kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.1,
               type = "C-classification", cross = 10)

  fit1 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
              scale = FALSE, seed = x,
              kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 1,
              type = "C-classification", cross = 10)

  1 - cbind(fit.0001$tot.accuracy, fit.001$tot.accuracy, fit.01$tot.accuracy, fit.1$tot.accuracy, fit1$tot.accuracy)/100
})

summary(sapply(rslts, function(x) which(x == min(x))[1]))
summary(sapply(rslts, function(x) x[2]))

myDigit = 5
q9_10 <- t(sapply(c(1e-2, 1, 1e2, 1e4, 1e6), function(cst) {
  fit <- svm(digit == myDigit ~ ., data = digits.train.sub,
             scale = FALSE,
             kernel = "radial", gamma = 1, cost = cst,
             type = "C-classification")
  pred <- predict(fit, digits.train.sub[-1])

  Ein = sum(pred != (digits.train.sub$digit == myDigit))/nrow(digits.train.sub)

  pred <- predict(fit, digits.test.sub[-1])
  Eout = sum(pred != (digits.test.sub$digit == myDigit))/nrow(digits.test.sub)

  cbind(cst, Ein, Eout, fit$tot.nSV)
}))

q9_10


## Exercício 9
## Prof. James Hunter
## from: https://rstudio.cloud/project/1181172
## 28 de maio de 2020
##
## Simulação das Camisetas de Sustentare -- Uma Vez
## Todos os dados totalmente inventados
## Similaridade entre esta versão da Sustentare e a verdadeiro é 100% por acaso

# Carregar pacotes

library(tidyverse)

# Premissas/Dados

publico_ano1 <- 4000 #número total dos alunos/ex-alunos
novo_publico <- 250 #número novo de alunos por ano
custo_ano1 <- 32 #custo da camiseta estampada com logo e nome em reais
inflacao <- .05 #aumento de custos anual (inflação)com
markup <- 1 #fator para adicionar ao custo para determinar preço de venda
            #ex. 1 = 100%
desenv_ano1 <- 20000 # cobrança em ano 1 para desenvolver produto, mktg, etc.
anos <- 5L #número de anos para julgar se programa vale a pena
min_prop <- 0.15 # min e max proporções do público que vai comprar
max_prop <- 0.40

# Modelo

# colocar as variáveis num tibble

camis <- tibble(desenv = numeric(length = anos), # variáveis numericas
                publico =  numeric(length = anos),
                custo = numeric(length = anos),
                preco = numeric(length = anos),
                compras = numeric(length = anos),
                renda = numeric(length = anos),
                lucro = numeric(length = anos))

# Carregar camis com os valores

## não precisa loop para desenv - só ocorre em ano 1

camis$desenv[1] <- desenv_ano1

## Outras precisam loop

for (i in 1:anos) {
  camis$publico[i] <- publico_ano1 + (i - 1) * novo_publico
  camis$custo[i] <- custo_ano1 * (1 + inflacao)^(i-1)
  camis$preco[i] <- camis$custo[i] * (1 + markup)
}

# variável probabilística -- qual proporção do público vai comprar
# aleatórico entre 15% e 40%
# usar distribuição uniforme -- runif()
# premissa: que pode comprar mais de uma vez

# set.seed() para tudo mundo tem o mesmo resultado

set.seed(42)

prop_compras <- runif(5, min = min_prop, max = max_prop)

camis <- camis %>%
  mutate(compras = publico * prop_compras,
         renda = compras * preco,
         lucro = renda - desenv - custo * compras)

# Calcular os Totais

total_camis <- camis %>%
  summarise(media_prop = mean(prop_compras),
            tot_compras = sum(compras),
            tot_renda = sum(renda),
            tot_lucro = sum(lucro))

total_camis


library(tseries)
library(forecast)
#'cow.dat'data
data<-read.table('cow.dat')
cow<-as.ts(data)
autoplot(cow)
par(mfrow=c(1,2))
acf(cow,main='cow')
pacf(cow)
adf.test(cow)
cow1<-diff(cow)
acf(cow1,main='cow1')
pacf(cow1)
adf.test(cow1)
auto.arima(cow,d=0,approximation=F,max.p=5, max.q=5)
auto.arima(cow,d=1,approximation=F,max.p=5, max.q=5)
fit1<-arima(cow,order=c(0,1,1))
tsdiag(fit1)
Box.test(fit1$residuals,lag=1)
par(mfrow=c(1,1))
plot(cow,xlim=c(0,80),ylim=c(20,100),ylab='cow')
cow.pred<-predict(fit1,n.ahead=5)
lines(cow.pred$pred,col="red")
lines(cow.pred$pred+2*cow.pred$se,col="red",lty=3)
lines(cow.pred$pred-2*cow.pred$se,col="red",lty=3)

#'wwwusage.txt' data
data1<-read.table('wwwusage.txt',header=T)
x<-as.ts(data1)
autoplot(x)
par(mfrow=c(1,2))
acf(x)
pacf(x)
x1<-diff(x)
acf(x1,main='x1')
pacf(x1)
x2<-diff(x1)
acf(x2,main='x2')
pacf(x2)
adf.test(x2)
auto.arima(x,d=2,approximation = F,max.p=5, max.q=5)
fit2<-arima(x,order=c(0,2,3))
fit2
fit3<-arima(x,order=c(2,2,0))
fit3
tsdiag(fit3)
Box.test(fit3$residuals,lag=1)
par(mfrow=c(1,1))
plot(x,xlim=c(0,105),ylim=c(80,280),ylab='x')
x.pred<-predict(fit3,n.ahead=5)
lines(x.pred$pred,col="red")
lines(x.pred$pred+2*x.pred$se,col="red",lty=3)
lines(x.pred$pred-2*x.pred$se,col="red",lty=3)


df = NULL

# Fixed parameters
s <- .2
gl <- .01
delta <- .05
alpha <- .3
lambda <- .9
phi <- -.2
theta <- .01
gR <- .01

# Initialize dynamic process
kycurr <- s/(gl+delta+.02) # start near a BGP
kyalt <- s/(gl+delta+.02) # start near a BGP
Rcurr <- 10 # start everyone with same R stock
Acurr <- 2
Aalt  <- 20

df = NULL # initialize a dataframe
dfalt = NULL # initialize a dataframe
name = "A"
namealt = "B"

for (t in 1:250) # do for this many periods
{
  gA <- theta*(Rcurr^lambda)/(Acurr^(1-phi)) # calculate growth in k/y given current k/y
  gky <- (1-alpha)*(s/kycurr - delta - gA - gl)
  df = rbind(df, data.frame(t,Acurr,gA,gky,kycurr,name)) # add to dataframe
  kycurr <- (1+gky)*(kycurr)
  Acurr <- (1+gA)*(Acurr) # update current k/y for next period
  gA <- theta*(Rcurr^lambda)/(Aalt^(1-phi))
  gky <- (1-alpha)*(s/kyalt - delta - gA - gl)
  dfalt = rbind(dfalt, data.frame(t,Aalt,gA,gky,kyalt,namealt)) # add to dataframe
  kyalt <- (1+gky)*(kyalt)
  Aalt <- (1+gA)*(Aalt)
  Rcurr <- (1+gR)*Rcurr
}

colnames(dfalt) <- c("t","Acurr","gA","gky","kycurr","name")
dfgraph = rbind(df,dfalt)

dfgraph$lny <- (alpha/(1-alpha))*log(dfgraph$ky) + 4 + log(dfgraph$Acurr)
dfgraph$gy <- (alpha/(1-alpha))*dfgraph$gky + dfgraph$gA

df <-dfgraph[order(dfgraph$name, dfgraph$t),]

fig <- plot_ly(df,
               x = ~t,
               y = ~lny,
               color = ~name,
               hoverinfo = "text",
               type = 'scatter',
               mode = 'lines'
)

fig <- fig %>% animation_slider(
  hide = T
)
fig <- fig %>% animation_button(
  x = 1, xanchor = "right", y = 0.4, yanchor = "bottom"
)
fig <- layout(fig, title = list(text = 'Level of GDP per capita over time', x=0),
              xaxis = list(title = 'Time', range=c(0,30),dtick=5),
              yaxis = list (title = 'Log GDP per capita'
              )
)

#api_create(fig, filename = "me-lny-prodanimated")


minCanopyTemperature = minTair + cropHeatFlux / ((rhoDensityAir * specificHeatCapacityAir * conductance / lambdaV) * 1000)
maxCanopyTemperature = maxTair + cropHeatFlux / ((rhoDensityAir * specificHeatCapacityAir * conductance / lambdaV) * 1000)


# script for plot of normal curves with differing means and sds
library(tidyverse)

png("../fig/normal-curves.png")
ggplot(data.frame(x = c(-10, 10)), aes(x = x)) +
  stat_function(fun = dnorm, args = list(-5, 2), color = "#7570b3", lwd=1) +
  stat_function(fun = dnorm, args = list(5, 0.5), color = "#d95f02", lwd=1) +
  stat_function(fun = dnorm, color = "#1b9e77", lwd=1) +
  theme(axis.title.x=element_blank(), axis.title.y=element_blank()) +
  annotate('text', x = -8, y = 0.2, label= "mean = -5\nsd = 2", color = "#7570b3") +
  annotate('text', x = -2.5, y = 0.35, label= "mean = 0\nsd = 1", color = "#1b9e77")  +
  annotate('text', x = 2.5, y = 0.6, label= "mean = 5\nsd = 0.5", color = "#d95f02")
dev.off()


# Euler1 in R

mySum <- function (n, size) {
    n * (ceiling(size/n)**2 + ceiling(size/n)) / 2
}

euler1 <- function (size) {
    return (mySum(3,size) + mySum(5,size) - mySum(15,size))
}

euler1(999)


# Algorithms_potts
# Extend algorithms to work on pott sampler.

# library(extraDistr)  # CHECK -- do we need this?
source("tools.r")

# Simulate states from the Potts model, using auxiliary Gaussian variables.
#
# A: adjacency matrix
# beta: inverse-temperatures
# init: intial state for the chain
# n_states: number of states each particle can adopt.
# n_iter: number of sampling iteration.
# B (not implemented): external magnetic field.
# alpha_modif: modification along diagonal of A to make it semi-positive def.
# retain_alpha: whether to use alpha_modif or instead use min eigenvalue.
# pertub (not implemented): if TRUE, adds flip transition.
#
# return: matrix with samples.
ag_potts_simple <- function (A, beta, init, n_states = 2, n_iter = 1000, B = 0,
                             alpha_modif = 1e-7, retain_alpha = FALSE,
                             perturb = FALSE) {
  if (B != 0) print("WARNING: non-zero magnetic field is not supported.")
  if (perturb) print("WARNING: pertub = TRUE is not supported.")

  if (retain_alpha) {
    alpha = alpha_modif
  } else {
    alpha = abs(min(eigen(A, symmetric = TRUE, only.values = TRUE)$values))
    alpha = alpha + alpha_modif
  }

  n_particles = nrow(A)
  C = 2 * beta * (A + alpha * diag(n_particles))
  L = t(chol(solve(C)))
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  # Auxiliary Gaussians
  Q = matrix(NA, nrow = n_particles, ncol = n_states)

  for (i in 2:n_iter) {
    for (l in 1:n_states) {
      mu_q = rep(0, n_particles)
      mu_q[X[i - 1, ] == l] = 1
      Q[, l] = mvrnorm_cholesky(n = 1, mu = mu_q, L = L)
    }

    P = C %*% Q

    u = runif(n_particles, 0, 1)

    for (j in 1:n_particles) {
      p = rep(NA, n_states)
      for (l in 1:n_states) {
        p[l] = exp(P[j, l])
      }
      norm_const = sum(p)

      state = 1
      p_current = p[state] / norm_const
      while (u[j] > p_current) {
        state = state + 1
        p_current = p_current + p[state] / norm_const
      }

      X[i, j] = state
    }
  }
  X
}

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

# Simulate states from the Potts model, using auxiliary Gaussian variables,
# and a low rank approximation. Takes in the modified adjacency matrix,
# C_tilde. See the wrapper below, which takes in A and beta.
#
#
# C_tilde: modified adjacency matrix, which is low rank, semi+ def,
#          and scaled by the inverse-temperature beta.
# init: intial state for the chain
# n_states: number of states each particle can adopt.
# n_iter: number of sampling iteration.
# epsilon: value below which an eigenvalue is considered to be 0.
# eigenvalue_rounding: determines how different two eigen values need to
#                      be in order to be considered non-identical.
#                      Required to handle numerical precision of LAPACK.
#
# return: matrix with samples.
ag_potts_lowrank__ <- function (C, init, n_states = 2, n_iter = 1000,
                                epsilon = 1e-12, eigenvalue_rounding = 1e12) {
  n_particles = nrow(C)
  spectral_decomposition = eigen(C, symmetric = TRUE)

  n_rank = length(
    spectral_decomposition$values[spectral_decomposition$values > epsilon])
  eigen_values_sqrt = sqrt(spectral_decomposition$values[1:n_rank])

  scaled_eigenvectors <- matrix(NA, nrow = n_particles, ncol = n_rank)
  for (i in 1:n_rank) {
    scaled_eigenvectors[, i] = spectral_decomposition$values[i] *
      spectral_decomposition$vectors[, i]
  }

  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  # Auxiliary Gaussians
  Q = matrix(NA, nrow = n_rank, ncol = n_states)

  for (i in 2:n_iter) {
    for (l in 1:n_states) {
      Y = rep(0, n_particles)
      Y[X[i - 1, ] == l] = 1
      mu_q = t(spectral_decomposition$vector[, 1:n_rank]) %*% Y

      # set.seed(1954)
      standard_normal = rnorm(n_rank)
      Q[, l] = standard_normal / eigen_values_sqrt + mu_q
    }

    P = scaled_eigenvectors %*% Q

    u = runif(n_particles, 0, 1)

    for (j in 1:n_particles) {
      p = exp(P[j, ])
      norm_const = sum(p)

      state = 1
      p_current = p[state] / norm_const
      while (u[j] > p_current) {
        state = state + 1
        p_current = p_current + p[state] / norm_const
      }

      X[i, j] = state
    }
  }
  X
}

# Wrapper around the above function, which takes A and beta.
ag_potts_lowrank <- function(A, beta, init, n_states = 2, n_iter = 1000,
                             alpha_modif = 1e-7, epsilon = 1e-12) {
  n_particles = nrow(A)
  # spectral_decomposition = eigen(2 * beta * A, symmetric = TRUE)
  # n_rank = length(
  #   spectral_decomposition$values[abs(spectral_decomposition$values) > epsilon])
  #
  # A_tilde = matrix(0, nrow = n_particles, ncol = n_particles)
  # for (i in 1:n_rank) {
  #   A_tilde = A_tilde +
  #     spectral_decomposition$values[i] * spectral_decomposition$vectors[, i] %*%
  #       t(spectral_decomposition$vectors[, i])
  # }
  #
  # alpha <- abs(min(eigen(A_tilde, symmetric = TRUE, only.values = TRUE)$values))
  # C_tilde <- A_tilde + alpha * diag(n_particles)

  alpha = abs(min(eigen(A, symmetric = TRUE, only.values = TRUE)$values))
  alpha = alpha + alpha_modif
  C = 2 * beta * (A + alpha * diag(n_particles))

  ag_potts_lowrank__(C, init, n_states, n_iter, epsilon)
}

## Test code

# x <- init_potts
# H = 0
# for (i in 1:n_part) {
#   for (j in 1:n_part) {
#     H = H + (x[i] == x[j]) * C[i, j]
#   }
# }

# 1) Reduce rank
# n_particles <- 16
# A <- adjacency_graph(n_particles, "complete")
# eigen_output <- eigen(A, symmetric = TRUE)
# epsilon <- 1e-12
# eigenvalue_rounding <- 1e12
# n_rank = length(round(
#   eigen_output$values[abs(eigen_output$values) > epsilon] *
#     eigenvalue_rounding) / eigenvalue_rounding)
#
# # Nake sure we have eigenvalues and eigenvectors
# # index <- 4
# # t(A %*% eigen_output$vectors[, index])
# # t(eigen_output$values[index] * eigen_output$vectors[, index])
#
# A_tilde = matrix(0, nrow = n_particles, ncol = n_particles)
# for (i in 1:n_rank) {
#   A_tilde = A_tilde +
#     eigen_output$values[i] * eigen_output$vectors[, i] %*% t(eigen_output$vectors[, i])
# }
# # QUESTION: why does A_tilde not recover A??
#
# alpha <- abs(min(eigen(A_tilde, symmetric = TRUE, only.values = TRUE)$values))
# C_tilde <- A_tilde + alpha * diag(n_particles)
# init <- sample(1:n_states, n_particles, replace = T)
# n_states = 4

# B_tilde <- eigen_output$values + eigen_output$vectors[, 1] %*% t(eigen_output$vectors[, 1])
# eigen_output$values[3] * eigen_output$vectors[, 3]
# A %*% eigen_output$vectors[, 3]

  # # NOTE: The Auxiliary variable I introduce is an overcomplication.
  # # The ag_potts_simple for a simpler version.
  # # DEPRECATE.
  # ag_potts <- function (A, beta, init, n_states = 2, n_iter = 1000, B = 0,
  #                       alpha_modif = 1e-7, retain_alpha = FALSE,
  #                       perturb = FALSE) {
  #   print("WARNING: We recommend using ag_potts_simple.")
  #   if (retain_alpha) {
  #     alpha = alpha_modif
  #   } else {
  #     # CHECK ME!
  #     alpha = abs(min(eigen(A, symmetric = TRUE, only.values = TRUE)$values))
  #     alpha = alpha + alpha_modif
  #   }
  #
  #   n_particles = nrow(A)
  #   C = beta * (A + alpha * diag(n_particles))
  #   L = 2 * t(chol(solve(C)))
  #   X = matrix(NA, nrow = n_iter, ncol = n_particles)
  #   x = init
  #   X[1, ] = x
  #
  #   # Auxiliary Gaussians
  #   Q = matrix(NA, nrow = n_particles, ncol = n_states)
  #
  #   for (i in 2:n_iter) {
  #     for (l in 1:n_states) {
  #       mu_q = rep(-1, n_particles)
  #       mu_q[X[i - 1, ] == l] = 1
  #       Q[, l] = mvrnorm_cholesky(n = 1, mu = mu_q, L = L)
  #     }
  #
  #     P = C %*% Q
  #     P_row_sum_term = 0.25 * rowSums(P)
  #     P_half = 0.5 * P
  #
  #     u = runif(n_particles, 0, 1)
  #
  #     for (j in 1:n_particles) {
  #       p = rep(NA, n_states)
  #       for (l in 1:n_states) {
  #         p[l] = exp(P_half[j, l] - P_row_sum_term[j])
  #       }
  #       norm_const = sum(p)
  #
  #       state = 1
  #       p_current = p[state] / norm_const
  #       while (u[j] > p_current) {
  #         state = state + 1
  #         p_current = p_current + p[state] / norm_const
  #       }
  #
  #       X[i, j] = state
  #     }
  #   }
  #   X
  # }


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(iris$Species)

  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, 3:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    scores <- rep(x = 0, times = length(classes))
    names(scores) = classes
    for (j in 1:k) {
      scores[sortedDataset$Species[j]] = scores[sortedDataset$Species[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)))
}

fast_cvloo_kwnn <- function() {
  maxK <- 149
  classes = unique(iris$Species)
  qs <- seq(from = 0.0, to = 1.0, by = 0.05)

  ans <- array(0L, dim = c(maxK, length(qs)))
  for (i in 1:length(iris[,1])) { # samples
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 3:4], iris[i, 3:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

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

        if (classForCurrentK == paste(iris$Species[i])) {
          ans[j,index] = ans[j,index] + 1
        }
        index <- index + 1
      }
    }
    index <- index + 1
  }
  cat("\n")

  # for (i in 1:length(ans)) {
  #
  #   ans[i] = ans[i] / (length(iris[,1]) - 1)
  # }

  return (ans)
}

m <- fast_cvloo_kwnn()

# Library
library(ggplot2)

qs <- seq(from = 0.0, to = 1.0, by = 0.05)

data <- expand.grid(
  X = dim(m)[1] %>% seq,
  Y = qs)
data$Z <- m %>% as.vector()

mx <- which(max(m) == m, arr.ind = T)
mx[,"col"] <- mx[,"col"] / 21
print(mx)
ggplot(data, aes(X, Y, fill = Z)) +
  geom_tile() +
  geom_rect(fill = "white", data = data.frame(start = mx[,"row"], end = mx[,"row"] + 1), inherit.aes = FALSE, aes(xmin = mx[,"row"], xmax = mx[,"row"] + 1, ymin=mx[,"col"], ymax=mx[,"col"] + 0.05))

1 - Nearest neighbors algorithm/kwnn-heatmap.r


# Examples of empirical correlation matrix computation using cor function

## Read chains

chains <- read.table(file="chain01.csv", header=FALSE, sep=",")

## Compute correlation matrix

print(cor(chains))


x = seq(0, 10, 0.1)
plot(sin(x),type='l')
n = length(x)
y = sin(x) + rnorm(n, mean=0, sd=0.05)

par(mfrow=c(2,1))
plot(sin(x),type='l')
plot(y,type='l')


setwd("P:/2019 0970 151 000/User Data/Faraz")
library(tidyverse)
#data loading and preprocessing
df <- read.csv("NACRASCIHI.csv")

#before demo vars
vars <- names(df)[2:130]
rem_days <- grep("days", names(df), value=TRUE)
rem_time <- grep("time", names(df), value=TRUE)

glm_vars <- vars[! (vars %in% c(rem_days, rem_time))]

str(df[glm_vars])

tabna <- function(x){table(x, useNA = "ifany")}

##
df$alc_status <- as.factor(df$alc_status)
##

################################################LOG ODDS Tutorial

df$female_flag <- as.factor(df$female_flag)

glm.1 <- glm(data = df, alc_status ~ female_flag, family = 'binomial')
summary(glm.1)

exp(glm.1$coef)
# (Intercept) female_flag1
#   0.1133606    1.3207381
tabna(df$alc_status, df$female_flag)
#xtabs(alc_status ~ female_flag, data = df)

library(gmodels)
CrossTable(df$alc_status, df$female_flag)

# Coefficients:
              # Estimate Std. Error z value Pr(>|z|)
# (Intercept)  -2.177181   0.003869 -562.70   <2e-16 ***
# female_flag1  0.278191   0.005104   54.51   <2e-16 ***

#intercept coeff is the log odds for the male group (is reference here)
#meaning the log[p(male being alc) / p(male not being alc)]
#looking at the contingency table this could be confirmed
#
#the coeficient for the female_flag1 (meaning being female) is
# the log of odds ratio between the female group and the male group

exp(glm.1$coef)
# (Intercept) female_flag1
#   0.1133606    1.3207381

# meaning the odds of being alc is going to be 1.3 times more if the
# subject is female

##################################################################################
###################
#Triage=1 is the most severe

df$triage <- as.factor(df$triage)

# glm.1 <- glm(data = df, alc_status ~ triage, family = 'binomial')
# summary(glm.1)

# output <- summary(glm.1)
# z<-output$coefficients[,1]/output$coefficients[,2]
# pv<-(1-pnorm(abs(z),0,1))*2

# CI_lower<-exp(output$coefficients[,1]-1.96*output$coefficients[,2])
# CI_upper<-exp(output$coefficients[,1]+1.96*output$coefficients[,2])

## blood transfused
	df$btany[df$btany == ""] <- NA
	df$btany <- factor(df$btany)

	# glm.1 <- glm(data = df, alc_status ~ btany, family = 'binomial')
	# summary(glm.1)

#########Adding to the result###############

add_result <- function(var, or_ls){
	formula <- as.formula(paste("alc_status ~ ", var))
	glm.var <- glm(data = df, formula, family = 'binomial')
	output <- summary(glm.var)
	z<-output$coefficients[,1]/output$coefficients[,2]
	pv<-(1-pnorm(abs(z),0,1))*2
	CI_lower<-exp(output$coefficients[,1]-1.96*output$coefficients[,2])
	CI_upper<-exp(output$coefficients[,1]+1.96*output$coefficients[,2])
	#profiling method for finding confidence interval is more accurate but too slow
	#or_ls <- rbind(or_ls, cbind(OR = exp(coef(glm.var)), confint(glm.var), pv))
	or_ls <- rbind(or_ls, cbind(OR = exp(coef(glm.var)), CI_lower, CI_upper, pv))
	return(or_ls)
}

result <- double()

result <- add_result("female_flag", result)
result <- add_result("triage", result)
result <- add_result("clidecunitflag", result)
result <- add_result("btany", result)
###saved to 17-3 file

###CACS vars###
df$cacsanetech <- factor(df$cacsanetech, levels = c(8, 1, 2, 3, 4))
# result <- add_result("cacsanetech", result) ##SOLID

##CACS branch---don't know variable meaning!
df$cacsbranch <- as.factor(df$cacsbranch) #too many levels 43!
# glm.1 <- glm(data = df, alc_status ~ cacsbranch, family = 'binomial')
# summary(glm.1)

## CACS Code ---Looks very good! ---Not significant p value --->needs more grouping and modification

#The null values are marked as not applicable
levels(df$cacscode) <- c(levels(df$cacscode), "Notapp")
df$cacscode[df$cacscode == ""] <- "Notapp"
df$cacscode <- factor(df$cacscode)
df$cacscode <- relevel(df$cacscode, "Notapp")##changing order to chnage base of odds ratio in LR

# glm.1 <- glm(data = df, alc_status ~ cacscode, family = 'binomial')
# summary(glm.1)

##CACScode binary vers.

df[df$cacscode == "Notapp", "cacscode_bin"] <- 0 # No code
df[! df$cacscode == "Notapp", "cacscode_bin"] <- 1 #any code
df$cacscode_bin <- factor(df$cacscode_bin)
glm.1 <- glm(data = df, alc_status ~ cacscode_bin, family = 'binomial')
summary(glm.1)

###Grouping all smaller freq into Other category
tbl <- tabna(df$cacscode)
tbl[order(-tbl)]

df$cacscode_grp <- df$cacscode
levels(df$cacscode_grp) <- c(levels(df$cacscode_grp), "Others")
df$cacscode_grp[! df$cacscode %in% c("B001","B002","B003","B004","B005", "Notapp")] <- "Others"
df$cacscode_grp <- factor(df$cacscode_grp)

glm.1 <- glm(data = df, alc_status ~ cacscode_grp, family = 'binomial')
summary(glm.1)

##Much better p values! in the modified cacscode!

# cacsintervention --> 99.9 NULL values ---> not used
# cacsit1 to 8
tabna(df$cacsit1)

#####################OLD VERSION OF DPLYR!!!!!! :////
# df <- within(df, {
	# cacsit1_fac <- dplyr::recode(cacsit1, `1` = "cat_scan",
	# `2` = "cat_scan",
	# `3` = "cat_scan",
	# `4` = "cat_scan",
	# `5` = "cat_scan",
	# `6` = "EEG",
	# `7` = "xray",
	# `20` = "xray",
	# `21` = "xray",
	# `8` = "Mammography",
	# `9` = "MRI",
	# `10` = "MRI",
	# `11` = "MRI",
	# `12` = "Nuclear",
	# `13` = "Nuclear",
	# `14` = "Nuclear",
	# `15` = "Nuclear",
	# `16` = "stress_test",
	# `17` = "ultrasound",
	# `18` = "ultrasound",
	# `19` = "ultrasound"
	# )
# })

df$cacsit1_grp[df$cacsit1 %in% c(1:5)] <- "Cat_scan"
df$cacsit1_grp[df$cacsit1 == 6] <- "EEG"
df$cacsit1_grp[df$cacsit1 %in% c(7,20,21)] <- "Xray"
df$cacsit1_grp[df$cacsit1 == 8] <- "Mammography"
df$cacsit1_grp[df$cacsit1 %in% c(9:11)] <- "MRI"
df$cacsit1_grp[df$cacsit1 %in% c(12:15)] <- "Nuclear"
df$cacsit1_grp[df$cacsit1 == 16] <- "Stress_test"
df$cacsit1_grp[df$cacsit1 %in% c(17:19)] <- "Ultrasound"

###Turn NA to not applicable
actual_NA <- df[which(!df$cacsitcnt == 0 & is.na(df$cacsit1_grp)), c("cacsit1_grp", "cacsitcnt")]
nrow(actual_NA) #237 actual NAs with cacsitcnt of non zero

df$cacsit1_grp[df$cacsitcnt == 0] <- "Notapp"
#Grouping some of the least populated categ.
df$cacsit1_grp[df$cacsit1_grp %in% c("EEG",
									 "Mammography",
									 "Stress_test",
									 "Nuclear")] <- "Others"
#factor it here!
df$cacsit1_grp <- factor(df$cacsit1_grp)
df$cacsit1_grp <- relevel(df$cacsit1_grp, "Notapp")
tabna(df$cacsit1_grp)

glm.1 <- glm(data = df, alc_status ~ cacsit1_grp, family = 'binomial')
summary(glm.1)

result <- add_result("cacsit1_grp", result)

#CACS total count
tabna(df$cacsitcnt)
glm.1 <- glm(data = df, alc_status ~ cacsitcnt, family = 'binomial')
summary(glm.1)
#Shows increase in odds ratio as number goes higher

#CACS Category count 1 to 7 [values: 1,2 and Na]

df$cacsitcnt1[df$cacsit1_grp == "Notapp"] <- "Notapp"
df$cacsitcnt1 <- factor(df$cacsitcnt1)
df$cacsitcnt1 <- relevel(df$cacsitcnt1, "Notapp")
levels(df$cacsitcnt1) <- c( "Notapp", "Just1","2orMore" )
glm.1 <- glm(data = df, alc_status ~ cacsitcnt1, family = 'binomial')
summary(glm.1)

### CACS logic type
tabna(df$cacslogictype)
df$cacslogictype <- as.factor(df$cacslogictype)
# glm.1 <- glm(data = df, alc_status ~ cacslogictype, family = 'binomial')
# summary(glm.1)

### CACS Partition Type
tabna(df$cacspartition)
df$cacspartition[df$cacspartition == ""] <- NA
df$cacspartition <- factor(df$cacspartition, levels = c("A", "D", "I"))
glm.1 <- glm(data = df, alc_status ~ cacspartition, family = 'binomial')
summary(glm.1)

#############END of CACS vars

##Adding odds ratio and confint and p value to results
result <- add_result("cacsanetech", result) ##SOLID

result <- add_result("cacscode", result) ##Too many levels but for keeping in records
result <- add_result("cacscode_grp", result) ##SOLID
result <- add_result("cacscode_bin", result) ##SOLID

result <- add_result("cacsitcnt", result) ##SOLID
result <- add_result("cacsitcnt1", result) ## Questionable but seems SOLID ---
 # other numbers could be picked maybe?
result <- add_result("cacslogictype", result)
result <- add_result("cacspartition", result) ##SOLID
result
##These CACS vars were not added!
# result <- add_result("cacsbranch", result) ##CI not converge
saveRDS(result, "./univar_result_CACS.rds")

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

## Glascow Coma Scale ##

df$glscoma[df$glscoma %in% c(3:8)] <- "Severe"
df$glscoma[df$glscoma %in% c(9:13)] <- "Moderate"
df$glscoma[df$glscoma %in% c(14,15)] <- "Mild"
df$glscoma[df$glscoma %in% c(99)] <- NA
df$glscoma[df$glscoma %>% is.na()] <- "Notapp"
df$glscoma <- as.factor(df$glscoma)
tabna(df$glscoma)
df$glscoma <- relevel(df$glscoma, "Notapp")##changing order to chnage base of odds ratio in LR

# glm.1 <- glm(data = df, alc_status ~ glscoma, family = 'binomial')
# summary(glm.1)
df$glscoma_bin <- as.character(df$glscoma)
df$glscoma_bin[! df$glscoma == "Notapp" ] <- "Y"
tabna(df$glscoma_bin)
df$glscoma_bin   <- factor(df$glscoma_bin )
# glm.1 <- glm(data = df, alc_status ~ glscoma_bin, family = 'binomial')
# summary(glm.1)

df$glscoma_grp <- as.character(df$glscoma)
df$glscoma_grp[ df$glscoma %in% c("Moderate", "Mild") ] <- "LessSevere"
df$glscoma_grp   <- factor(df$glscoma_grp )
df$glscoma_grp   <- relevel(df$glscoma_grp, "Notapp" )

## Patient complaint1 ##

tabna(df$complaint1) #173 levels

##Trying to look more into the 40% missing obs
df[which(is.na(df$days_to_ambarrdate)),] %>% select(complaint1) %>% is.na() %>% sum()
#They are not just patients who arrived by the ambulance

#Checking NA with year in data
comp.na <- df[which(is.na(df$complaint1)),] %>% select(complaint1, indexfyear)

tabna(comp.na$indexfyear) ##Number of missing obs of compalint per year
tabna(comp.na$indexfyear) / tabna(df$indexfyear) * 100 ##percentage

#intresting find is that from 2014 to 2016 this variable has around 5 percent missing
#as the average for other years was around 40% !!!!
# But sizes are much smaller in these last thress years

#Check complaint1 and eddischdx1 (discharge diagnosis)
df[c("complaint1", "eddischdx1")] %>% head()
#No way is discharge as it is 99 percent null itself

####This has a odds ratio reference problem but let's keep it for now

tbl <- tabna(df$complaint1)
tbl[order(-as.numeric(tbl))] #NA not shown
#CrossTable(df$complaint1, df$alc_status) #hard to get information this way!
###Lets group by highest freq categories

selected_cat <- names(tbl[order(-as.numeric(tbl))])[1:22]
# [1] NA    "651" "7"   "251" "3"   "999" "557" "409" "852" "401" "555" "257" "402" "8"
# [15] "855" "260" "551" "5"   "4"   "653" "403" "407"
df$complaint1_grp <- df$complaint1
df$complaint1_grp[! df$complaint1_grp %in% selected_cat] <- "Others"
df$complaint1_grp <- factor(df$complaint1_grp)
#Now building the LR model
glm.1 <- glm(data = df, alc_status ~ complaint1_grp, family = 'binomial')
summary(glm.1)

# Some categories have insanely high odds ratio, lets take a closer look!
df$complaint1_555

## Consultserv1 ## ####This has a odds ratio reference problem but let's keep it for now

str(df$consultserv1) #not Factor
tabna(df$consultserv1)

tbl <- tabna(df$consultserv1)
tbl[order(-as.numeric(tbl))]
selected_cat <- names(tbl[order(-as.numeric(tbl))])[1:15]
# NA   "10" "30" "1"  "34" "12" "39" "17" "15" "18" "32" "55" "74" "16" "37"
df$consultserv_grp <- df$consultserv1
df$consultserv_grp[! df$consultserv_grp %in% selected_cat] <- "Others"
tabna(df$consultserv_grp)
#Now building the LR model
glm.1 <- glm(data = df, alc_status ~ consultserv_grp, family = 'binomial')
summary(glm.1)

##Percentage of missing in each year
consult.na <- df[which(is.na(df$consultserv1)),] %>% select(consultserv1, indexfyear)

tabna(consult.na$indexfyear) ##Number of missing obs of compalint per year
tabna(consult.na$indexfyear) / tabna(df$indexfyear) * 100 ##percentage

#####Add to results
result <- add_result("glscoma", result)
result <- add_result("glscoma_bin", result)
result <- add_result("glscoma_grp", result)

result <- add_result("complaint1_grp", result)
result <- add_result("consultserv_grp", result)

saveRDS(result, "./univar_result_consult.rds")

####Next are Mostly Cihi vars

cvar <- c("admcat", "age_group","dependency_q_da", "deprivation_q_da",
"dischdisp", "entry", "ethniccon_q_da", "female_flag", "incquint", "indexfyear",
"instability_q_da", "instftyp", "rural")

sapply(df[cvar], tabna)
str(df[cvar])

#####Demographic in cvar

##AGE --used as integer
	df$age_group <- factor(df$age_group, levels = c(levels(df$age_group), "102"))
	df[which(df$age_group == "102-110"), "age_group"] <- "102"
	df$age_group <- as.numeric(as.character(df$age_group))
	tabna(df$age_group)
	#Now building the LR model
	glm.1 <- glm(data = df, alc_status ~ age_group, family = 'binomial')
	summary(glm.1)
##Female Flag---> was used at top of file

##Rural
	tabna(df$rural)
	df$rural[df$rural == ""]<- NA
	df$rural <- factor(df$rural)
	#Now building the LR model
	glm.1 <- glm(data = df, alc_status ~ rural, family = 'binomial')
	summary(glm.1)

## "dependency_q_da"
	df$dependency_q_da <- as.factor(df$dependency_q_da)
	glm.1 <- glm(data = df, alc_status ~ dependency_q_da, family = 'binomial')
	summary(glm.1)

## deprivation_q_da
	df$deprivation_q_da <- as.factor(df$deprivation_q_da)
	glm.1 <- glm(data = df, alc_status ~ deprivation_q_da, family = 'binomial')
	summary(glm.1)

## "ethniccon_q_da"
	df$ethniccon_q_da <- as.factor(df$ethniccon_q_da)
	glm.1 <- glm(data = df, alc_status ~ ethniccon_q_da, family = 'binomial')
	summary(glm.1)

## instability_q_da
	df$instability_q_da <- as.factor(df$instability_q_da)
	glm.1 <- glm(data = df, alc_status ~ instability_q_da, family = 'binomial')
	summary(glm.1)

## Income quantile
	df$incquint <- as.factor(df$incquint)
	glm.1 <- glm(data = df, alc_status ~ incquint, family = 'binomial')
	summary(glm.1)

#####Add to results
result <- add_result("age_group", result)
result <- add_result("rural", result)
result <- add_result("dependency_q_da", result)
result <- add_result("deprivation_q_da", result)
result <- add_result("ethniccon_q_da", result)
result <- add_result("instability_q_da", result)
result <- add_result("incquint", result)
saveRDS(result, "./univar_result_demo.rds")
write.csv(result, "./univar_result_final.csv")


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

############## FUNCTION DEFINITIONS #################################

#function to calculate the log-likelihood for nonstationary GEV model with trend in location parameter
GEV.likelihood = function(mu,muslope,sigma,epsilon,data,time_index){
  t = (1+epsilon*((data-mu-(muslope*time_index))/sigma))^(-1/epsilon)
  pdf = (t^(epsilon+1))*exp(-t)/sigma
  log.likelihood = sum(log(pdf))
  return(log.likelihood)
}

#function to create time index for any baseyear
time.index = function(Year,ReferenceYear){
  t = Year - ReferenceYear
  return(t)
}
#function to calculate nonstationary return period for event z
calc.nstat.ret.period = function(mu_0,mu_1,scale,shape,z,baseyear,analysisyear){
  i = 0
  accept_prob = 1
  prod_accept_prob = 1
  t = 1
  while (accept_prob > 0){
    accept_prob = exp(-((1 + (shape*((z-(mu_0+mu_1*(analysisyear-baseyear)+(mu_1*i)))/scale)))^(-1/shape)))
    prod_accept_prob = prod_accept_prob*accept_prob
    t = t + prod_accept_prob
    i = i+1
  }
  return(t)
}

#function to calculate nonstationary "n" year return event (n>=2)
calc.nstat.ret.event = function(mu_0,mu_1,scale,shape,n,baseyear,analysisyear,epsilon){
  stat_params.default = 1
  if (mu_1<=0){
    z = mu_0  - scale*(1-(-log(1 - (1/n)))^(-shape))/shape
    return(z)
  } else {
    #calculate lower bound of n year event
    lb = mu_0  - scale*(1-(-log(1 - (1/n)))^(-shape))/shape
    t_lb = n
    while (t_lb > n-epsilon){
      t_lb = calc.nstat.ret.period(mu_0,mu_1,scale,shape,lb,baseyear,analysisyear)
      if(t_lb>n-epsilon){lb = 0.9*lb}
    }
    #calculate upper bound of n year event
    ub = mu_0 + mu_1*(analysisyear-baseyear) +mu_1*n - scale*(1-(-log(1 - (1/(n))))^(-shape))/shape
    t_ub = n
    while (t_ub < n+epsilon){
      t_ub = calc.nstat.ret.period(mu_0,mu_1,scale,shape,ub,baseyear,analysisyear)
      if(t_ub<n+epsilon){ub = 1.5*ub}
    }
    #get n year event iteratively with epsilon level of accuracy.
    t = 0
    while (abs(t - n) > epsilon) {
      z = (lb+ub)/2
      t = calc.nstat.ret.period(mu_0,mu_1,scale,shape,z,baseyear,analysisyear)
      if (t < n) {
        lb = z
      } else {ub = z}
    }
  return(z)
  }

}

#function to plot return event with respect to return period
ret.event.plot.data = function(baseyear_par_data, min_ret_index, max_ret_index,mle_year_index, avg_year_index, analysisyear){
  t = seq(5,100,5)
  epsilon_seq = 0.01*t
  min = NULL
  max = NULL
  mle = NULL
  avg = NULL
  for (i in 1:length(t)){
    min[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[min_ret_index],baseyear_par_data$location_slope[min_ret_index],baseyear_par_data$scale[min_ret_index],baseyear_par_data$shape[min_ret_index],t[i],baseyear_par_data$year[min_ret_index],analysisyear,epsilon_seq[i])
    max[i] = calc.nstat.ret.event(baseyear_par_data$location_intercept[max_ret_index],baseyear_par_data$location_slope[max_ret_index],baseyear_par_data$scale[max_ret_index],baseyear_par_data$shape[max_ret_index],t[i],baseyear_par_data$year[max_ret_index],analysisyear,epsilon_seq[i])
    mle[i] = calc.nstat.ret.event(baseyear_par_data$location_intercept[mle_year_index],baseyear_par_data$location_slope[mle_year_index],baseyear_par_data$scale[mle_year_index],baseyear_par_data$shape[mle_year_index],t[i],baseyear_par_data$year[mle_year_index],analysisyear,epsilon_seq[i])
    avg[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[avg_year_index],baseyear_par_data$location_slope[avg_year_index],baseyear_par_data$scale[avg_year_index],baseyear_par_data$shape[avg_year_index],t[i],baseyear_par_data$year[avg_year_index],analysisyear,epsilon_seq[i])
  }
  y_data = data.frame(t,min,max,mle,avg)
  write.table(y_data, file = paste0(output_file,"_reteventplot_data.csv"), row.names=FALSE, na="", col.names=c("year","min","max","mle","avg"), sep=",")
  return(y_data)
}
#function to plot return event trend with respect to analysis year for a given return period
ret.event.trend = function(baseyear_par_data,min_ret_index, max_ret_index,mle_year_index, avg_year_index, return_period,first_analysis_year,last_analysis_year,interval){
  epsilon = 0.01*return_period
  analysisyear = seq(first_analysis_year,last_analysis_year,interval)
  min = NULL
  max = NULL
  mle = NULL
  avg = NULL
  for (i in 1:length(analysisyear)){
    min[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[min_ret_index],baseyear_par_data$location_slope[min_ret_index],baseyear_par_data$scale[min_ret_index],baseyear_par_data$shape[min_ret_index],return_period,baseyear_par_data$year[min_ret_index],analysisyear[i],epsilon)
    max[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[max_ret_index],baseyear_par_data$location_slope[max_ret_index],baseyear_par_data$scale[max_ret_index],baseyear_par_data$shape[max_ret_index],return_period,baseyear_par_data$year[max_ret_index],analysisyear[i],epsilon)
    mle[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[mle_year_index],baseyear_par_data$location_slope[mle_year_index],baseyear_par_data$scale[mle_year_index],baseyear_par_data$shape[mle_year_index],return_period,baseyear_par_data$year[mle_year_index],analysisyear[i],epsilon)
    avg[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[avg_year_index],baseyear_par_data$location_slope[avg_year_index],baseyear_par_data$scale[avg_year_index],baseyear_par_data$shape[avg_year_index],return_period,baseyear_par_data$year[avg_year_index],analysisyear[i],epsilon)
  }
  ret_trend_data = data.frame(analysisyear,min,max,mle,avg)
  write.table(ret_trend_data, file = paste0(output_file,"_retevent_trend_data.csv"), row.names=FALSE, na="", col.names=c("analysisyear","min","max","mle","avg"), sep=",")
  return(ret_trend_data)
}

#function to calculate likelihood value
likelihood.val = function(data,time_index,mu0,mu1,scale,shape){
  k =(1 + (shape*(data-(mu0+(mu1*time_index)))/scale))^(-1/shape)
  pdf = (1/scale)*((k)^(shape+1))*exp(-k)
  llf = -sum(log(pdf))
  return(llf)
}

#function to calculate stationary return event
calc.stat.ret.event = function(mu, scale, shape, n){
  z = mu  - scale*(1-(-log(1 - (1/n)))^(-shape))/shape
  return(z)
}

#function to do MCMC sampling
draw.MCMC.samples = function(Data,time_index,InitialValues,LocationInterceptPrior,LocationSlopePrior,ScalePrior,ShapePrior,ProposalWidth,n_samples){
  mu_lb = LocationInterceptPrior[1]
  mu_ub = LocationInterceptPrior[2]
  muslope_lb = LocationSlopePrior[1]
  muslope_ub = LocationSlopePrior[2]
  scale_lb = ScalePrior[1]
  scale_ub = ScalePrior[2]
  shape_lb = ShapePrior[1]
  shape_ub = ShapePrior[2]
  mu = InitialValues[1]
  muslope = InitialValues[2]
  scale = InitialValues[3]
  shape = InitialValues[4]
  mu_proposal_width = ProposalWidth[1]
  muslope_proposal_width = ProposalWidth[2]
  scale_proposal_width = ProposalWidth[3]
  shape_proposal_width = ProposalWidth[4]
  mu_post=NULL
  muslope_post=NULL
  scale_post=NULL
  shape_post=NULL
  rng_seed = 1
  sample = 0
  rng = 0
  set.seed(rng_seed)

  #start the algorithm; (NOTE: if likelihood not finite for initial values of parameters, select different values).

  if(is.finite(GEV.likelihood(mu,muslope,scale,shape,Data,time_index))==FALSE){
    while (is.finite(GEV.likelihood(mu,muslope,scale,shape,Data,time_index))==FALSE){
      mu = runif(1,mu_lb,mu_ub)
      muslope = runif(1,muslope_lb,muslope_ub)
      scale = runif(1,scale_lb,scale_ub)
      shape = runif(1,shape_lb,shape_ub)
      rng = rng+1
    }
  }

  while (sample < n_samples){

    #start sampling proposals from jump distribution
    mu_proposed = rnorm(1,mu,mu_proposal_width)
    muslope_proposed = rnorm(1,muslope,muslope_proposal_width)
    scale_proposed = rnorm(1,scale,scale_proposal_width)
    shape_proposed = rnorm(1,shape,shape_proposal_width)
    #counter for random number generated
    rng = rng+1

    #check if all the values are finite for acceptance ratio calculation

    suppressWarnings(if (is.finite(GEV.likelihood(mu_proposed,muslope_proposed,scale_proposed,shape_proposed,Data,time_index))==TRUE & is.finite(dunif(mu_proposed,mu_lb,mu_ub,log = TRUE)) == TRUE & is.finite(dunif(scale_proposed,scale_lb,scale_ub,log = TRUE)) == TRUE & is.finite(dunif(shape_proposed,shape_lb,shape_ub,log = TRUE)) == TRUE & is.finite(dunif(muslope_proposed,muslope_lb,muslope_ub,log = TRUE))==TRUE) {

      log.r = GEV.likelihood(mu_proposed,muslope_proposed,scale_proposed,shape_proposed,Data,time_index) + dunif(mu_proposed,mu_lb,mu_ub,log = TRUE) + dunif(muslope_proposed,muslope_lb,muslope_ub,log = TRUE) + dunif(scale_proposed,scale_lb,scale_ub,log = TRUE) + dunif(shape_proposed,shape_lb,shape_ub,log = TRUE) - GEV.likelihood(mu,muslope,scale,shape,Data,time_index) - dunif(mu,mu_lb,mu_ub,log = TRUE) - dunif(scale,scale_lb,scale_ub,log = TRUE) - dunif(shape,shape_lb,shape_ub,log = TRUE) - dunif(muslope,muslope_lb,muslope_ub,log = TRUE)

      #collect new sample if criteria satisfied
      if (log.r > log(runif(1,0,1))){
        mu = mu_proposed
        muslope = muslope_proposed
        scale = scale_proposed
        shape = shape_proposed

      }
    })
    mu_post = c(mu_post,mu)
    scale_post = c(scale_post,scale)
    shape_post = c(shape_post,shape)
    muslope_post = c(muslope_post,muslope)
    sample = sample + 1
  }
  parameters = data.frame(mu_post,muslope_post,scale_post,shape_post)
  return(parameters)
}


########################
# R Script for Class 6 #
########################

# loading data
D = read.csv2('shoesize.csv')
D

# exploring height
D$Height
mean(D$Height)
sd(D$Height)
quantile(D$Height)
hist(D$Height)
plot(density(D$Height))

sd(D$Height)/sqrt(408)

hist(D$Size)
mean(D$Size)
sd(D$Size)

mean(D$Size)+(2*(sd(D$Size)/sqrt(408)))
mean(D$Size)-(2*(sd(D$Size)/sqrt(408)))

# What is the relationship between height and shoe size?

plot(D$Height, D$Size)
cor(D$Height, D$Size)

M = lm(D$Height~D$Size)
summary(M)

M = lm(D$Height~D$Size+D$Gender)
summary(M)

M = lm(D$Height~D$Size+D$Gender + D$Size*D$Gender )
summary(M)

# family planning data
library(foreign)
library(calibrate)

D = read.dta('effort.dta')
head(D)

plot(change~effort, data=D, ylab="CBR change", xlab="program effort", pch=20, col="#000099dd", cex=2)

M = lm(change~effort, data=D)
summary(M)

M = lm(change~effort+setting, data=D)
summary(M)


########### Sample R script for Customer Churn ###############
## Source: IBM Developerworks

library(ggplot2)

## Code below creates a data frame called mydata based on an input file
mydata <- read.csv("customer_data.csv")

## Code below performs statistical analysis on the data frame
mydata$IN_B2B_INDUSTRY <- factor(mydata$IN_B2B_INDUSTRY)
mydata$TOTAL_BUY <- factor(mydata$TOTAL_BUY)

## Code below performs Logistic Regression
mylogit <- glm(CENSOR ~ AVG_SPENT_RETAIN_PM + AVG_SQ_SPENT_RETAIN_PM + TOTAL_BUY + TOTAL_BUY_FREQ
              + IN_B2B_INDUSTRY + ANNUAL_REVENUE_MIL + TOTAL_EMPLOYEES, data = mydata, family = binomial)
summary(mylogit)
newdata2 <- with(mydata, data.frame(DURATION = rep(seq(from = 36, to = 730, length.out = 100)),
                                   AVG_SPENT_RETAIN_PM = rep(seq(from = 0, to = 145, length.out = 100)),
                                   AVG_SQ_SPENT_RETAIN_PM = rep(seq(from = 0, to = 21071, length.out = 100)),
                                   IN_B2B_INDUSTRY = factor(rep(0:1, each = 100)),
                                   ANNUAL_REVENUE_MIL = rep(seq(from = 1, to = 77, length.out = 100)),
                                   TOTAL_EMPLOYEES = rep(seq(from = 0, to = 2000, length.out = 100)),
                                   TOTAL_BUY = factor(rep(1:6, each = 100)),
                                   TOTAL_BUY_FREQ = rep(seq(from = 1, to = 21, length.out = 100))))
newdata3 <- cbind(newdata2, predict(mylogit, newdata = newdata2, type = "link",
                                   se = TRUE))
newdata3 <- within(newdata3, {churnprob <- plogis(fit)
                             LL <- plogis(fit - (1.96 * se.fit))
                             UL <- plogis(fit + (1.96 * se.fit))})
cutpoints <- quantile(newdata3$DURATION, seq(0, 1, length = 4), na.rm = TRUE)
newdata3$dur_dec <- cut(newdata3$DURATION, cutpoints)
levels(newdata3$dur_dec)#
newdata3$IN_B2B_INDUSTRY <- factor(newdata3$IN_B2B_INDUSTRY, labels = c("B2C", "B2B"))
newdata3$dur_dec <- factor(newdata3$dur_dec, labels = c("Duration:36-267", "Duration:267-499", "Duration:499-730"))

## Code below saves the output in CSV format
write.csv(newdata3, file = "churn.csv")

## Code below generates a plot
churn <- ggplot(newdata3, aes(x = AVG_SPENT_RETAIN_PM, y = churnprob)) +
 geom_point(aes(color = TOTAL_BUY_FREQ),size = 1, alpha = 0.75) +
 scale_colour_gradient(low="green", high = "red") +
 geom_smooth(method = "lm", se=FALSE,  size=2, col="steelblue", linetype=3) +
 facet_wrap(dur_dec~IN_B2B_INDUSTRY, nrow=4,ncol=2)+
 labs(title="Customer Churn")+   labs(x="Average Retaining Expense",y="Customer churn Probability")
ggsave(filename = "customer-img.jpg", plot = churn, height=3, width=3, scale=2, dpi=200)
## Code below saves the plot as PDF
ggsave(filename = "churn.pdf", height=7, width=7)


library(mixtools)

N <- 400

X <- list(
	mvrnorm(N, c(1,1), matrix(c(1,-0.5,-0.5,1),2,2)/4),
	mvrnorm(N, c(3,3), matrix(c(2,0.5,0.5,1),2,2)/4),
	mvrnorm(N, c(5,5), matrix(c(1,-0.5,-0.5,4),2,2)/4))

plot(0,0,xlim=c(-1,7),ylim=c(-1,7),type='n')
for(i in 1:3)
	points(X[[i]],pch=18+i, col=1+i)


require(png)
require(animation)
## likelihood and dL/dp
lik <- function(x,n,p){
    choose(n,x)*p^x*(1-p)^(n-x)
}
dl <- function(x,n,p){
    choose(n,x)*p^(x-1)*(1 - p)^(n - x - 1)*(x - n*p)
}

pngs <- list.files("img/",pattern = "mle_pics",full = TRUE)
imgs <- lapply(pngs,png::readPNG)

## Binomial params
n <- 190
x <- 125
p <- seq(0.55,0.75,length.out = 300)
mle <- x/n
## id mle
idx <- which(abs(p - mle) == min(abs(p - mle)))
p.new <- c(p[1:idx],rep(mle,15),p[idx:length(p)]) ## spend 16 at hill peak
idx.plt <- rep(1:4,times = length(p)/4)
idx.plt <- c(idx.plt[1:(idx-1)],rep(5:12,times = 2),idx.plt[idx:length(p)])

ani.options(interval = 0.4)
saveGIF(
    for(i in 1: length(p.new)){
        layout(matrix(c(1,1,1,2,2,2,2,2,2),ncol = 3,byrow = TRUE))
        par(mar = c(0,0,0,0))
        plot(1,type = "n", axes = FALSE,xlim = c(p.new[1],p.new[length(p.new)]),xlab ="",ylim = c(0,1),ylab = "")
        rasterImage(imgs[[idx.plt[i]]],p.new[i] - 0.1,0,p.new[i] + 0.1,1)
        par(mar = c(4.5,4.5,0,0))
        plot(p.new,lik(x,n,p.new),type = "l",ylab = "L(p;x)", lwd = 3,cex.lab = 2,
             xlab = "p",xaxt = "n",yaxt = "n")
        axis(1, tick = TRUE,cex.axis = 2)
        axis(2, tick = TRUE, at = c(0.00,0.02,0.04,0.06),cex.axis = 2,las = 2)
        vall <- round(dl(x,n,p.new[i]),3)
        points(p.new[i],lik(x,n,p.new[i]),col = "red",pch = 20, cex = 3)
        legend("topleft",bty = "n",legend = bquote(frac(dL,dp) == .(vall)),cex = 3)
    },movie.name = "mle.gif"
)


library(psych)

region_cells_BE <- read.csv('../data/train_BE/region_cells.csv')
subset_BE <- region_cells_BE[which(region_cells_BE$density>0 & region_cells_BE$density<30),]

biserial(region_cells_BE$density, region_cells_BE$hasstop) # 0.1756958
biserial(subset_BE$density, subset_BE$hasstop) # 0.4397582
# Outliers distort the correlation a lot!
# We only take a subset_BE of the data, with which we get a correlation of 0.4397582
boxplot(density~hasstop, data=subset_BE)

region_cells_NL <- read.csv('../data/train_NL/region_cells.csv')
subset_NL <- region_cells_NL[which(region_cells_NL$density>0 & region_cells_NL$density<6.3),]

biserial(region_cells_NL$density, region_cells_NL$hasstop) # 0.8780911
biserial(subset_NL$density, subset_NL$hasstop) # 0.4599671
# Outliers distort the correlation a lot!
# We only take a subset_NL of the data, with which we get a correlation of 0.4397582
boxplot(density~hasstop, data=subset_NL)


# Imitating the amount of expenses in following:
# A person, older than 65 y.o., buys some medicine during 1 year.
# The number of purchases ~ Po(25), purchase's amount of money ~ U(5,95)

# calculating total costs for each year by the number of purchases
CostCalculate <- function(num)
{
  return(sum(runif(num, 5, 95)))
}

DrawPlot <- function(title, x = Timeline, y)
{
  ggplot(data = NULL, aes(x, y)) + geom_path() + ggtitle(title) + xlab(substitute(x)) + ylab(substitute(y))
}

library(ggplot2)

# number of years to imitate independently
Y <- 1000
Timeline <- seq(from = 1, to = Y, by = 1)

# imitating Y years for one person:
# number of purchases
PurchaseNum <- rpois(Y,25)
Expenses <- sapply(PurchaseNum, CostCalculate)

DrawPlot(y = PurchaseNum, title = "Purchase Number")
DrawPlot(y = Expenses, title = "Expenses")

AvgCost <- mean(Expenses)
print("Average expenses cost is:")
print(AvgCost)

# P{costs per year >= 2000} - ?
p <- length(Expenses[Expenses >= 2000])/length(Expenses)
print("P{costs per year >= 2000} is:")
print(p)


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Sat Feb 20 16:16:23 2010
########################################################
#Check to see if the homicide data was manipulated with
#1. Benford's law

source("library/utilities.r")

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

########################################################
#See if the first digits of the monthly number of homicides
#follow a Benford distribution
########################################################
dBen <- function(x){
    log(1 + 1/x) / log(10)
}

firstDigit <- function(x){
    x <- as.numeric(substring(formatC(x, format = 'e'), 1, 1))
}

benObsExp <- function(x, name =""){
    n <- length(x)
    x <- firstDigit(x)
    obs.freq <- tabulate(x, nbins = 9)
    obs.freq <- obs.freq / sum(obs.freq)
    ben.freq <- dBen(1:9)
    name <- paste(name, "homicide data (red) vs. Benford's law (black)")
    df <- data.frame(obs = obs.freq, ben = ben.freq, digits = 1:9)
    ggplot(df, aes(digits, ben)) + geom_line() +
        geom_point(aes(digits, obs), color = "red") +
        opts(title = name) + ylab("") +
        scale_y_continuous(formatter = "percent")
}

chiBen <- function(x) {
    n <- length(x)
    x <- firstDigit(x)
    obs.freq <- tabulate(x, nbins = 9)
    chisq.test(obs.freq, p = dBen(1:9))
}

#The original data from Benford's paper
#http://mathworld.wolfram.com/BenfordsLaw.html
death.rate <-  (c(27.0,18.6,15.7,9.4,6.7,6.5,7.2,4.8,4.1)/100) * 418
chisq.test(death.rate, p = dBen(1:9))

#For the vital statistics data
#Benford's law is scale invariant
inegi <- hom$Total.Murders
print(benObsExp(inegi, "INEGI"))
ggsave("Benford/output/INEGI.png", dpi=72, width = 6, height = 6)
chiBen(inegi)

#For the police data
icesi <- melt(read.csv("INEGIvsSNSP/data/states-icesi.csv"),
           id ="State")
print(benObsExp(icesi$value, "SNSP"))
ggsave("Benford/output/ICESI.png", dpi=72, width = 6, height = 6)
chiBen(icesi$value)

#Mean absolute deviation

#INEGI
y <- tabulate(firstDigit(inegi), nbins=9)
sum(abs((dBen(1:9)) - y / sum(y)))*100
#ICESI
y <- tabulate(firstDigit(icesi$value), nbins=9)
sum(abs((dBen(1:9)) - y / sum(y)))*100

#Some regressions to see the size of the difference

#Null hypothesis
y <- dBen(1:9)
fitBen <- lm(log(y) ~ c(1:9))
#INEGI
y1 <- tabulate(firstDigit(inegi), nbins=9)
fitInegi <- lm(log(y) ~ c(1:9))
#ICESI
y2 <- tabulate(firstDigit(icesi$value), nbins=9)
fitIcesi <- lm(log(y) ~ c(1:9))

anova(fitInegi, fitBen)
anova(fitIcesi, fitBen)

#check if the last digit follows a uniform distribution
#Is this even reasonable? I don't think so
lastDigit <- function(v){
 	v - 10*floor(v/10)
}
chi.uni <- function(x) {
  v <- table(lastDigit(x))
  chisq.test(as.vector(v), p = rep(1/10, 10))
}

chi.uni(inegi)
chi.uni(icesi$value)
plot(as.vector(table(lastDigit(icesi$value))))


#' Quantile Sheets with pya's constraint
#'
#' Estimate conditional quantile sheet Schlossmacher's
#'  Alternating b/w weighted regression and recomputing weights
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param arg_bs  argument for b-spline
#' @param dims knots number
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import scam
#'
#' @return a scam object
#'

qs_scam <- function(x, y, maxit = 10, ntaus = 10,
                    arg_bs = c("tesmi1", "ps"),
                    opt = "bfgs", dims = c(5, 15), ords = NA,
                    analysis = F, trace = F, sp = NULL, tol = 5e-2,
                    bnd = 1e-5, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }

    # initialization
    fit <- cq.reg(x, y, arg_bs, opt, dims, ords, sp = sp, ...)
    v_coef <- coef(fit)
    # fit <- f_descent(y, x, dims - ords, ords, maxit = 0)
    # v_coef <- fit$beta

    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(bnd, 1 - bnd, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # get info
    v_pred <- predict(fit, dat)
    # v_pred <- c(cq_prediction(v_taus, fit))
    v_resid <- ystar - v_pred

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / sqrt(v_resid^2 + 1e-8 * max(abs(v_resid))^2)
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- scam(y ~ s(tau, x1, k = dims, m = ords, bs = arg_bs),
            data = dat, optimizer = opt, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # get info
        v_pred <- fit$fitted.values
        v_resid <- fit$residual
        s_diff <- norm_2(v_coef - c(coef(fit))) / norm_2(v_coef)
        v_coef <- c(coef(fit))
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        # terminate
        if (s_diff <= tol) break
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$bnd <- bnd
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}

#' Quantile Sheets(original)
#'
#' Estimate conditional quantile sheet Schlossmacher's
#'  Alternating b/w weighted regression and recomputing weights
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import mgcv
#'
#' @return a gam object
#'

qs_gam <- function(x, y, maxit = 10, ntaus = 10,
                   dims = c(10, 10), ords = NA,
                   analysis = F, trace = F, sp = NULL, tol = 1e-3, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }
    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(0, 1, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # initialization
    fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
        data = dat, sp = c(sp), ...
    )
    v_coef <- coef(fit)

    # get info
    v_pred <- predict(fit, dat)
    v_resid <- ystar - v_pred

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / sqrt(v_resid^2 + 1e-8 * max(abs(v_resid))^2)
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
            data = dat, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # terminate
        s_diff <- norm_2(v_coef - coef(fit)) / norm_2(v_coef)
        v_coef <- coef(fit)
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        if (s_diff <= tol) break
        # get info
        v_pred <- fit$fitted.values
        v_resid <- ystar - v_pred
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}

#' Expectile Sheets with pya's constraint
#'
#' Estimate conditional quantile sheet iterative evalution
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param arg_bs  argument for b-spline
#' @param dims knots number
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import scam
#'
#' @return a scam object
#'
es_scam <- function(x, y, maxit = 10, ntaus = 10,
                    arg_bs = c("tesmi1", "ps"),
                    opt = "nlm.fd", dims = c(5, 10), ords = NA,
                    analysis = F, trace = F, sp = NULL, tol = 1e-2, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }

    # initialization
    fit <- cq.reg(x, y, arg_bs, opt, dims, ords, sp = sp, ...)
    v_coef <- coef(fit)

    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(0, 1, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # get info
    v_pred <- predict(fit, dat)

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- scam(y ~ s(tau, x1, k = dims, m = ords, bs = arg_bs),
            data = dat, optimizer = opt, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # terminate
        s_diff <- norm_2(v_coef - coef(fit)) / norm_2(v_coef)
        v_coef <- coef(fit)
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        if (s_diff <= tol) break
        # get info
        v_pred <- fit$fitted.values
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}

#' Expectile Sheets(original)
#'
#' Expectile sheet
#'
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import mgcv
#'
#' @return a gam object
#'

es_gam <- function(x, y, maxit = 10, ntaus = 10,
                   dims = c(10, 10), ords = NA,
                   analysis = F, trace = F, sp = NULL, tol = 1e-3, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }
    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(0, 1, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # initialization
    fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
        data = dat, sp = c(sp), ...
    )
    v_coef <- coef(fit)

    # get info
    v_pred <- predict(fit, dat)

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
            data = dat, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # terminate
        s_diff <- norm_2(v_coef - coef(fit)) / norm_2(v_coef)
        v_coef <- coef(fit)
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        if (s_diff <= tol) break
        # get info
        v_pred <- fit$fitted.values
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}


# Imitating shot noise process according to:
# x(t) = sum(k=1:inf; g(t - sum(i=1:k; xi_i))) + sum(k=1:inf; g(t + sum(i=1:k; eta_i))),
# where g() - measured & absolutely integrated function,
# xi_i, eta_i - i.i.d.r.v. with Exp(1) distribution

g <- function(t)
{
  # g() - measured & absolutely integrated function to make x(t)
  g_scalar <- function(t)
  {
    if(t >= 0 && t <= 0.5)
      return(1)
    else
      return(0)
  }
  return(sapply(X = t, FUN = g_scalar))
}

ShotNoise <- function(t, num, inLambda = 1)
{
  # returns value of x(t)

  # auxiliary random variable to build process: xi or eta
  # 2 different calls of aux_rvar provides independency
  aux_rvar <- function(n = num, lambda = inLambda)
  {
    return(rexp(n, rate = lambda))
  }

  # X = X1 + X2
  X1 <- sum(g(t - cumsum(aux_rvar())))
  X2 <- sum(g(t + cumsum(aux_rvar())))
  X <- X1 + X2
  return(X)
}

EvaluateTail <- function(s, imitNum, over)
{
  # calculating P{max[X(t)]>=s} with imitation
  p <- 0
  for(i in 1:imitNum)
  {
    Sample <- sapply(over, ShotNoise, num = 100)
    M <- max(Sample)
    if(M >= s)
      p <- p + 1/imitNum
  }
  return(p)
}

library(ggplot2)
N <- 1000

Timeline = seq(from = 0, to = 10, by = 0.1)
ShotNoiseValues <- sapply(Timeline, ShotNoise, num = N)
qplot(x = Timeline,
      y = ShotNoiseValues,
      geom = "path",
      main = "Shot Noise Process",
      xlab = "t",
      ylab = "x(t)")
print("Calculated value for P{max[X(t)]>=3}:")
print(EvaluateTail(3, imitNum = N, over = Timeline))


# /**
# * Calculate p-value of hypergeometric test
# * $k : overlop number
# * $m : set 1 size
# * $n : set 2 size
# * $N : background size
# *               C(m,k) * C(N-m, n-k)
# * log(P) = log[----------------------]
# *                   C(N, n)
# *               m!/(k!(m-k)!) * (N-m)!/(n-k)!(N-m-n+k)!)
# *        = log[------------------------------------------]
# *                          N!/(n!(N-n)!)
# *        =   logfact(m) + logfact(N-m) + logfact(n) + logfact(N-n)
# *          - logfact(k) - logfact(m-k) - logfact(n-k) - logfact(N-m-n+k) - logfact(N)
# */
{{rimport}}('__init__.r')
library(methods)

infile  = {{i.infile | R}}
outfile = {{o.outfile | R}}
intype  = {{args.intype | R}}
N       = {{args.N | R}}
inopts  = update.list(list(rnames=T, cnames=T), {{args.inopts | R}})

ret    = matrix(nrow = 0, ncol = 5)
colnames(ret) = c('k', 'm', 'n', 'N', 'pval')

if (intype == 'raw') {
	rn     = if (inopts$rnames) 1 else NULL
	data   = read.table(infile, row.names = rn, header = inopts$cnames, sep = "\t", check.names = F)
	cnames = colnames(data)
	ncols  = ncol(data)
	if (is.null(N))
		N = nrow(data)
	if (ncols < 2)
		stop ('Need at least 2 columns.')
	if (!inopts$cnames) {
		cnames = paste0("COL", 1:ncols)
		colnames(data) = cnames
	}
	for (i in 1:(ncols-1)) {
		for (j in (i+1):ncols) {
			row       = list(k = NA, m = NA, n = NA, N = N, pval = NA)
			row$m     = sum(data[, i], na.rm = T)
			row$n     = sum(data[, j], na.rm = T)
			row$k     = nrow(data[which(data[, i] + data[, j] == 2), ])
			row$pval  = phyper(row$k, row$m, row$N-row$m, row$n, lower.tail = F)
			row.names = paste(cnames[i], 'vs', cnames[j], sep = '.')
			row       = as.data.frame(row)

			rownames(row) = row.names

			ret = rbind(ret, row)
		}
	}
} else {
	rn     = if (inopts$rnames) 1 else NULL
	data   = read.table(infile, row.names = rn, header = inopts$cnames, sep = "\t", check.names = F)
	cnames = colnames(data)
	ncols  = ncol(data)
	if (!inopts$cnames) {
		cnames = c('k', 'm', 'n', 'N')[1:ncols]
		colnames(data) = cnames
	}
	if (!'N' %in% cnames && is.null(N)) {
		stop('N is not specified neither in infile nor args.N.')
	}
	if (!'k' %in% cnames || !'m' %in% cnames || !'n' %in% cnames) {
		stop('Column k, m or n is missing.')
	}
	rnames = rownames(data)
	if (!inopts$rnames) {
		rnames = paste0('ROW', 1:nrow(data))
		rownames(data) = rnames
	}
	for (rname in rnames) {
		if ('N' %in% cnames) N = data[rname, 'N']
		row      = list(k = NA, m = NA, n = NA, N = N, pval = NA)
		row$m    = data[rname, 'm']
		row$n    = data[rname, 'n']
		row$k    = data[rname, 'k']
		row$pval = phyper(row$k, row$m, row$N-row$m, row$n, lower.tail = F)
		row      = as.data.frame(row)

		rownames(row) = rname
		ret = rbind(ret, row)
	}
}

write.table(
	pretty.numbers(ret, formats = list(pval = '%.2E')),
	outfile, quote = F, row.names = T, col.names = T, sep = "\t"
)


population<-c(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
#  There are 45 possible samples of 2 items selected from the 10 items.
combn(population, 2)
samps<-combn(population, 2)
xbars <- colMeans(samps)
table(xbars)
prop.table(table(xbars))


labMarketOD <- function(N,sal_res,OD){
  if(OD == "o"){
    func = 0.5*N
    func[func<sal_res] = sal_res
  } else{
    func = 57-0.5*N
  }
  return(func)
}

laborMarketPlot <- function(input,output,values){
  emp_level = seq(0,100,length.out = 100)
  to_plot = data.frame(emp_level = emp_level)

  eqNo = (input$W)/(0.5*values$p)
  eqNstar = labMarketOD(values$eq$Nstar,input$sal_res,"o")

  fig = plot_ly(to_plot, x = ~emp_level)
  fig = fig %>% add_trace(y = labMarketOD(emp_level,input$sal_res,"o"), type = "scatter", mode = "lines", name = "$$N^s(N)$$", line = list(color = "blue"),
                          hovertemplate = paste("Ns=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_trace(y = labMarketOD(emp_level,input$sal_res,"d"), type = "scatter", mode = "lines", name = "$$N^d(N)$$", line = list(color = "red"),
                          hovertemplate = paste("Nd=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(0,input$W/values$p,values$eq$subN,input$W/values$p, line = list(color = 'blue', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN,input$W/values$p,values$eq$N,input$W/values$p, line = list(color = 'green', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$N,input$W/values$p,eqNo,input$W/values$p, line = list(color = 'grey', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN,0,values$eq$subN,input$W/values$p, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_trace(x = values$eq$subN, y = input$W/values$p, mode = "markers", marker = list(color = "blue"), showlegend = F,
                          hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$Nstar,0,values$eq$Nstar,eqNstar, line = list(color = 'rgb(200,0,0)', width = 1, dash = 'dash'), showlegend = F,
                             hovertemplate = paste("N*=%{x:.0f}","
(W/p)*=%{y:.0f}","<extra></extra>"))

  if(abs(values$eq$Nstar - values$eq$N) >= 5 & abs(values$eq$subN - values$eq$N) >= 5){
    x_label = c(values$eq$Nstar,values$eq$N,values$eq$subN)
    y_label = c(eqNstar,input$W/values$p,input$W/values$p)
    text_label = c(paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1)),paste0("N=",round(values$eq$N)),paste0("N=",round(values$eq$subN)))
  } else if(abs(values$eq$Nstar - values$eq$N) >= 5 & abs(values$eq$subN - values$eq$N) <= 5){
    x_label = c(values$eq$Nstar,values$eq$N)
    y_label = c(eqNstar,input$W/values$p)
    text_label = c(paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1)),paste0("N=",round(values$eq$N)))
  } else if(abs(values$eq$Nstar - values$eq$N) <= 5 & abs(values$eq$subN - values$eq$N) >= 5){
    x_label = c(values$eq$Nstar,values$eq$subN)
    y_label = c(eqNstar,input$W/values$p)
    text_label = c(paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1)),paste0("N=",round(values$eq$subN)))
  } else{
    x_label = c(values$eq$Nstar)
    y_label = c(eqNstar)
    text_label = paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1))
  }
  eq_label = list(
    x = x_label,
    y = y_label,
    text = text_label
  )
  fig = fig %>% layout(annotations = eq_label)

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  empLevel <- list(
    title = "Niveau d'emploi, N",
    titlefont = f
  )
  salReels <- list(
    title = "Salaires réels, W/p",
    titlefont = f
  )
  fig = fig %>% layout(xaxis = empLevel, yaxis = salReels)
}

margCost = function(N,w){
  return(w/(-N^0.6+13)+5)
}

firmEqPlot <- function(input,output,values){
  N = seq(0,70,length.out = 1000)
  to_plot = data.frame(emp_level = N)

  eqRev = margCost(values$eq$N,input$W/values$p)#*values$p
  subEqRev = margCost(values$eq$subN,input$W/values$p)
  fig = plot_ly(to_plot, x = ~emp_level)
  fig = fig %>% add_trace(y = margCost(N,input$W/values$p), type = "scatter", mode = "lines", name = "$$N^s(N)$$", line = list(color = "red"),
                          hovertemplate = paste("N=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(0,eqRev,98,eqRev, line = list(color = 'blue', width = 1), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN,0,values$eq$subN,subEqRev, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN, subEqRev, values$eq$subN, eqRev,  line = list(color = "green", width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN, subEqRev, values$eq$N, subEqRev,  line = list(color = "green", width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$N, 0, values$eq$N, eqRev,  line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))

  if(abs(values$eq$subN - values$eq$N) > 5){
    x_label = c(values$eq$N,values$eq$subN)
    y_label = c(eqRev,subEqRev)
    text_label = c(paste0("N=",round(values$eq$N)),paste0("N=",round(values$eq$subN)))
  } else{
    x_label = c(values$eq$N)
    y_label = c(eqRev)
    text_label = paste0("N=",round(values$eq$N))
  }
  eq_label = list(
    x = x_label,
    y = y_label,
    text = text_label
  )
  fig = fig %>% layout(annotations = eq_label)

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  empLevel <- list(
    title = "Niveau d'emploi, N",
    titlefont = f,
    range = c(0,70)
  )
  revCosts <- list(
    title = "Revenus et Couts",
    titlefont = f,
    range = c(0,40)
  )
  fig = fig %>% layout(xaxis = empLevel, yaxis = revCosts)

}


#############################################################################
#
# Mark Cembrowski, Janelia Research Campus, April 3 2015
#
# This script plots the number of D-V enriched genes in DG granule cells.
#
#############################################################################

dgDv <- function(fpkmThres=10){

	theFolds <- c(3:10)
	df <- as.data.frame(matrix(nrow=theFolds,ncol=2))
	for (ii in 1:length(theFolds)){
		df[ii,] <- .dgFold(theFolds[ii],fpkmThres)
	}
	total <- df[,1]+df[,2]
	df <- cbind(theFolds,df,total)
	rownames(df) <- theFolds
	colnames(df) <- c('theFolds','dorsal','ventral','total')

	print(df)

	# Plot.
	gg <- ggplot(df,aes(x=theFolds))
	gg <- gg + geom_line(aes(y=dorsal),colour='green')
	gg <- gg + geom_line(aes(y=ventral),colour='magenta')
	gg <- gg + geom_line(aes(y=total),colour='black')
	gg <- gg + theme_bw()
	gg <- gg + expand_limits(y=0)
	gg <- gg + xlab('Fold difference') + ylab('Number of genes')
	print(gg)
}

# details = F: return only numbers of genes, or gene names as well?
.dgFold <- function(theFold,fpkmThres,details=F){
	# Get genes that are enriched in either direction with the fold thres.
	dgMat <- fpkmPoolMat[,c('dg_d','dg_v')]
	dgThres <- apply(dgMat,1,max)>fpkmThres
	dgMat <- dgMat[dgThres,]

	dgRat <- dgMat$dg_d/dgMat$dg_v

	dgD <- sum(dgRat>theFold)
	dgDNames <- idToSym(rownames(dgMat)[dgRat>theFold])
	dgV <- sum(dgRat<(1/theFold))
	dgVNames <- idToSym(rownames(dgMat)[dgRat<(1/theFold)])

	if(!details){
		invisible(c(dgD,dgV))
	}else{
		dgNames <- c(dgDNames,dgVNames)
		dgEnriched <- c(rep('dorsal',length(dgDNames)),rep('ventral',length(dgVNames)))
		theOut <- cbind(dgNames,dgEnriched)

		dgFpkm <- fpkmPoolMat[rownames(theOut),c('dg_d','dg_v')]
		dgFold <- dgFpkm$dg_d/dgFpkm$dg_v
		dgFold <- pmax(dgFold,1/dgFold)

		theOut <- cbind(theOut,dgFpkm,dgFold)

		# Put into order of fold change.
		theOutD <- subset(theOut,dgEnriched=='dorsal')
		theOutD <- theOutD[order(-theOutD$dgFold),]
		theOutV <- subset(theOut,dgEnriched=='ventral')
		theOutV <- theOutV[order(-theOutV$dgFold),]
		theOut <- rbind(theOutD,theOutV)

		invisible(theOut)
	}
}


#volume of a donut

r <- 3 #minor radius of the donut

R <- 6 #major radius of the donut

#circumference of the donut

circum_inner <- 2*pi*R

#cylindrical area of the donut
area <- pi*(r^2)

#volume = area * circumference

volume <- area * circum_inner

print(volume)


require(Hmisc)
n <- 100
set.seed(1)
y <- sample(0:8, n, TRUE)
x1 <- runif(n)
x2 <- runif(n)
x2[1:10] <- NA
z <- sample(1:20, n, TRUE)
d <- data.frame(y, x1, x2, z)
f1 <- glm(y ~ x1 + x2, family=poisson)
f2 <- glm(y ~ x1 + x2 + offset(log(z)), family=poisson)

a <- aregImpute(~ y + x1 + x2)
g1 <- fit.mult.impute(y ~ x1 + x2 , glm, a,
	family=poisson, data=d)
g2 <- fit.mult.impute(y ~ x1 + x2 + offset(log(z)), glm, a,
	family=poisson, data=d)
# g3 <- fit.mult.impute(y ~ x1 + x2 + offset(log(z)), Glm, a, family=poisson, data=d)
coef(g1)
coef(g2)
# coef(g3)
coef(f1)
coef(f2)


#impoting dataset
dataset = read.csv('Experience.csv')
# dataset = dataset[, 2:3]

#Splitting the Dataset into Training set and Test set
#install.packages('caTools')
library(caTools)
set.seed(123)
split = sample.split(dataset$Salary, SplitRatio = 2/3)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

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

# Fittring SLR to the Training set
regressor = lm(formula = Salary ~ YearsExperience, data = training_set)

# Predicting the Test set result
y_pred = predict(regressor, newdata = test_set)

#Visualizing the Training set results
#install.packages('ggplot2')
# library(ggplot2)
ggplot() +
  geom_point(aes(x = training_set$YearsExperience, y = training_set$Salary),
             colour = 'red') +
  geom_line(aes(x = training_set$YearsExperience, y = predict(regressor, newdata = training_set)),
            colour = 'blue') +
  ggtitle('Salary vs Experience (Training set)') +
  xlab('Years of Experience') +
  ylab('Salary')
# Visualizing the test set
ggplot() +
  geom_point(aes(x = test_set$YearsExperience, y = test_set$Salary),
             colour = 'red') +
  geom_line(aes(x = training_set$YearsExperience, y = predict(regressor, newdata = training_set)),
            colour = 'blue') +
  ggtitle('Salary vs Experience (Test set)') +
  xlab('Years of Experience') +
  ylab('Salary')