library(shiny)
library(rsconnect)
library(ggplot2)

#############################################################
# Set the baseline parameters
#############################################################
base_sI <- .2
base_gL <- .01
base_gA <- .02
base_delta <- .05
base_alpha <- .3
base_A <- 1
base_kystar <- base_sI/(base_gL+base_gA+base_delta)
base_K <- base_kystar^(1/(1-base_alpha))
base_timeT <- 50

#############################################################
# Define UI ----
#############################################################
ui <- fluidPage(
  withMathJax(),
  titlePanel("Basic Solow Model"),

  sidebarLayout(
    sidebarPanel(

      h4("Set parameters"),
      actionButton("reset", "Reset to baseline"),
      sliderInput("alt_sI", h6('New capital share of GDP \\(s_I\\)'),
                  min = 0, max = 1, value = base_sI),
      sliderInput("alt_gL", h6("Population growth rate \\(gL\\)"),
                  min = -.1, max = .1, value = base_gL),
      sliderInput("alt_gA", h6("Productivity gorwth rate \\(gA\\)"),
                  min = -.1, max = .1, value = base_gA),
      sliderInput("alt_delta", h6("Depreciation rate \\(\\delta\\)"),
                  min = 0, max = 1, value = base_delta),
      sliderInput("alt_alpha", h6("Capital elasticity \\(\\alpha\\)"),
                  min = 0, max = 1, value = base_alpha),
      sliderInput("alt_K", h6("Initial capital stock \\(K_0\\)"),
                  min = 0, max = 10, value = base_K,step = 0.1),
      sliderInput("alt_A", h6("Initial Productivity \\(A_0\\)"),
                  min = 0, max = 10, value = base_A, step = 0.1),
      sliderInput("timeT", h6("Number of periods"),
                  min = 0, max = 300, value = base_timeT, step = 1)
      ), # end sidebar panel

    mainPanel(

      tabsetPanel(type = "tabs",
                  tabPanel("K/Y ratio",
                           br(),
                           p("The baseline is that the economy is on a BGP, so the actual K/Y is constant.
                             As you adjust the parameters to the left, there may be a new BGP, or actual K/Y may
                             not be on the BGP any more. Black graphs the actual path of K/Y, blue the baseline BGP,
                             and green is the new BGP based on your choice of parameters."),
                           br(),
                           p("Be sure you understand why some adjustments to parameters create a new BGP, and why
                             some adjustments only push actual K/Y off of the BGP."),
                           plotOutput("kygraph",width = "100%") ),
                  tabPanel("Log GDP p.c.",
                           br(),
                           p("This has the same idea the K/Y ratio. Black is the actual path of GDP per capita.
                             Green is the BGP from the parameters you set, and blue is the original BGP."),
                           br(),
                           plotOutput("lnygraph",width = "100%") ),
                  tabPanel("Growth rate",
                           br(),
                           p("The colors work the same with the growth rate of GDP per capita. Make sure you
                             understand how this growth rate is related to the path of log GDP per capita."),
                           br(),
                           plotOutput("gygraph",width = "100%") ),
                  tabPanel("K/Y dynamics",
                           br(),
                           p("This graph is different. It shows the relationship of the growth rate in K/Y and
                             the level of K/Y. The negative slope established the stability of the Solow model.
                             Changes in some parameters shift the theoretical curves here, implying different
                             steady state K/Y ratios where the growth rate is zero."),
                           br(),
                           p("The black dots indicate the actual K/Y ratio and growth rate over time. In the
                             baseline, all these dots are at the steady state point. If you adjust parameters
                             you'll see these spread out and show you how K/Y and the growth rate of K/Y evolved.
                             See how they follow the green path based on the new BGP."),
                           br(),
                           plotOutput("gkygraph",width = "100%") )
      ) # end tabset

      ) # end main panel
  ) # end ui
)
#############################################################
# Define server logic ----
#############################################################
server <- function(input, output, session) {

  # Reset parameters
  observeEvent(input$reset, {
    updateSliderInput(session,'alt_sI',value = base_sI)
    updateSliderInput(session,'alt_gL',value = base_gL)
    updateSliderInput(session,'alt_gA',value = base_gA)
    updateSliderInput(session,'alt_delta',value = base_delta)
    updateSliderInput(session,'alt_alpha',value = base_alpha)
    updateSliderInput(session,'alt_K',value = base_K)
    updateSliderInput(session,'alt_A',value = base_A)
    updateSliderInput(session,'timeT',value = base_timeT)
  })

  # Simple function to calculate the new  steady state K/Y ratio for display
  output$kystar <- renderText(
    {
    paste("K/Y*:",
          input$alt_sI/(input$alt_delta+input$alt_gA+input$alt_gL))
    }
  )

  # Function to combine alternative and baseline inputs, generate dataframe
  # containing time series of outcomes
  GraphData <- reactive({
    t <- c(0:input$timeT) # vector of periods up to input time
    df <- data.frame(t) # create dataframe to hold outcomes
    alt_kystar <- input$alt_sI/(input$alt_delta+input$alt_gA+input$alt_gL) # alt ss KY
    alt_ky <- (input$alt_K/input$alt_A)^(1-input$alt_alpha) ## actual starting KY

    # Formula to fill in per-period actual KY ratio
    df$ky <- alt_kystar*(1-exp(-(1-input$alt_alpha)*(input$alt_delta+input$alt_gA+input$alt_gL)*df$t)) + alt_ky*exp(-(1-input$alt_alpha)*(input$alt_delta+input$alt_gA+input$alt_gL)*df$t)

    df$kyalt <- alt_kystar # fill df with alt ss KY
    df$kybase <- base_kystar # fill df with base ss KY

    # Fill df with series on log GDP per capita
    df$lny <- (input$alt_alpha/(1-input$alt_alpha))*df$ky + log(input$alt_A) + input$alt_gA*df$t
    df$lnyalt <- (input$alt_alpha/(1-input$alt_alpha))*df$kyalt + log(input$alt_A) + input$alt_gA*df$t
    df$lnybase <- (base_alpha/(1-base_alpha))*df$kybase + log(base_A) + base_gA*df$t

    # Fill df with series on growth rate of GDP per capita
    df$gky <- (1-input$alt_alpha)*(input$alt_sI/df$ky-input$alt_gL -input$alt_gA- input$alt_delta)
    df$gy <- (input$alt_alpha/(1-input$alt_alpha))*df$gky + input$alt_gA
    df$gyalt <- input$alt_gA
    df$gybase <- base_gA

    df$tick <- df$ky # for graphing purposes later
    return(df)
  })

  output$kygraph <- renderPlot(
    {
      ggplot(GraphData(), aes(t,value,colour=variable)) +
        geom_line(aes(y = ky, color = "black"),size=1) +
        geom_line(aes(y = kybase, color="blue"), linetype="dashed",size=1) +
        geom_line(aes(y = kyalt, color="green"), linetype="dashed",size=1) +
        xlab("Time") +
        ylab("Capital/output ratio") +
        ylim(0, 5) +
        theme_light() +
        ggtitle("Capital/output ratio over time") +
        scale_color_identity(name = "Models",
                             breaks = c("black", "green", "blue"),
                             labels = c("Actual", "New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end ky graph

  output$lnygraph <- renderPlot(
    {
      ggplot(GraphData(), aes(t,value,colour=variable)) +
        geom_line(aes(y = lny, color = "black"),size=1) +
        geom_line(aes(y = lnybase, color="blue"), linetype="dashed",size=1) +
        geom_line(aes(y = lnyalt, color="green"), linetype="dashed",size=1) +
        xlab("Time") +
        ylab("Log GDP per capita") +
        ylim(0, 3) +
        theme_light() +
        ggtitle("GDP per capita over time") +
        scale_color_identity(name = "Models",
                             breaks = c("black", "green", "blue"),
                             labels = c("Actual", "New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end lny graph

  output$gygraph <- renderPlot(
    {
      ggplot(GraphData(), aes(t,value,colour=variable)) +
        geom_line(aes(y = gy, color = "black"),size=1) +
        geom_line(aes(y = gybase, color="blue"), linetype="dashed",size=1) +
        geom_line(aes(y = gyalt, color="green"), linetype="dashed",size=1) +
        xlab("Time") +
        ylab("Growth rate of GDP p.c.") +
        theme_light() +
        ylim(-.05, .07) +
        ggtitle("Growth rate of GDP p.c. over time") +
        scale_color_identity(name = "Models",
                             breaks = c("black", "green", "blue"),
                             labels = c("Actual", "New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end gy graph

  output$gkygraph <- renderPlot(
    {
      tick <- seq(0,6,.1) # arbitrary kal values
      df <- data.frame(tick) # create dataframe
      df$gky <- (1-input$alt_alpha)*(input$alt_sI/df$tick-input$alt_gL -input$alt_gA- input$alt_delta)
      df$gkybase <- (1-base_alpha)*(base_sI/df$tick-base_gL -base_gA- base_delta)
      alt_kystar = (input$alt_sI/(input$alt_gL + input$alt_gA + input$alt_delta))

      ggplot(df, aes(x=tick)) +
        geom_line(aes(y = gky, color = "green"),size=1) +
        geom_line(aes(y = gkybase, color="blue"), linetype="dashed",size=1) +
        geom_point(data=GraphData(),y=GraphData()$gky, color="black") +
        geom_hline(yintercept=0, linetype="dotted", color = "red") +
        geom_vline(xintercept=base_kystar, linetype="dotted", color = "red") +
        geom_vline(xintercept=alt_kystar, linetype="dotted", color = "red") +
        xlab("K/Y ratio") +
        ylab("Growth rate of K/Y") +
        theme_light() +
        ylim(-.1,.15) +
        ggtitle("Growth rate of K/Y vs. K/Y") +
        scale_color_identity(name = "Models",
                             breaks = c("green", "blue"),
                             labels = c("New BGP", "Old BGP"),
                             guide = "legend")
    }
  ) # end gky graph

} # end server

# Run the app ----
shinyApp(ui = ui, server = server)


# intersects line x+t*v with G*x<h polytope
# returns: c(X1,minT), where X1 is the intersection points, and minT is the T values at intersection point..
intersectLineWithPlanes <- function(G,h,X,V){

  #hGX= ( G %*% X )  - h
  hGX = sweep( -G %*% X , 2 , h, '+',check.margin = FALSE)

  T = hGX / G %*% V

  T[T<0] = Inf

  minT = apply(T,2,min)

  X1 = sweep( X , 2 , V %*% minT , '+',check.margin = FALSE)

  #ret = c(X1,minT)
  ret = vector('list',2);
  ret[[1]] = X1
  ret[[2]] = minT
  return(ret);
}

# compute hr step
hrstep_unif <- function (G,h,X) {

  d=ncol(G)
  m=nrow(G)
  n=ncol(X);

  # compute random directions:
  vr = matrix(rnorm(n*d),nrow=d)
  vr = vr / apply(vr,2,sum)

  # compute intersections:
  tbr = intersectLineWithPlanes(G,h,X,vr)
  tar = intersectLineWithPlanes(G,h,X,-vr)
  ta = -tar[[2]]
  tb = tbr[[2]]

  # compute random new points:
  r01 = matrix(runif(n))
  t01 = ta + (tb-ta) * t(r01)

  Xnext = X + sweep( vr , 2 , t01 , '*')# ( t01 * vr )
  return(Xnext)
}

# performs hr step, using a trivial method to estimate 1d density
# ns2d is number of samples for 1d density estim
hrstep_01 <- function (G,h,f,X,ns1d) {
  d=ncol(G)
  m=nrow(G)
  n=ncol(X);

  # compute random directions:
  vr = matrix(rnorm(n*d),nrow=d)
  vr = vr / repmat(colSums(vr^2),d,1)

  # compute intersections:
  tbr = intersectLineWithPlanes(G,h,X,vr)
  tar = intersectLineWithPlanes(G,h,X,-vr)
  ixa = tar[[1]]
  ixb = tbr[[1]]

  # compute random new points:
  uu = runif(n)
  #loop over samples and process each separately..
  for(zi in 1:n){
    #xx = sweep( ixa[,zi,drop=FALSE] , 2 , sweep( (ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]),2, seq(0,1,length=(ns1d+2)) ,'*' ) , '+')
    #xx = bsxfun( '+' , ixa[,zi,drop=FALSE] , bsxfun('*',(ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]),seq(0,1,length=(ns1d+2))) )
    #xx = outer( (ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]),seq(0,1,length=(ns1d+2)) )
    xx = repmat( ixa[,zi,drop=FALSE] , 1 , ns1d+2 ) +  ( (ixb[,zi,drop=FALSE]-ixa[,zi,drop=FALSE]) %*% seq(0,1,length=(ns1d+2)) )
    ff   = apply(xx[,-c(1,ns1d+2)],2,f)
    ffcs = cumsum(ff);
    ffcs = ffcs / tail(ffcs,1)

    # now draw unif. rd to get next point:
    u  = uu[zi];
    # find first entry larger than u
    ux = min(which(ffcs>u))
    # par(mfrow=c(2,1)); plot(ff); plot(ffcs)
    # pos now is: center of xx[ux] andxx[ux+1]
    xn = 0.5*(xx[,ux] + xx[,ux+1])

    X[,zi] = xn
  }
  return(X)
}

# compute hr steps
# nsteps
hr_unif <- function(G,h,X,nsteps) {

  cs = 0
  XX = vector('list',length(nsteps))

  ii = 1;
  for(nsi in nsteps){
    stepsi = nsi-cs;
    for( zi in 1:stepsi ){
      X = hrstep_unif(G,h,X)
    }
    XX[[ii]] = X;
    ii = ii+1
    cs = nsi;
  }
  return(XX);
}

hr <- function(G,h,f,X,nsteps,ns1d) {

  cs = 0
  XX = vector('list',length(nsteps))

  ii = 1;
  for(nsi in nsteps){
    stepsi = nsi-cs;
    for( zi in 1:stepsi ){
      X = hrstep_01(G,h,f,X,ns1d)
    }
    XX[[ii]] = X;
    ii = ii+1
    cs = nsi;
  }
  return(XX);
}


# Utilities - basics

# 1. Mathematical
# round: round the values to 0 decimal places by default

# The errors vector has already been defined for you
errors <- c(1.9, -2.6, 4.0, -9.5, -3.4, 7.3)

# Sum of absolute rounded values of errors
sum(abs(round(errors)))

# 2. Data
# seq(): Generate sequences, by specifying the from, to, and by arguments.
# rep(): Replicate elements of vectors and lists.
# sort(): Sort a vector in ascending order. Works on numerics, but also on character strings and logicals.
# rev(): Reverse the elements in a data structures for which reversal is defined.
# str(): Display the structure of any R object.
# append(): Merge vectors or lists.
# is.*(): Check for the class of an R object.
# as.*(): Convert an R object from one class to another.
# unlist(): Flatten (possibly embedded) lists to produce a vector.

# The linkedin and facebook lists have already been created for you
linkedin <- list(16, 9, 13, 5, 2, 17, 14)
facebook <- list(17, 7, 5, 16, 8, 13, 14)

# Convert linkedin and facebook to a vector: li_vec and fb_vec
li_vec <- unlist(linkedin)
fb_vec <- unlist(facebook)

# Append fb_vec to li_vec: social_vec
social_vec <- append(li_vec, fb_vec)

# Sort social_vec
rev(sort(social_vec))

# Fix me - had to switch the two functions into the correct order
rep(seq(1, 7, by = 2), times = 7)

# Create first sequence: seq1
seq1 <- seq(1, 500, by = 3)

# Create second sequence: seq2
seq2 <- seq(1200, 900, by = -7)

# Calculate total sum of the sequences
sum(append(seq1, seq2))


# install.packages("rARPACK")
library(logisticPCA)
library(ggplot2)
amn <- read_csv("datasets/Asheville/amn.csv")
logpca_model = logisticPCA(amn, k = 16, m = 10)
write.table(logpca_model$PCs, "datasets/Asheville/amn_PCAed.csv",
            row.names = FALSE, col.names = FALSE, sep=',')

write.table(logpca_model$U, "datasets/Asheville/amn_PCAed_U.csv",
            row.names = FALSE, col.names = FALSE, sep=',')

# clogpca_model = convexLogisticPCA(amn, k = 16, m = 10)
#logpca_cv = cv.lpca(house_votes84, ks = 2:16, ms = 1:10, quiet = FALSE)#
#plot(logpca_cv)

#logpca_k16_cv = cv.lpca(house_votes84, ks = 16, ms = 1:60, quiet = FALSE)#
#plot(logpca_k16_cv)

#logpca_k2_cv = cv.lpca(house_votes84, ks = 2, ms = 1:20, quiet = FALSE)#
#plot(logpca_k2_cv)

#logpca_k8_cv = cv.lpca(house_votes84, ks = 8, ms = 1:20, quiet = FALSE)#
#plot(logpca_k8_cv)

df = as.data.frame(logpca_model$U)

df$idu <- as.numeric(row.names(df))

library(reshape2)
df_melten <- melt(df, id.vars="idu")

df_melten$value = abs(df_melten$value)

ggplot(df_melten, aes(idu, value, col=variable)) + geom_line()

df_melten_thresheld = df_melten[(df_melten$value>.3),]

ggplot(df_melten_thresheld, aes(idu, value)) +
   geom_line() +
   facet_wrap(~variable)
library(dplyr)
group_by(df_melten_thresheld, variable)


#' Function to return the magnificent seven statistics for a given data series
#' @param x A dataframe containing a vector of date values in the first column and vector of numeric flow values in the second column.
#' @param yearType A charcter of either "water" or "calendar" indicating whether to use water years or calendar years, respectively.
#' @param digits A numeric. Number of digits to round indice values
#' @return data.frame of calculated statistics
#' @details This is a function to compute the 7 statistics of daily streamflow
#' used by Archfield et al., under revision (June 2013).
#' @importFrom lubridate month
#' @importFrom lubridate year
#' @importFrom lmom .samlmu
#' @export
#' @examples
#' x<-sampleData[c("date","discharge")]
#' magSeven <- calc_magnifSeven(x)
calc_magnifSeven<-function(x,yearType = "water",digits=3)  {

        #Check data inputs
        x <- validate_data(x,yearType = yearType)

        #calculate some stuff for use later
        x$month_val <- lubridate::month(x$date)

        #Compute L-moment ratios for time series so consistent in function
        complmom <- lmom::.samlmu(x$discharge)
        complmom[2] = complmom[2] / complmom[1]
        complmom = round(complmom, digits=2)
        lam1<-complmom[1]
        tau2<-complmom[2]
        tau3<-complmom[3]
        tau4<-complmom[4]

        #Compute AR(1) correlation coefficienct
        calc_ar1v<-calc_ar1(x,yearType = yearType,digits=digits)

        get_seasonality_vars <- get_seasonality(x, yearType = yearType)
        amplitude<-get_seasonality_vars[1]
        phase<-get_seasonality_vars[2]

        #Combine all indices into 1 dataframe and return
        magnif7 <- data.frame(indice = c("lam1","tau2","tau3","tau4","ar1","amplitude","phase"),
                            statistic = c(lam1,tau2,tau3,tau4,calc_ar1v,amplitude,phase),
                            stringsAsFactors = F)

        magnif7$statistic <- round(magnif7$statistic,digits=digits)

        return(magnif7)
}


#### break / next

## Comando "break"

# Debido a que es un comando especial, es necesario usar comillas para
# acceder a la ayuda:
?"break"

# Como se puede sospechar por el nombre, break sirve para interrumpir un
# loop. Por ejemplo:
for (i in 1:10) {
  print(i)
  break
}
i
# Imprime sólo el primer valor, luego es interrumpido.

# Combinado con if, sirve para interrumpir en el momento que ocurre
# alguna situación en particular. Por ejemplo, quiero interrumpir el loop
# anterior cuando i llegue al 7
for (i in 1:10) {
  print(i)
  if (i >= 7)
    break
}

## Combinar "break" con "repeat"

# Como se mencionó brevemente, el comando "repeat" es otro tipo de loop que se
# puede usar en R. Es el más simple de todos: se limita a repetir un comando
# hasta que el usuario de una orden de finalización. Una forma de determinar
# la finalización es usando un "break". Usando uno de los ejemplos de la
# lección de "while", la serie que tiende a cero:
# f(n) = f(n - 1) / n
# f(0) = 5
# Se puede expresar así con "repeat":
f <- 5 # Valor inicial
n <- 0
repeat {
  n <- n + 1 # n es el número de elementos + 1, actua como un contador, el cual
  # comienza en 0
  f <- f / n # f depende del valor del f anterior el cual se relaciona con n
  print(f)
  if (f <= 0.001) # en este caso el límite se lo da el comado if
    break
}

# Esto debería hacer exactamente lo mismo que el ejemplo dado en la lección
# mencionada:
f <- 5 # Valor inicial
n <- 0
while (f > 0.001) { # en este caso el límite lo hace por defecto el comando
                   # while
  n <- n + 1
  f <- f / n
  print(f)
}

## Comando "next"

# El comando "next" también genera una interrupción, pero no en todo el
# loop, si no de la iteración en la que se encuentra el mismo.
?"next"

# Por ejemplo, usando un if + next se puede modificar el ejemplo inicial
# para que se impriman todos los números menos el 4
for (i in 1:10) {
  if (i == 4)
    next
  print(i)
}

# Para imprimir sólo los impares
for (i in 1:10) {
  if (i %% 2 == 0) # (¿qué hace el %%?)
    next
  print(i)
}

# Para no imprimir 4:7
for (i in 1:10) {
  if (i %in% 4:7)
    next
  print(i)
}

# El uso de break y next no es tan extendido, pero es muy útil cuando
# realmente es necesario, evitando que se prolonguen las iteraciones, y
# que se hagan cálculos innecesarios.


# Function definitions for the normal-inverse-gamma distribution.
# The parameters of the distribution (mu, lambda, alpha, beta) are as defined here:
# https://en.wikipedia.org/wiki/Normal-inverse-gamma_distribution

# NOTE: The functions below require the function definitions in invgamma.r

dnorminvgamma <- function(x, sigma2, mu, lambda, alpha, beta) {
    # The pdf of the normal-inverse-gamma distribution at x (mean) and sigma2 (variance).
    return(dnorm(x, mu, sqrt(sigma2 / lambda)) * dinvgamma(sigma2, alpha, beta));
}

rnorminvgamma <- function(n, mu, lambda, alpha, beta) {
    # Draw n samples from the normal-inverse-gamma distribution.
    # Returns a matrix where each column contains a (x, sigma2) sample.
    sigma2 = rinvgamma(n, alpha, beta);  # Sample sigma^2 from the inverse-gamma
    x = rnorm(n, mu, sqrt(sigma2 / lambda));  # Sample x from the normal
    return(t(matrix(c(x, sigma2), nrow=n, ncol=2)));
}


# testAllocationOptimisation.r

library(matrixcalc)
#library(matlib)
###

# Cost of RAT, RT-PCR, IgG antibody in 1000 rupees
testCosts = c(0.45, 1.6, 0.30)

# Set the guessed prevalence for local c-optimal design
p = c(0.1,0.3,0.01)

# The set of test types and test outcomes
txset= read.csv("../data/inputs/ratrtpcrabvec.csv", header=T)

# Diseasestate - response map. Read and delete the row names.
highs= read.csv("../data/inputs/ratrtpcrabhighs.csv", header=T)
highs = highs[-c(1)]

## Global sensitivity and specificity
## 1=RAT,2=RTPCR,3=AB
Spec = c(0.975,0.97,0.977)
Sen  = c(0.5,0.95,0.921)

# This function estimates q_t(x;p), the probability of seeing test outcome x
# when test type is t and the disease prevalence vector is p.
# p = c(p[1], p[2], p[3]). ActiveInfection, ActiveABonly, ActiveForBoth
# Last state carries the remaining probability.
qxp = function(x,p){
  # Structure of x and p : x = ("0", "1", ""), p = (0.1, 0.2, 0.3)x
  output = 0
  prod = c(1,1,1,1)
  for(j in 1:3){
    if(x[j]=="0"){
      for(i in 1:4) {
        # For state i, test j, if correct response highs[i,j] is 1,
        # this is a sensitivity error.
        # If correct response is 0, this is correct specificity.
        prod[i] = prod[i]*(highs[i,j]*(1-Sen[j]) + (1-highs[i,j])*Spec[j])
      }
    }
    if(x[j]=="1"){
      for(i in 1:4) {
        # See explanation above
        prod[i] = prod[i]*(highs[i,j]*Sen[j] + (1-highs[i,j])*(1-Spec[j]))
      }
    }
  }
  r = c(p, 1-sum(p))
  # log-probability, gradients[3], probability
  output=c(log(sum(prod*r)), prod[1]-prod[4], prod[2]-prod[4], prod[3]-prod[4], sum(prod*r))
}

###Fisher information for a test pattern
getPatternFisherInfo = function(p, t){
  x = txset[-c(1)]
  # Compute the Fisher information matrix, weighted
  I = diag(c(0,0,0))
  #if ((t==4) | (t==6) | (t==8)) { # Uncomment this line if RTPCR is free.
  for(i in 1:3) {
    for (j in i:3) {
      sx = subset(x, txset$Test.Type==t)
      v2=0
      for(k in 1:nrow(sx)){
          y =c(sx[k,])
          Q=qxp(y,p) #Q[2:4] are gradients. Q[5] is probability
          v2 = v2 + ((Q[1+i])*Q[1+j])/(Q[5])
      }
      I[i,j] = v2
      I[j,i] = v2
    }
  }
  #} # Uncomment this line if RTPCR is free.
  out = I
}

###Weighted Fisher information
getWeightedFisherInfo = function(p, wsub, pcost){

  # Identify test types
  ttype = unique(txset$Test.Type)
  w = c(0,wsub)

  # t=1, initialisation
  I = diag(c(0,0,0))
  for(t in 2:length(ttype)){
    widx = t-1
    I = I + w[t]*getPatternFisherInfo(p,t)/pcost[widx]
  }
  out = I
}

getCosting = function(costvec){
  ttypevalid = cbind(txset$Test.Type, 1-as.numeric(is.na(txset$RAT)), 1-as.numeric(is.na(txset$RTPCR)), 1-as.numeric(is.na(txset$AB)))
  ttypevalid = unique(ttypevalid)
  out = ttypevalid[,-1] %*% costvec
}

varfun = function(wsub){
  I = getWeightedFisherInfo(p,wsub,patternCost)
  J = matrix.inverse(I)
  u = c(1,1,1)
  out = t(u) %*% J %*% u
  out
}

vargrad = function(wsub){
  I = getWeightedFisherInfo(p,wsub,patternCost)
  J = matrix.inverse(I)
  u = c(1,1,1)
  mygrad = rep(0,length(wsub))
  tmax = length(wsub)+1 # wsub and w = (0, wsub)
  for (widx in 1:length(wsub)) {
    # Index of pattern is 1 more than idx, since the first one is dropped
    t = widx+1
    patternFisherInfoGradWeighted = getPatternFisherInfo(p,t)/patternCost[widx]
    mygrad[widx] = -t(u) %*% J %*% patternFisherInfoGradWeighted %*% J %*% u
  }
  out = mygrad
}

patternCost = getCosting(testCosts)
patternCost = patternCost[-1]

#Initialise to uniform test patterns. Ensure interior point, to begin.
weps = 0.1
lenw = length(patternCost)
initw = rep(weps, lenw)

# Linear inequality constraint: M w \geq b
constrM = diag(rep(1,lenw))
constrM = rbind(constrM, -rep(1,lenw))

# Vector b for constraint
constrval = c(rep(0,lenw), -1)

constrg = function(wsub){
  out = -(constrM %*% wsub - constrval)
}

constrgJacobian = function(wsub) {
  out = -constrM
}

objfun = function(wsub){
  return( list( "objective" = varfun(wsub),
                "gradient" = vargrad(wsub) ) )
}

constrfun = function(wsub){
  constr = constrg(wsub)
  grad = constrgJacobian(wsub)
  return( list( "constraints" = constr, "jacobian" = grad ) )
}

kktcheck = function(wsub,t) {
  I = getWeightedFisherInfo(p,wsub,patternCost)
  J = matrix.inverse(I)
  u = c(1,1,1)
  # Assume t>1
  widx = t-1
  patternFisherInfoGradWeighted = getPatternFisherInfo(p,t)/patternCost[widx]
  out1 = t(u) %*% J %*% patternFisherInfoGradWeighted %*% J %*% u
  out2 = t(u) %*% J %*% u
  out = out1-out2
}


mat <- matrix(c(rep(1:8, each = 8) / 8,
                rep(16:1, each = 4) / 16,
                rep(1:32, each = 2) / 32,
                rep(64:1, each = 1) / 64),
              nrow = 4, byrow = TRUE)
par(mar = rep(0, 4))
image(t(mat[4:1, ]), col = gray(1:64/64), axes = FALSE)


#' winddir
#'
#' @description Calculate meteorological wind direction from cartesian components u and v.
#'
#' @param u numeric U zonal component (m/s) .
#' @param v numeric V meridian component (m/s).
#' @return wind direction provenience
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords Meteorological Wind direction
#'
#'
#' @export

winddir <- function(u, v) {
                    (180 / pi) * atan(u/v) + ifelse(v>0,180,ifelse(u>0,360,0))
}


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

iterapply = function(start, func, length) {
    result = numeric(length)
    result[1] = start
    for (i in 2:length) {
        result[i] = func(result[i - 1])
    }
    return(result)
}

get_next_x = function(x, alpha) {
    epsilon = runif(1)
    return (alpha * x + (1 - alpha) * epsilon)
}

generate_series = function(alpha) {
    return (iterapply(0, function(x) { return (get_next_x(x, alpha)) }, 100000))
}

xs = generate_series(0.1)
hist(xs, freq=FALSE)

xs = generate_series(0.3)
hist(xs, freq=FALSE)

xs = generate_series(0.7)
hist(xs, freq=FALSE)

xs = generate_series(0.9)
hist(xs, freq=FALSE)


##' @title
##' Regression Metrics Parameters
##'
##' @description
##' Documentation for shared parameters of functions that compute regression
##' metrics.
##'
##' @param actual \code{[numeric]} The ground truth numeric vector.
##' @param predicted \code{[numeric]} The predicted numeric vector, where each
##'     element in the vector is a prediction of the corresponding elements in
##'     \code{actual}.
##' @name regression_params
##' @include helper-functions.r
NULL

##' @title
##' Explained Variance
##'
##'
##' @description
##'
##' \code{mtr_explained_variance} computes explained variance, also known as
##' explained variation, which is interpreted as the percentage of variation in
##' one numeric vector explained by another. The best possible score is 1.0,
##' lower values are worse.
##'
##' @inheritParams regression_params
##' @importFrom stats var
##' @seealso \code{\link{mtr_r2}}
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_explained_variance(act, pred)
##'
##' act <- c(1.1, 1.9, 3.0, 4.4, 5.0, 5.6)
##' pred <- c(0.9, 1.8, 2.5, 4.5, 5.0, 6.2)
##' mtr_explained_variance(act, pred)
##'
##' @export
mtr_explained_variance <- function(actual, predicted) {

    check_equal_length(actual, predicted)

    exp_var <- 1 - (var(actual - predicted) / var(actual))
    exp_var
}

##' @title
##' Max Error
##'
##'
##' @description
##'
##' \code{mtr_max_error} computes the maximum residual error, a metric that
##' captures the worst error between the predicted value and the true value.
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, 2, 7, 1)
##' pred <- c(9, 2, 7, 1)
##' mtr_max_error(act, pred)
##'
##'
##' @export
mtr_max_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    me <- max(abs(actual - predicted), na.rm = TRUE)
    me
}

##' @title
##' Mean Absolute Error
##'
##'
##' @description
##'
##' \code{mtr_mean_absolute_error} is a measure of difference between the
##' predicted value and the true value.
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @name mae
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_mean_absolute_error(act, pred)
##' mtr_mae(act, pred)
##'
##'
##' @export
mtr_mean_absolute_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    mae <- mean(abs(actual - predicted), na.rm = TRUE)
    mae
}

##' @export
##' @rdname mae
mtr_mae <- mtr_mean_absolute_error

##' @title
##' Mean Squared Error
##'
##'
##'
##' @description test
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @name mse
##' @export
##'
##'
##'
##' @export
##'
##'
##'
##'
##' @export
mtr_mean_squared_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    mse <- mean((actual - predicted)^2, na.rm = TRUE)
    mse
}

##' @export
##' @rdname mse
mtr_mse <- mtr_mean_squared_error

##' @title
##' Root Mean Squared Error Function
##'
##'
##' @description test
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_mean_squared_error(act, pred)
##'
##'
##' @export
mtr_root_mean_squared_error <- function(actual, predicted) {
    sqrt(mtr_mean_squared_error(actual, predicted))
}

##' @title
##' Mean Squared Log Error
##'
##'
##'
##' @description test
##'
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @name msle
##' @author An Chu
##' @examples
##'
##' act <- c(3, 5, 2.5, 7)
##' pred <- c(2.5, 5, 4, 8)
##' mtr_mean_squared_log_error(act, pred)
##'
##'
##' @export
mtr_mean_squared_log_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    msle <- mtr_mean_squared_error(log1p(actual), log1p(predicted))
    msle
}

##' @export
##' @rdname msle
mtr_msle <- mtr_mean_squared_log_error

##' @title
##' Median Absolute Error
##'
##'
##'
##' @description test
##'
##'
##' @details test
##'
##'
##'
##' @inheritParams regression_params
##' @importFrom stats median
##' @return A numeric scalar output
##' @name mdae
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_median_absolute_error(act, pred)
##'
##'
##' @export
mtr_median_absolute_error <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    mdae <- median(abs(actual - predicted), na.rm = TRUE)
    mdae
}

##' @export
##' @rdname mdae
mtr_mdae <- mtr_median_absolute_error

##' @title R2 Score
##'
##'
##'
##' @description test
##'
##'
##'
##'
##' @inheritParams regression_params
##' @return A numeric scalar output
##' @author An Chu
##' @examples
##'
##' act <- c(3, -0.5, 2, 7)
##' pred <- c(2.5, 0.0, 2, 8)
##' mtr_r2(act, pred)
##'
##'
##' @export
mtr_r2 <- function(actual, predicted) {

    check_equal_length(actual, predicted)

    if (length(predicted) < 2) {
        warning("R^2 is not applicable for less than two instances", call. = FALSE)
        return(NA_real_)
    }

    numerator <- sum((actual - predicted) ^ 2)
    denominator <- sum((actual - mean(actual)) ^ 2)

    zero_numerator <- numerator == 0
    zero_denominator <- denominator == 0

    if (zero_numerator || zero_denominator) return(0)

    r2 <- 1 - numerator / denominator
    r2
}


BinSearch <- function(A, value, low, high) {
  if ( high < low ) {
    return(NULL)
  } else {
    mid <- floor((low + high) / 2)
    if ( A[mid] > value )
      BinSearch(A, value, low, mid-1)
    else if ( A[mid] < value )
      BinSearch(A, value, mid+1, high)
    else
      mid
  }
}


addsub <- function(x, y) list(add=(x + y), sub=(x - y))


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

plotwitherror <- function(x, y, dy, col="black", ...) {
  plot(x=x, y=y, col=col, ...)
  arrows(x0=x, y0=y-dy, x1=x, y1=y+dy, length=0.01,
         angle=90, code=3, col=col)
}

myprint = function(varname, var) {
    cat(paste0(varname, ':', '\n'))
    print(var)
    cat('\n')
}

task2 = function() {
    n = c(1:10)

    A = matrix(data=c(1:20), nrow=2)

    myprint('A', A)

    A1 = A[1,]
    A2 = A[2,]

    mean1 = cumsum(A1) / c(1:length(A1))
    mean2 = cumsum(A2) / c(1:length(A2))

    myprint('n', n)
    myprint('mean1', mean1)
    myprint('mean2', mean2)

    result = t(rbind(n, mean1, mean2))
    myprint('result', result)

    write.table(result, '00-2-R-running_mean.tsv', row.names=FALSE, col.names=FALSE)
    write.table(A, '00-2-R-A.tsv', row.names=FALSE, col.names=FALSE)
}

expectation1 = function(n) {
    return(n)
}

expectation2 = function(n) {
    return(n + 1)
}

task3 = function() {
    result = read.table('00-2-R-running_mean.tsv')

    n = result$V1
    mean1 = result$V2
    mean2 = result$V3

    pdf('00-3-R-running_mean.pdf')
    plot(x=n, y=mean1)
    lines(x=n, y=expectation1(n))
    plot(x=n, y=mean2)
    lines(x=n, y=expectation2(n))
    dev.off()

    pdf('00-3-R-running_mean_withmodelerror.pdf')
    plotwitherror (x=n, y=mean1, dy=(mean1*0.1), ylim=c(0,12), xlab="n", ylab=expression('S'['odd']))
    lines(x=n, y=expectation1(n))

    plotwitherror (x=n, y=mean2, dy=(mean2*0.1), ylim=c(0,12), xlab="n", ylab=expression('S'['even']))
    lines(x=n, y=expectation2(n))
    dev.off()

    #dev.copy2pdf('00-3-R-running_mean.pdf')
}

task4 = function() {
    A = read.table('00-2-R-A.tsv')

    myprint('A', A)

    squared1 = t(A[1,])^2
    squared2 = t(A[2,])^2

    myprint('squared1', squared1)
    myprint('squared2', squared2)

    n = c(1:length(squared1))

    mean1 = cumsum(squared1) / n
    mean2 = cumsum(squared2) / n

    pdf('00-4-R-running_mean_square.pdf')
    plot(n, mean1)
    lines(n, (2*n + 1) * (2 * n - 1) / 3)
    plot(n, mean2)
    lines(n, 2*(n + 1) * (2 * n + 1) / 3)
    dev.off()

    myprint('mean1', mean1)
    myprint('mean2', mean2)
}

task5 = function() {
    k = c(1:10^4)
    r = sin(k)
    pdf('00-5-R-hist.pdf')
    hist(r)

    indices = which(r > 0)
    number_positive = length(indices)
    myprint('number_positive', number_positive)

    r[r < 0] = 0

    mean_of_positive = mean(r)
    myprint('mean_of_positive', mean_of_positive)
}

task2()
task3()
task4()
task5()


rm(list=ls())
# reading the file
dataset0=read.csv("test.csv",header=T)
dataset=dataset0[1:5]

summary(dataset)
print("Printing the entire datas")
print(dataset)
dataset=dataset0[3:5]

print("Printing the specifc data to be processed")
print(dataset)
set.seed(123)
set.seed(6)
wcss=vector()
for(i in 1:10) wcss[i]=sum(kmeans(dataset,i)$withinss)

plot(1:10,wcss,type="p",col="red",
main=paste("The Elbow method (Phase--> 1)"),xlab="Number of Clusters",ylab="WCSS")

plot(1:10,wcss,type="b",col="blue",
main=paste("The Elbow method (Phase--> 2)"),xlab="Number of Clusters",ylab="WCSS")

plot(1:10,wcss,type="l",col="green",
main=paste("The Elbow method (Phase--> 3)"),xlab="Number of Clusters",ylab="WCSS")

kmeans=kmeans(x=dataset,centers=4)
y_kmeans=kmeans$cluster
print(y_kmeans)

library(cluster)
clusplot(dataset,y_kmeans,lines=0,
shade=TRUE,
color=TRUE,
labels=1,
plotchar=TRUE,
span=TRUE,
main=paste("Insurace "),
xlab="Passenger Travelled",
ylab="Injured")


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);

  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b7;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- (mu[n-1]^b7)*exp(u+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.2,0.1);
b7 ~ normal(0.98,0.1);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.2,b7=0.98,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=6

pdf(paste("M9_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b7","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M9_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2"), inc_warmup = T,  nrow = 2, ncol = 1, window = NULL, include = TRUE)

dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

pdf(paste("M9_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M9_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M9_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M9_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=1

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M9_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M9 model for ",name[k],sep=""),lwd = 2)

dev.off()

#####################################################################################################################################################
######################################      forecast          ###################################

GP.r <- function(L, s)
{

v=0
Lp=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
sLp=Lp

# calculate the vector of cum pmf
v=1
while((sLp<0.9999999) & ((L + v * s )> 0))
{Lp1=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
Lp=c(Lp,Lp1)
sLp=sLp+Lp1
v=v+1
}

csLp=c(cumsum(Lp),1) ##### add a max for it
x=length(Lp)

# first check if you are in the first interval

U = runif(1)
B = FALSE
i = 1

while(B == FALSE) {

  if(U > csLp[i])  ### U may greater than max of csLp if do not set 1
    { i=i+1}
  else
    {X=i-1
     B=TRUE}

}

return(X)

}

################################################ as.data.frame(fit@sim[[1]][[1]])[1,]

P=20
Mu=matrix(,nrow=90000,ncol=P)
X=matrix(,nrow=90000,ncol=P)

lambda_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,1]
u_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,2]
b7_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,3]
sig2_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,4]

set.seed(999)

for (r in 1:90000){

Mu[r,1]=y[length(y)]
for (s in 1:(P-1) ){

e=rnorm(1,0,sig2_p[r])

Mu[r,s+1]=(Mu[r,s]^b7_p[r])*exp(u_p[r]+e)
}}

sigob=1000
for (r in 1:90000){
for (s in 1:P ){

X[r,s]=rnorm(1,Mu[r,s], sigob)

}}

#for (r in 1:90){
#for (s in 1:P ){
#X[r,s]=GP.r(Mu[r,s]*(1-lambda_p[r]), lambda_p[r])
#}}

#X=Mu

Xm=apply(X,2,mean)

X5 <- apply( X , 2 , quantile, probs=0.05 )

X9 <- apply( X , 2 , quantile, probs=0.95 )

Zm=c(y,Xm)
Z5=c(y,X5)
Z9=c(y,X9)

k=3

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

m=length(Zm)

setwd("./covid19modelrisk/output/forecast")
pdf(paste("M9_",abn[k],"_F.pdf",sep=""), width = 16.5, height = 8.50)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Z9[1:m]), Z5[1:m]), col = "grey80", border = NA)

lines(newx,Z9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Z5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)

dev.off()

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

n=length(y)

u=0.2
b7=0.98

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=(x[i]^b7)*exp(u)
}
x=round(x)
x

plot(y,ylim=c(min(y,x),max(y,x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(y,x),max(y,x)))

#############################################################
##### GM

u=0.25
b7=0.98

##### IT

u=0.25
b7=0.98

##### JP
u=0.21
b7=0.98

##### SP
u=0.25
b7=0.98

##### UK
u=0.25
b7=0.98

##### US
u=0.3
b7=0.98

##### AU
u=0.2
b7=0.98


# clusters i center
clust.centroid = function(i, dat, clusters) {
	ind = (clusters == i)
	colMeans(dat[ind,])
}

clusters_df <- function(df, index_name, index, num_clusters, use_hclust_method_name, image_size, ggplot_image, label_on)
{
	library(cluster)
	library(ggfortify)
	library(ggplot2)
	library(proxy)

	n = ncol(df)

	m = nrow(df)

	if ( length(index) == 0 )
	{
		index <- data.frame(index_row=1:m)
		index_name <- "index_row"
	}else
	{
		index <- data.frame(index)
		colnames(index) <- c(index_name)
	}
	rownames(df) <- index[,1]

	print("---------------------")
	#smat <- scale(df)
	smat <- df

	#  wss <- (nrow(smat)-1)*sum(apply(smat,2,var))
	#  for (i in 2:n) wss[i] <- sum(kmeans(smat, centers=i)$withinss)
	#  plot(1:n, wss, type="b", xlab="Number of Clusters", ylab="Within groups sum of squares")

	fit <- NULL
	if ( use_hclust_method_name != "" )
	{
		#method =  "euclidean"),
        #method =  "maximum"),
        #method =  "manhattan"))

		method_name <- use_hclust_method_name;
		#clusters <- cutree(hclust(dist(smat, method = "cosine"), method = "ward.D2"), k = num_clusters)
		#clusters <- cutree(hclust(dist(smat, method = "manhattan"), method = "ward.D2"), k = num_clusters)
		clusters <- cutree(hclust(proxy::dist(smat, method = method_name), method = "ward.D2"), k = num_clusters)
		centers <- sapply(unique(clusters), clust.centroid, smat, clusters)
		fit <- kmeans(smat, centers=t(centers))
	}else
	{
		fit <- kmeans(smat, num_clusters) # [num_clusters] cluster solution
	}

	cluster_id <- data.frame(fit$cluster)

	print(num_clusters)
	for ( k in 1:num_clusters)
	{
		df1 = NULL
		df2 = NULL
		df3 = NULL
		for ( i in 1:m)
		{
			if ( cluster_id[i,] == k)
			{
				df1 <- rbind(df1, df[i,])
				df2 <- rbind(df2, index[i,])
				df3 <- rbind(df3, cluster_id[i,])
			}
		}
		colnames(df2) <- c(index_name)
		colnames(df3) <- c("cluster_id")
		df1 <- cbind(df1, df2)
		df1 <- cbind(df1, df3)
		file.name <- sprintf("df_cluster_%03d.csv", k)
		write.csv(df1, file.name, row.names=FALSE)
	}

	if ( ggplot_image  == 0)
	{
		if ( image_size == 0 )
		{
			png("cluster.png")
		}else
		{
			png("cluster.png", height=640*image_size, width=640*image_size)
		}

		label = 0
		if ( label_on ) label = 2
		clusplot(df, fit$cluster, color=TRUE, shade=TRUE, labels=label, lines=0, cex=1+image_size)
		#clusplot(df, fit$cluster, color=TRUE, shade=F, labels=label, lines=0, cex=1+image_size)
		dev.off()
	}else
	{
		sz = image_size;
		if ( sz <= 0 ) sz = 1
		g = autoplot(fit, data = df, frame = TRUE, frame.type = 'norm', label = label_on, label.size = 3)
		ggsave(file = "cluster.png", plot = g, dpi = 100*sz, width = 6.4, height = 4.8)
	}

	sink(file = "cluster_id.txt")
	print(cluster_id)
	sink()

	return (fit)
}


Seatbelts <- data.frame(Seatbelts)
str(Seatbelts)
head(Seatbelts,n=10)
summary(Seatbelts)

BeforeLaw <-subset(Seatbelts,law ==0)
AfterLaw <- subset(Seatbelts,law!=0)

summary(BeforeLaw)
summary(AfterLaw)

library(glmnet)

x <- model.matrix(DriversKilled~., BeforeLaw)[,-c(1,8)]
y <- BeforeLaw$DriversKilled

ElasticnetMod <- glmnet(x, y, alpha=0.5, nlambda=100,
                        lambda.min.ratio=0.0001)
plot(ElasticnetMod)

CvElasticnetMod <- cv.glmnet(x, y, alpha=0.5, nlambda=100,
                             lambda.min.ratio=0.0001)

plot(CvElasticnetMod)


library(tidyverse)
library(ggplot2)
library(plotly)

data = data.frame(diamonds)
plot_ly(data, x= data$cut, y=data$carat, type="scatter")
ggplot2::geom_boxplot(data)

ggplot(diamonds, aes(diamonds$carat, diamonds$clarity, colour = "dark blue"),geom_point())

df <- data.frame(
  gp = factor(rep(letters[1:3], each = 10)),
  y = rnorm(30)
)
ds <- plyr::ddply(df, "gp", plyr::summarise, mean = mean(y), sd = sd(y))

# The summary data frame ds is used to plot larger red points on top
# of the raw data. Note that we don't need to supply `data` or `mapping`
# in each layer because the defaults from ggplot() are used.
ggplot(data, aes(x=data$carat, y=data$color)) +
  geom_point() +
  geom_point(data = data, aes(y = data$clarity), colour = 'red', size = 3)

#Scatter plot

ggplot(diamonds,aes(x=diamonds$carat,y=diamonds$price,
           color=diamonds$color))+
  geom_point()

#histogram

library(ggplot2)
ggplot(diamonds, aes(x = diamonds$price,color=diamonds$color)) +
  geom_histogram()

#bar plot

library(ggplot2)
ggplot(diamonds, aes(x = diamonds$price,color=diamonds$color, size = 2)) +
  geom_bar()

#bar plot

ggplot(diamonds,aes(x=diamonds$carat,y=diamonds$price,
                    color=diamonds$color))+
  geom_line()

#boxplot

ggplot(diamonds,aes(x=diamonds$carat,y=diamonds$price,
                    color=diamonds$color))+
  geom_boxplot()

#line graph

p <- ggplot(diamonds, aes(x = diamonds$carat, y = diamonds$price))
p + geom_line(aes(color = diamonds$color))

#cross bar

ggplot(diamonds,aes(y=diamonds$carat,x=diamonds$price,ymin=6.5, ymax=3.6,
                    color=diamonds$color))+
  geom_crossbar()

# scaling
p3 <- ggplot(diamonds,
             aes(y = diamonds$depth,
                 x = diamonds$cut)) +
  theme(legend.position="top",
        axis.text=element_text(size = 6))
(p4 <- p3 + geom_point(aes(color = diamonds$color),
                       alpha = 0.25,
                       size = 1.5,
                       position = position_jitter(width = 0.05, height = 17)))


ibp = function(n, a) {

  dishes = max(1, rpois(1, a))
  diners = data.frame(dish = seq(dishes), diners = rep(1, dishes))
  buffet = list(buffet = diners, choices = list(seq(dishes)))

  for (j in seq(n - 1)) {
      buffet = arrival(buffet, a)
    }
  buffet
  }

arrival = function(b, a) {
  config  = b$buffet
  existing_choices = b$choices
  j = length(existing_choices) + 1
  n = nrow(config)

  num_new_dishes = rpois(1, a / j)
  new_dishes     =
      if (num_new_dishes > 0) {
        (n + 1):(n + num_new_dishes)
      } else {
        numeric(0)
      }

  probs     = sapply(config$diners, function(n) { n / j })
  selection = rbinom(n, 1, prob = probs) == 1
  choices   = list(c(as.integer(row.names(config[selection,])), new_dishes))
  diners    = with(config, replace(diners, selection, diners[selection] + 1))

  buffet = data.frame(
      dish   = seq(n + num_new_dishes)
    , diners = c(diners, rep(1, num_new_dishes))
    )

  list(buffet = buffet, choices = c(existing_choices, choices))
  }

ibp_matrix = function(buffet) {
  dishes = do.call(max, buffet$choices)
  index  = function(j) { as.numeric(seq(dishes) %in% j) }
  rows   = lapply(buffet$choices, index)

  do.call(rbind, rows)
  }


library('ggplot2')
library('forecast')
library('tseries')
library("readxl")

MSE<-function(y_pred,y_true){
    return (mean((as.numeric(unlist(y_pred))-as.numeric(unlist(y_true))^2)))
}

eval_arima_model<-function(train,dev,order){
    model=arima(train,order = order)
    dev_pred = predict(model,120)
    error = MSE(y_pred=dev_pred,y_true=dev)
    return (error)
}

eval_arima_models<-function(train,dev,p_values,d_values,q_values){
    best_score = Inf
    best_order = NULL
    for(i in 1:length(p_values)){
        for(j in 1:length(d_values)){
            for(k in 1:length(q_values)){
                order=c(p_values[i],d_values[j],q_values[k])
                print(order)
                mse = eval_arima_model(train,dev,order = order)
                if(mse < best_score){
                    best_score=mse
                    best_order=order
                }
            }
        }
    }
    print(best_order)
    print(best_score)
    return (best_order)
}
huaxian=read_excel("time_series/HuaxianRunoff1951-2018(1953-2018).xlsx")
hua_mr = huaxian$MonthlyRunoff[25:816]
hua_ts = ts(hua_mr,frequency = 12)
decomp = stl(hua_ts,s.window = "periodic")
deseasonal_hua <- seasadj(decomp)

auto.arima(deseasonal_hua,seasonal=FALSE)

train = deseasonal_hua[1:552]
dev = deseasonal_hua[553:672]
test = deseasonal_hua[673:792]
# length(train)
# length(dev)
# length(test)
p_values=c(1,2,3,4,5,6,7,8,9)
d_values=c(1,2,3)
q_values=c(1,2,3)
best_order = eval_arima_models(train,dev,p_values,d_values,q_values)
model = arima(train,order = best_order)
dev_pred = predict(model,120)
print(dev_pred)
plot(as.numeric(unlist(dev_pred)))


# boot.r  -  very simple code used to generate the 500 bootstrap
#  samples from the lab 1 exercise.

lab2bigd <- lab2bigr <- rep(0,500)
a <- lab1$Y[1:10]    # data from group A
b <- lab1$Y[11:20]   # data from group B

for (i in 1:500) {
   ma <- mean(sample(a,10,repl=T));
   mb <- mean(sample(b,10,repl=T))

   lab2bigd[i] <- mb - ma;
   lab2bigr[i] <- mb/ma;
   }

lab2bigd <- sort(lab2bigd)
lab2bigr <- sort(lab2bigr)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/boot.r


###Getting started
#1. Install the latest version of RStudio (Help-Check for Updates)
#2. Download and install the latest version of R: https://cran.cnr.berkeley.edu/
#3. Create a new project in RStudio called "Lecture 1 554" (or similar) in the
#   same directory as all of the .csv data files, to make it easy to read files.
#Select part of a line and type ctrl+enter to run that line in the Console
#=======================================

library(tidyverse)    #loads the library for ggplot2 and other useful libraries

print("Hello world")  #prints values contained in object or string
?print                #use ? to get help on a function

#vectors and number sequences
x1 <- 5:12            #assign sequence of numbers 5 to 12 to x1
x1[-c(2,4)]           #exclude the 2nd and 4th value
print(x1+3)           #R does operations on all elements of a vector
x2 <- seq(from=2,to=30,by=3)     #every 3rd number from 2 to 30
print(x2)

#matrix manipulations (row then column)
xmat <- cbind(x1,rev(x1))  #column binding x1 and reversed x1 to make matrix
xmat[1:3,-2]           #first three rows, and not the second column

#lists
xlist <- list(x1, xmat)
xlist[[2]][1:5,]      #first five rows and all columns of element 2 of the list

#data frames
mydata <- data.frame(ID=1:5, names=c("Tim","Anne","Mae","Luke","Pat"))
mydata$names[2:3]

#functions: easy to see everything that goes into a function,
#  easy to reuse code, no global variables
#e.g. return sum of square of differences between numbers (or vectors)
sumxmy2 <- function(x,y) {
  return(sum((x-y)^2))
}
sumxmy2(1,2)                      #works for individual values
sumxmy2(c(1,1,1,1),c(1,2,3,4))    #works for two vectors

#if-then-else statements
x <- 10
if (x==10) {
  print("yes")
} else {
  print("no")
}

#for-loops: 99% of all loops can be written this way
#(there are also while loops, but no need to worry about them)
for(i in 5:1) {       #i becomes each value 5 4 3 2 1 then loop ends
  print(i)
  print(i^2)
  print(i+10)
}
#press ESC if you get stuck inside a loop---this also happens
#when the console has lines that start with + instead of >

######GGPLOT2
library(ggplot2)   #or library(tidyverse)
library(gapminder) #contains data
gapminder          #look at the data; it is contained in a tibble (data frame)
gapminder2007 <- filter(gapminder, year==2007)

ggplot(data=gapminder2007)  #specify where the data are contained
gapminder %>% ggplot()  #or you can "pipe" the data into ggplot

#adding data, aesthetics, and geometries
ggplot(data=gapminder2007) +
   aes(x=gdpPercap) +
   aes(y=lifeExp) +
   geom_point()

#this is the same as combining aesthetics
ggplot(data=gapminder2007) +
  aes(x=gdpPercap, y=lifeExp) +
  geom_point()

#what if we want a line plot?
gapminderEurope <- filter(gapminder, continent=="Europe")
ggplot(data=gapminderEurope) + aes(x=year, y=lifeExp) +
  geom_line() + aes(group=country) + aes(color=country) +
  geom_point() + scale_y_continuous(limits=c(30,100))

#what if we want a boxplot?
gapminderAmericas <- filter(gapminder, continent=="Americas")
ggplot(data=gapminderAmericas) + aes(x=country, y=lifeExp) +
  aes(group=country) + geom_boxplot()

#flip the x and y axes
gapminderAmericas <- filter(gapminder, continent=="Americas")
ggplot(data=gapminderAmericas) + aes(x=country, y=lifeExp) +
  aes(group=country) + geom_boxplot() + coord_flip()

#reorder by GDP
library(tidyverse)   #or library(tidyverse)
library(gapminder) #contains data
gapminderAmericas <- filter(gapminder, continent=="Americas")
ggplot(data=gapminderAmericas) + aes(x=reorder(country, gdpPercap), y=lifeExp) +
  aes(group=country) + geom_boxplot() + coord_flip()

#reorder by life expectancy
library(tidyverse)   #or library(tidyverse)
library(gapminder) #contains data
gapminderAmericas <- filter(gapminder, continent=="Americas")
ggplot(data=gapminderAmericas) + aes(x=reorder(country, lifeExp), y=lifeExp) +
  aes(group=country) + geom_boxplot() + coord_flip()

#======reading in data
#Fall student enrollment at UW Seattle campus
library(tidyverse)
UWenroll <- read_csv(file=here("Documents","data","beautiful_graphics","UWenrollment.csv"))
UWenroll
ggplot(data=UWenroll) + aes(x=Year, y=FallEnrollment) +
  geom_col()

#==========pie chart in ggplot=================================
#Color codes from http://www.colorschemer.com/colorpix_info.php
#Idea: http://flowingdata.com/2014/12/01/pie-chart-pyramid/
#code: Bryce Mecum and Trevor Branch
library(tidyverse)
sides <- c("Sky","Sunny side of pyramid",
         "Shady side of pyramid")
greatpyr <- data.frame(x=factor(sides, levels=sides, ordered=TRUE),
                       y=c(14.7,3,1))
ggplot(data=greatpyr,
            aes(x="", y=y, fill=x)) +
  geom_bar(width = 1, stat = "identity") +
  coord_polar("y", start=2.45) +
  scale_fill_manual(values=c("#0095D9","#F5E837","#C4B633")) +
  theme(legend.title=element_blank(),
        axis.title=element_blank(),
        axis.ticks=element_blank(),
        axis.line=element_blank(),
        axis.text=element_blank(),
        panel.background=element_blank())

#======pie chart in base R graphics=================================
par(oma=c(0,0,0,10))  #make space around figure
pie(c(12,3,1,2.7), col=c("#0095D9", "#F5E837", "#C4B633", "#0095D9"),
    border=NA, labels=c(""))  #pie chart with specific colors
legend(x=0.90,y=0.9,pt.bg=c("#0095D9", "#F5E837", "#C4B633"),
       xpd=NA, pch=22, pt.cex=2.5, border=NA,box.col=NA, col=NA,
       legend=c("Sky","Sunny side of the pyramid",
                "Shady side of the pyramid"))   #add a legend


garage1=c(17.6,20.2,19.5,11.3,13.0,16.3,15.3,16.2,12.2,14.8,21.3,22.1,16.9,17.6,18.4)
garage2=c(17.3,19.1,18.4,11.5,12.7,15.8,14.9,15.3,12.0,14.2,21.0,21.0,16.1,16.7,17.5)
t.test(garage1,garage2)


library("nloptr")

# Set up parameters and constants
birthyear <- 1997
lifespan <- 100
startage.i <- 22
startage.r <- 60

startyear.i <-  birthyear + startage.i # start investing
startyear.r <- birthyear + startage.r # start retiring (end investing)
endyear.r <- birthyear + lifespan
n.i <- startyear.r - startyear.i # number of years of investing
n.r <- endyear.r - startyear.r # number of years of retirement
n.total <- n.i + n.r

year2ind <- function(year) { year - startyear.i + 1 }
age2ind <- function(age) { age - startage.i + 1 }

PARAM.NAMES <- c('d.roth', 'd.trad', 'w.roth', 'w.trad')

unpack_params_simple <- function(packed_params) {
  params <- as.list(packed_params)
  names(params) <- PARAM.NAMES
  params
}

pack_params_simple <- function(params) {
  unlist(params)
}

init_params_simple <- function(init_val=0) {
  unpack_params_simple(rep(init_val, times=length(PARAM.NAMES)))
}

params.simple <- init_params_simple()

income.estimated <- 5e5
interest.rate <- 1.08

# Tax function - using 2020 single filers tax brackets
BRACKETS <- list(rate=c(0.1, 0.12, 0.22, 0.24, 0.32, 0.35, 0.37),
                 cutoffs=c(9875, 40125, 85525, 163300, 207350, 518400, Inf))

clip <- function(vec, LB=0, UB=10) pmax( LB, pmin( vec, UB))
shift <- function(x, by) c(rep(0,times=by), x[1:length(x) - by])

tax_fn_helper <- function(income) {
  lb <- shift(BRACKETS$cutoffs, 1)
  ub <- BRACKETS$cutoffs
  if (income == 0) {
    BRACKETS$rate[1]
  } else {
    (BRACKETS$rate %*% (clip(income, LB=lb, UB=ub) - lb)) / income
  }
}
tax_fn <- Vectorize(tax_fn_helper)

# Don't count traditional deposits as income
adjust.income <- function(income, d.trad.vals) {
  income - d.trad.vals
}
# value.roth <- function(d.roth, w.roth, adjusted.income, interest.cum, n.i, n.r) {
#   d.roth.vals <- c(rep(d.roth, times=n.i), rep(0, times=n.r))
#   w.roth.vals <- c(rep(0, times=n.i), rep(w.roth, times=n.r))
#   sum(interest.cum * (d.roth.vals * (1 - tax_fn(adjusted.income))) - interest.cum * w.roth.vals)
# }
deposit_mult <- function(interest, n.i, n.r) {
  (1 - interest^n.i) / (1 - interest) * interest * interest^n.r
}
withdrawal_mult <- function(interest, n.r) {
  (1 - interest^n.r) / (1 - interest) * interest
}
value.roth <- function(d.roth, w.roth, adjusted.income, interest, n.i, n.r) {
  d.mult <- (1 - tax_fn(adjusted.income)) * deposit_mult(interest, n.i, n.r)
  w.mult <- withdrawal_mult(interest, n.r)
  d.roth * d.mult - w.roth * w.mult
}
# value.trad <- function(d.trad, w.trad, interest.cum, n.i, n.r) {
#   d.trad.vals <- c(rep(d.trad, times=n.i), rep(0, times=n.r))
#   w.trad.vals <- c(rep(0, times=n.i), rep(w.trad, times=n.r))
#   sum(interest.cum * d.trad.vals - interest.cum * w.trad.vals)
# }
value.trad <- function(d.trad, w.trad, interest, n.i, n.r) {
  d.mult <- deposit_mult(interest, n.i, n.r)
  w.mult <- withdrawal_mult(interest, n.r)
  d.trad * d.mult - w.trad * w.mult
}

obj_simple_grad <- function(params, tax_mult) {
  params$d.roth <- 0
  params$d.trad <- 0
  params$w.roth <- -1
  params$w.trad <- -tax_mult
  pack_params_simple(params)
}
eval_obj_simple <- function(x, income, interest.rate, n.i, n.r) {
  params <- unpack_params_simple(x)
  tax_mult <- (1 - tax_fn(params$w.trad))
  list(objective=-(params$w.roth + params$w.trad * (1 - tax_fn(params$w.trad))),
       gradient=obj_simple_grad(params, tax_mult)
  )
}

# Inequality Constraints - should be in form g(x) <= 0
IRA_CONTRIB_LIM <- 6e3

ira.limit.ineq.grad <- function(params, tax_mult) {
  params$d.roth <- tax_mult
  params$d.trad <- 1
  params$w.roth <- 0
  params$w.trad <- 0
  pack_params_simple(params)
}
ira.limit.ineq <- function(params, adjusted.incomes) {
  tax_mult <- (1 - tax_fn(adjusted.incomes))
  list(
    inequality=(params$d.roth * tax_mult) + params$d.trad - IRA_CONTRIB_LIM,
    gradient=ira.limit.ineq.grad(params, tax_mult)
  )
}

posdef.account.roth.grad <- function(params, adjusted.income, interest.rate, n.i, n.r) {
  params$d.roth <--1 * (1 - tax_fn(adjusted.income)) * deposit_mult(interest.rate, n.i, n.r)
  params$d.trad <- 0
  params$w.roth <- 1 * withdrawal_mult(interest.rate, n.r)
  params$w.trad <- 0
  pack_params_simple(params)
}
posdef.account.roth <- function(params, adjusted.income, interest.rate, n.i, n.r) {
  list(
    inequality=-value.roth(params$d.roth, params$w.roth, adjusted.income, interest.rate, n.i, n.r),
    gradient=posdef.account.roth.grad(params, adjusted.income, interest.rate, n.i, n.r)
  )
}
posdef.account.trad.grad <- function(params, interest.rate, n.i, n.r) {
  params$d.trad <--1 * deposit_mult(interest.rate, n.i, n.r)
  params$d.roth <- 0
  params$w.trad <- 1 * withdrawal_mult(interest.rate, n.r)
  params$w.roth <- 0
  pack_params_simple(params)
}
posdef.account.trad <- function(params, interest.rate, n.i, n.r) {
  list(
    inequality=-value.trad(params$d.trad, params$w.trad, interest.rate, n.i, n.r),
    gradient=posdef.account.trad.grad(params, interest.rate, n.i, n.r)
  )
}

eval_ineq_simple <- function(x, income, interest.rate, n.i, n.r) {
  params <- unpack_params_simple(x)
  adjusted.income <- adjust.income(income, params$d.trad)
  ira_limit <- ira.limit.ineq(params, adjusted.income)
  roth_posdef <- posdef.account.roth(params, adjusted.income, interest.rate, n.i, n.r)
  trad_posdef <- posdef.account.trad(params, interest.rate, n.i, n.r)

  list(
    constraints=c(ira_limit$inequality, roth_posdef$inequality, trad_posdef$inequality),
    jacobian=rbind(c(ira_limit$gradient, roth_posdef$gradient, trad_posdef$gradient))
  )
}

# Simple optimize
local_opts <- list(
  algorithm="NLOPT_LD_TNEWTON",
  xtol_rel=1e-04,
  maxeval=10000
)
opts <- list(
  algorithm="NLOPT_LD_AUGLAG",
  xtol_rel=1e-08,
  maxeval=100000,
  local_opts=local_opts
)
params.packed <- pack_params_simple(params.simple)
res <- nloptr(
  x0=params.packed,
  eval_f=eval_obj_simple,
  lb= rep(0, times=length(params.packed)),
  ub= rep(IRA_CONTRIB_LIM, times=length(params.packed)),
  eval_g_ineq=eval_ineq_simple,
  opts=opts,
  income=income.estimated,
  interest.rate=interest.rate,
  n.i=n.i,
  n.r=n.r
)

cat("Failed?: ",  res$status)
cat("Status Message: ", res$message)
cat("Total Withdrawal achieved: ", -res$objective)
params.opt <- unpack_params_simple(res$solution)

cat("Traditional Deposits: ", params.opt$d.trad)
cat("Roth Deposits: ", params.opt$d.roth)
cat("Traditional Withdrawals: ", params.opt$w.trad)
cat("Roth Withdrawals: ", params.opt$w.roth)


## GIFs inspired by https://crumplab.github.io/statistics/gifs.html
## libraries
library(ggplot2)
library(dplyr)
library(magick)
library(gganimate)
## some packages only available via github
## devtools::install_github("thomasp85/transformr")
library(transformr)

## simulate data
set.seed(3214)
A <- rnorm(100,45,10)
B <- rnorm(100,50,10)
C <- rnorm(100,40,10)
DV <- c(A,B,C)
Transport <- rep(rep(c("Car","Bus","Train"),each=10),10)
sims <- rep(1:10,each=30)
df<-data.frame(sims,Transport,DV)
means_df <- df %>%
    group_by(sims,Transport) %>%
    summarize(means=mean(DV),
              sem = sd(DV)/sqrt(length(DV)))
stats_df <- df %>%
    group_by(sims) %>%
    summarize(Fs = summary(aov(DV~Transport))[[1]][[4]][1])
a <- ggplot(means_df, aes(x=Transport,y=means, fill=Transport)) +
    geom_bar(stat="identity") +  scale_fill_brewer(palette = "Dark2") +
    geom_point(data=df,aes(x=Transport, y=DV), alpha=.25) +
    geom_errorbar(aes(ymin=means-sem, ymax=means+sem),width=.2)  +
    theme(axis.title.x=element_blank(),
          panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA)) + ylab("Time to work (mins)") +
    transition_states(
        states=sims,
        transition_length = 2,
        state_length = 1) +
    geom_text(aes(0.5, 78,label = paste("Sample mean Bus:", format(round(means[rep(seq(1,30,3),each = 3)], 3),
                                                                   nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    geom_text(aes(0.5, 74,label = paste("Sample mean Car:", format(round(means[rep(seq(2,30,3),each = 3)], 3),
                                                                   nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    geom_text(aes(0.5, 70,label = paste("Sample mean Train:", format(round(means[sims*3], 3),
                                                                     nsmall = 2))),
              size = 4, hjust = 0, color = "black") + enter_fade() +
    exit_shrink() +
    ease_aes('sine-in-out')
## for p-value shading
crit_df <- as.data.frame(apply(stats_df,2,rep,each = 100))
crit_df$Fs <- c(sapply(stats_df$Fs, function(x) seq(x,6, length.out = 100))) ## xvect of sequences
crit_df$y <- df(crit_df$Fs,df1 = 2,df2 = 27) ## corresponding F vals
b <- ggplot(stats_df,aes(x = Fs,y = y)) +
    geom_vline(aes(xintercept = Fs)) +
    geom_line(data=data.frame(x = seq(0,6,.1),
                              y  = df(seq(0,6,.1),df1=2,df2=27)),
              aes(x=x,y=y)) +
    theme(panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA),
          legend.position = "none") +
    ylab("density") +
    xlab("F-statistic") +
    geom_area(data = crit_df,mapping = aes(x = Fs,y = y),fill = "grey",alpha = 0.3) +
    transition_states(sims,transition_length = 0,
                      state_length = 1) + enter_fade() +
    geom_text(aes(4, 1,label = paste("F-statistic:", format(round(Fs, 2), nsmall = 2))),
              size = 4, hjust = 0, color = "black")  +
    geom_text(aes(4, 0.95,label = paste("p-value:", format(round(pf(Fs,2,27,lower.tail = FALSE), 2), nsmall = 2))),
              size = 4, hjust = 0, color = "grey")  +
    exit_shrink() +
    ease_aes('sine-in-out')
## individual gifs
a_gif <- animate(a,width=420,height=420)
anim_save("a.gif")
b_gif <-animate(b,width=420,height=420)
anim_save("b.gif")

a_mgif<-image_read("a.gif")
b_mgif<-image_read("b.gif")

## combine
new_gif <- image_append(c(a_mgif[1], b_mgif[1]))
for(i in 2:100){
    combined <- image_append(c(a_mgif[i], b_mgif[i]))
    new_gif <- c(new_gif,combined)
}
anim_save("anova.gif",new_gif)


#Rscript

#######################################
##     Homogeneity and normality     ##
#######################################

#####Packages : car
#               ggplot2
#               ggpubr
#               Cowplot

#####Load arguments

args <- commandArgs(trailingOnly = TRUE)

if (length(args) == 0) {
    stop("This tool needs at least one argument")
}else{
    table <- args[1]
    hr <- args[2]
    date <- as.numeric(args[3])
    spe <- as.numeric(args[4])
    var <- as.numeric(args[5])
}

if (hr == "false") {
  hr <- FALSE
}else{
  hr <- TRUE
}

#####Import data
data <- read.table(table, sep = "\t", dec = ".", header = hr, fill = TRUE, encoding = "UTF-8")
data <- na.omit(data)
coldate <- colnames(data)[date]
colspe <- colnames(data)[spe]
colvar <- colnames(data)[var]

#####Your analysis

####Homogeneity of the variance####

##Test of Levene##
testlevene <- function(data, col1, col2) {
        data[, col1] <- as.numeric(data[, col1])
        data[, col2] <- as.factor(data[, col2])
    tb_levene <- car::leveneTest(y = data[, col1], group = data[, col2])

    return(tb_levene)
    }
levene <- capture.output(testlevene(data = data, col1 = colvar, col2 = colspe))

cat("\nwrite table with levene test. \n--> \"", paste(levene, "\"\n", sep = ""), file = "levene.txt", sep = "", append = TRUE)

##Two boxplots to visualize it##

homog_var <- function(data, col1, col2, col3, mult) {
    data[, col1] <- as.factor(data[, col1])
    if (mult) {
            for (spe in unique(data[, col2])) {
             data_cut <- data[data[, col2] == spe, ]
             graph_2 <- ggplot2::ggplot(data_cut, ggplot2::aes_string(x = col1, y = col3, color = col1)) +
             ggplot2::geom_boxplot() +
             ggplot2::theme(legend.position = "none", axis.text.x = ggplot2::element_text(angle = 90, vjust = 0.5, hjust = 1), panel.background = ggplot2::element_rect(fill = "#d9d4c5", colour = "#d9d4c5", linetype = "solid"),
              panel.grid.major = ggplot2::element_line(linetype = "solid", colour = "white"),
              panel.grid.minor = ggplot2::element_line(linetype = "solid", colour = "white"))

            ggplot2::ggsave(paste("Homogeneity_of_", spe, ".png"), graph_2, width = 16, height = 9, units = "cm")
            }
        }else{
        graph_1 <- ggplot2::ggplot(data, ggplot2::aes_string(x = col1, y = col3, color = col1)) +
          ggplot2::geom_boxplot() +
          ggplot2::theme(legend.position = "none", axis.text.x = ggplot2::element_text(angle = 90, vjust = 0.5, hjust = 1))

    #Put multiple panels
    graph_2 <- graph_1 + ggplot2::facet_grid(rows = ggplot2::vars(data[, col2]), scales = "free") +
      ggplot2::theme(panel.background = ggplot2::element_rect(fill = "#d9d4c5", colour = "#d9d4c5", linetype = "solid"),
          panel.grid.major = ggplot2::element_line(linetype = "solid", colour = "white"),
          panel.grid.minor = ggplot2::element_line(linetype = "solid", colour = "white"))

    ggplot2::ggsave("Homogeneity.png", graph_2, width = 16, height = 9, units = "cm")
        }
}

####Normality of the distribution####
# Kolmogorov-Smirnov test

ks <- capture.output(ks.test(x = data[, var], y = "pnorm", alternative = "two.sided"))

cat("\nwrite table with Kolmogorov-Smirnov test. \n--> \"", paste(ks, "\"\n", sep = ""), file = "ks.txt", sep = "", append = TRUE)

#Histogramm with distribution line
graph_hist <- function(data, var1) {
  graph_hist <- ggplot2::ggplot(data) +
  ggplot2::geom_histogram(ggplot2::aes_string(x = var1), binwidth = 2, color = "black", fill = "white") +
  ggplot2::geom_density(ggplot2::aes_string(var1), alpha = 0.12, fill = "red") +
  ggplot2::ggtitle("Distribution histogram")

return(graph_hist)
}

#Add the mean dashed line
add_mean <- function(graph, var1) {
  graph_mean <- graph + ggplot2::geom_vline(xintercept = mean(data[, var1]),
              color = "midnightblue", linetype = "dashed", size = 1)

return(graph_mean)
}

#Adding a QQplot
graph_qqplot <- function(data, var1) {
  graph2 <- ggpubr::ggqqplot(data, var1, color = "midnightblue") + ggplot2::ggtitle("Q-Q plot")

return(graph2)
}

#On suppose que les données sont distribuées normalement lorsque les points suivent approximativement la ligne de référence à 45 degrés.

graph_fin <- function(graph1, graph2) {
  graph <- cowplot::plot_grid(graph1, graph2, ncol = 2, nrow = 1)

  ggplot2::ggsave("Normal_distribution.png", graph, width = 10, height = 7, units = "cm")
}

mult <- ifelse(length(unique(data[, colspe])) == 2, FALSE, TRUE)
homog_var(data, col1 = coldate, col2 = colspe, col3 = colvar, mult = mult)

graph_hist1 <- graph_hist(data, var1 = colvar)
graph_mean <- add_mean(graph = graph_hist1, var1 = colvar)
graph_fin(graph1 = graph_mean, graph2 = graph_qqplot(data, var1 = colvar))


# mean
accounts_due<-c(55.20,  4.88 ,271.95,
                18.06, 180.29, 365.29,
                28.16, 399.11 ,807.80,
                44.14, 97.47, 9.98,
                61.61, 56.89 ,82.73)
n<-sum(accounts_due)
d<-length(accounts_due)
mean_accountsdue<-n/d
print(mean_accountsdue)
total_overdueamount=150*mean_accountsdue
print(total_overdueamount)


#' Converts a correlation metric (rho) to a z-score
#'
#' @param rho  A Pearson's r
#' @return     A z-score
fisher_r2z = function(rho) 0.5 * log((1 + rho)/(1 - rho))

#' Tests for significant correlations in a population
#'
#' @param mat  A sample matrix with [obs x samples]
#' @return     A matrix with p-values
test = function(mat, self=0) {
    mat = as.matrix(mat)
    n = ncol(mat)
    p.mat = matrix(NA, n, n, dimnames=dimnames(mat)[c(2,2)])
    diag(p.mat) = self
    for (i in 1:(n - 1))
        for (j in (i + 1):n)
            p.mat[i,j] = p.mat[j,i] = cor.test(mat[,i], mat[,j])$p.value
    p.mat
}

#' Tests for significant changes in correlation between two populations
#'
#' TODO: all stat tests should return a data.frame
#'
#' @param x  A sample matrix with [obs x variables]
#' @param y  A samples matrix with [obs x variables]
#' @param return_cor  Return cor matrices of x and y (default: FALSE)
#' @param pad  Pad cor(x/y) assuming zero correlation
#' @return   A symmetric matrix of p-values [variables x variables]
diff_test = function(x, y, return_cor=FALSE, pad=FALSE) {
    if (pad) {
        cboth = narray::stack(list(x=cor(x), y=cor(y)), along=3, fill=0)
        corx = cboth[,,"x"]
        cory = cboth[,,"y"]
    } else {
        narray::intersect(x, y, along=2)
        corx = cor(x)
        cory = cor(y)
    }
    delta_cor = cory - corx

    za = fisher_r2z(corx)
    zb = fisher_r2z(cory)

    na = narray::rrep(apply(x, 2, function(x) sum(!is.na(x))), ncol(x))
    nb = narray::rrep(apply(y, 2, function(x) sum(!is.na(x))), ncol(y))

    se = sqrt((1/(na-3))+(1/(nb-3)))
    z = (za-zb)/se

    pval = 2*pnorm(-abs(z))

    if (return_cor)
        list(x=corx, y=cory, delta_cor = delta_cor, p.value = pval)
    else
        list(delta_cor = delta_cor, p.value = pval)
}


 ZHPGVX Example Program Results

 Number of eigenvalues found =    2

 Eigenvalues
    -2.9936  0.5047
 Selected eigenvectors
          1       2
 1  -0.6626  0.2835
     0.2258 -0.5806

 2  -0.1164 -0.3769
    -0.0178 -0.3194

 3   0.9098 -0.3338
    -0.0000 -0.0134

 4  -0.6120  0.6663
    -0.5348  0.0000


# Assignment: ASSIGNMENT 0
# Name: Safwat-Taylor, Joshua
# Date: 2022/3/26

# Basics

## Add 8 and 5
8 + 5

## Subtract 6 from 22
22 - 6

## Multiply 6 by 7
6 * 7

## Add 4 to 6 and divide the result by 2
(4 + 6) / 2

## Compute 5 modulo 2
5 %% 2

## Assign the value 82 to the variable x
## Print x
x <- 82
x

## Assign the value 41 to the variable y
## Print y
y <- 41
y

## Assign the output of x + y to the variable z
## Print z
z <- x + y
z

## Assign the string value "DSC520" to the variable class_name
## Print the value of class_name
class_name <- "DSC520"
class_name

## Assign the string value of TRUE to the variable is_good
## Print the value of is_good
is_good <- TRUE

## Check the class of the variable is_good using the `class()` function
class(is_good)

## Check the class of the variable z using the `class()` function
class(z)

## Check the class of the variable class_name using the class() function
class(class_name)


counting_sort <- function(arr, minval, maxval) {
  r <- arr
  z <- 1
  for(i in minval:maxval) {
    cnt = sum(arr == i)
    while(cnt > 0) {
      r[z] = i
      z <- z + 1
      cnt <- cnt - 1
    }
  }
  r
}

# 140+1 instead of 140, since random numbers generated
# by runif are always less than the given maximum;
# floor(a number at most 140.9999...) is 140
ages <- floor(runif(100, 0, 140+1))
sorted <- counting_sort(ages, 0, 140)
print(sorted)


#  Calculating a Confidence Interval From a Normal Distribution
n<-50
a<-27.3
s<-12.1
#  we will use a 99% confidence level and wish to find the confidence interval
margin <- qnorm(0.995)*s/sqrt(n)
left_i <- a-margin
right_i <- a+margin
print("Confidence interval is")
print(left_i)
print(right_i)


# episode 01 of 2/7/2022

# demonstrate using R like a calculator
3 + 5
3 * 5
3 ^ 5

# declare variables/objects
# variables have 'types' text, numbers, etc.

# use this assignment operator
area_hectares <- 1.0

# you can use this, but later on,
# it may trip you up.
x = "My little text variable"

(area_hectares2 <- 1.0) # declare AND print it out

area_hectares2 # type the name of your
               # variable to print it out

# things run top to bottom -- OR
# in the order you choose.

area_acres <- 2.47 * area_hectares2
area_hectares2 <- 47

area_acres

# challenge
# make 3 new variables
# the 3rd one assigned from the first two.

r_length <- 47
r_width <- 4
r_area <- r_width * r_length

# functions and getting help
a <- 48
(b <- sqrt(a))

round(3.14159)

# args() give you some brief help
args(round)

round(3.14156, digits = 3)

# more help
?round

# vectors
# c() the 'c' is for 'combine' NOT 'concatenate'
hh_members <- c(3, 7, 10, 6)
hh_members

respondent_wall_type <- c("muddaub", "burntbricks", "sunbricks")

# inspect vector properties
length(hh_members)
length(respondent_wall_type)
str(hh_members)

# appending to vectors with c()
possessions <- c("bicycle", "radio", "television")
possessions
possessions <- c(possessions, "mobile phone")
possessions

typeof(possessions)
str(possessions)

# subsetting vectors
# calling specific pieces of them

respondent_wall_type
respondent_wall_type[2]
respondent_wall_type[c(3, 2)]

(more_respondent_wall_type <- respondent_wall_type[c(1, 2, 3, 1, 2, 1)])

# deal with missing values
# because you often can't do math
# on 'NA's'
rooms <- c(1, 2, 1, 1, NA, 3, 1, 3, 2, 1, 1, 8, 3, 1, NA, 1)

# select only the values that are NOT NA
rooms[!is.na(rooms)]

# count NA's
sum(is.na(rooms))

# count NOT NA's
sum(!is.na(rooms))

# final challenge
# how many houses have more than 2 rooms?
rooms_no_na <- rooms[!is.na(rooms)]
rooms_no_na

median(rooms, na.rm = TRUE)
median(rooms_no_na)

rooms_above_2 <- rooms_no_na[rooms_no_na > 2]
length(rooms_above_2)


# Program to find the H.C.F of two input number
# define a function
hcf <- function(x, y) {
# choose the smaller number
if(x > y) {
smaller = y
} else {
smaller = x
}
for(i in 1:smaller) {
if((x %% i == 0) && (y %% i == 0)) {
hcf = i
}
}
return(hcf)
}
# take input from the user
num1 = as.integer(readline(prompt = "Enter first number: "))
num2 = as.integer(readline(prompt = "Enter second number: "))
print(paste("The H.C.F. of", num1,"and", num2,"is", hcf(num1, num2)))


#' Interarrival times and arrival times of a poisson process
#'
#' @param probability The probability of success in the poisson process
#' @param events The number of events in the process (or \code{NULL} if defining
#'   the cut off point by the time)
#' @param time.running The amount of time for the process to run (or \code{NULL}
#'   if defining the cut off by the number of events)
#' @return An numeric matrix with 2 columns. The first column contains the interarrival
#'   times and the second contains the arrival times.
#' @export
#'
bernoulli.process = function(probability = .5, events = NULL, time.running = NULL) {
  stopifnot(!all(c(is.null(events), is.null(time.running))))
  stopifnot(probability >= 0 & probability <= 1)
  if(is.null(time.running)) {
    times = rgeom(events, probability) + 1
    results = mclapply(seq_len(events), FUN = function(i) c(times[i], sum(times[1:i])))
    return(do.call(rbind,results))
  } else {
    times = rgeom(ceiling(time.running*probability), probability)+1
    results = mclapply(seq_len(length(times)), FUN = function(i) c(times[i], sum(times[1:i])))
    while(results[[length(results)]][2] < time.running) {
      times = rgeom(max(c(10,ceiling(time.running*probability*.25))), probability) + 1
      results_sub = mclapply(seq_len(length(times)), FUN = function(i) {
        c(times[i], results[[length(results)]][2]+sum(times[1:i]))
      })
      results = append(results, results_sub)
    }
    results = do.call(rbind,results)
    return(results[results[,2] < time.running,])
  }
}


pn1 <- 1 - pnorm(80, 70, 10)
write(round(pn1 * 100, 2), stdout())
pn2 <- 1 - (pnorm(60, 70, 10) - pnorm(0, 70, 10))
write(round(pn2 * 100, 2), stdout())
pn3 <- pnorm(60, 70, 10)
write(round(pn3 * 100, 2), stdout())


#Simulate positions for n=8 sities
pos <- read.table("optimaltransport.ascii",header=F)
p = nrow(pos)
set.seed(345)
par(mfrow=c(1,1))
plot(pos)
dev.copy2pdf(file="../doc/example_trav_sale.pdf")

#Calculate pairwise distances between cities
d = as.matrix((dist(pos,diag=TRUE,upper=TRUE)))
#Convert to vector in order to access many components at a time
d = as.vector(d)

#Perform neighbor search, simulated annealing
#Random inizialization
#We implement the fact that the distribution must start and finish at home town
theta = c(1, sample(2:p,p-1), 1)

#Convert sequential pairs into index in the d-vector
ind = (theta[-p]-1)*p+theta[-1]
#Calculate total distance of order
V = sum(d[ind])
Vseq = V
Numit=50000
for(i in 1:Numit)
{
  tau = 100/i
  #tau = 1/log(i+1)
  #tau <- (0.8 + i/Numit/10)*tau
  #we never change the position of index=1 (home)
  ind2 = sample(2:p,2,replace=F)
  theta2 = theta
  theta2[ind2[1]] = theta[ind2[2]]
  theta2[ind2[2]] = theta[ind2[1]]
  ind2 = (theta2[-p]-1)*p+theta2[-1]
  V2 = sum(d[ind2])
  prob = exp((V-V2)/tau)
  u = runif(1)
  if(u<prob)
  {
    theta = theta2
    V = V2
  }
  Vseq = c(Vseq,V)
}
#par(mfrow=c(2,1),mar=c(0.5,1,0.5,1))
plot(pos)
lines(pos[theta,1],pos[theta,2])
points(pos[1,1],pos[1,2], type = 'o', col = 'red')
#dev.copy2pdf(file="../doc/example_trav_sale_SA.pdf")
plot.ts(Vseq)
show(min(Vseq))


#################################################################
#################################################################
#	Code for Project for the Mathematical Modelling module 	#
#	Author:Gianpiero Cea                                   	#
#################################################################
#
#################################################################
# First we install all the required packages.
# This should work but if there are any problems refer
# to the individual documentations
#################################################################
print('Install all required packages')

install.packages("mlbench")
install.packages("Amelia")
install.packages("bnlearn")
install.packages("BDgraph")
install.packages("corrplot")
install.packages("caret")

#################################################################
# Importing all the required libraries
#################################################################
print('#########################################################')
print('Part 0: Importing all libraries that we need')

#Part 0: Importing all libraries that we need:
#mlbench used to import the dataset
library(mlbench)
#used to do imputation of the values
library(Amelia)
#main library to work with Bayesian Network
library(bnlearn)
#possibly used for indirected graphs
library(BDgraph)
#used to plot a correlation plot
library(corrplot)
#used to test accuracy and other metric of models
library(caret)

##################################################################
# Cleaning the data
##################################################################
print('#########################################################')
print('Part 1: Cleaning Data: imputation/omission, visualisation')

# Part 1: Cleaning Data: imputation/omission, visualisation

# save the data in dataframe df
data(BreastCancer)
df <- BreastCancer
# check the missing values, OUTPUT: 16 NA's in 'Bare.nuclei'
summary(df)

#Omitting missing values
df.omit = na.omit(df)

#Imputing missing values
print('Imputing missing values')
## Using Amelia II:
print('Imputing values using Amelia II...')
#to.nom(df) turns a df of factors into a df of numerical values
to.nom <-function(df){
  df2 <- data.matrix(df)
  df2 <- data.frame(df2)
  return(df2)
}
df.num <- to.nom(df)
#to use amelia we can't use factors
res = amelia(df.num)
df.imputed <-df
df.imputed$Bare.nuclei <- as.factor(abs(floor(res$imputations[[1]]$Bare.nuclei)))
#we can have a comparison of our data before and after imputations
print('Comparison of the data before and after Amelia imputations')
summary(df)
summary(df.imputed)

## Using structural.em to impute data, learn from missing data
print('Imputing values using structural.em')
res<-structural.em(df[,2:11],return.all=TRUE)
df.imputed2 <- res$imputed
bn.fit.missing <-res$fitted
bn.missing <- res$dag

# Data correlation
print('Visualising correlation plot')
bc = cor(na.omit(df.num)[,2:11]) #create an object of the features
corrplot.mixed(bc)

#Split the data , p%-(1-p)%
	split <- function(df,p){
	a = floor(nrow(df)*(p/100))
	df.train <- df[1:a,]
	df.test <- df[(a+1):nrow(df),]
	return(list(train =df.train,test =df.test))
	}

df.omit.train <- split(df.omit[,2:11],20)$train
df.omit.test <- split(df.omit[,2:11],20)$test

df.imputed.train <- split(df.imputed[,2:11],20)$train
df.imputed.test <- split(df.imputed[,2:11],20)$test

df.imputed2.train <- split(df.imputed2,20)$train
df.imputed2.test <- split(df.imputed2,20)$test
##################################################################
# Structure learning
#################################################################
print('#########################################################')
print('Structural learning')
# Part 2: Structure Learning

#the following functions applies several algorithms  to the data and returns
#the structure learned
struc.learn <- function(df){
	#Classifiers

	bn.naive.bayes <- naive.bayes(df,"Class")
	bn.tree.bayes <- tree.bayes(df,"Class")

	#Score Based
	bn.hc <-hc(df)
	bn.tabu <-tabu(df)

	#Constraint Based
	#here we give the option parameter test
	bn.gs <- gs(df)
	bn.iamb <-iamb(df)
	bn.fast.iamb <- fast.iamb(df)
	bn.inter.iamb <-inter.iamb(df)
	bn.mmpc <- mmpc(df)
	bn.si.hiton.pc <- si.hiton.pc(df)

	return(list(naive.bayes = bn.naive.bayes,tree.bayes = bn.tree.bayes, hc = bn.hc,tabu=bn.tabu, gs=bn.gs,iamb =bn.iamb,fast.iamb =bn.fast.iamb,mmpc=bn.mmpc,si.hiton.pc=bn.si.hiton.pc))
}

# Here we do strucutural learning for the three different datasets
# ...omit, imputed and imputed2

structures.omit <- struc.learn(df.omit.train)
#we also had the bn learned from the missing data!
structures.omit[[length(structures.omit)+1]] <- bn.missing
print('Structures learnt for omit dataset')

structures.imputed <-struc.learn(df.imputed.train)
print('Structures learnt for imputed dataset')

structures.imputed2 <- struc.learn(df.imputed2.train)
print('Structures learnt for imputed2 dataset')

# We plot all the different structures learned for structures.omit
par(mfrow=c(3,3))
for(i in 1:9){plot(structures.omit[[i]],main=names(structures.omit)[[i]])}
plot(structures.omit[[10]],main=names(structures.omit)[[10]])

# We plot all the different structures learned for structures.imputed
par(mfrow=c(3,3))
for(i in 1:9){plot(structures.imputed[[i]],main=names(structures.imputed)[[i]])}

# We plot all the different structures learned for structures.imputed2
par(mfrow=c(3,3))
for(i in 1:9){plot(structures.imputed2[[i]],main=names(structures.imputed2)[[i]])}

##Compare the hc and tabu graph. OUTPUT: they are the same
compare(structures.imputed2$hc,structures.imputed2$tabu)
##Get a string representing the model:
##OUTPUT:"[Cell.size][Class|Cell.size][Cl.thickness|Class][Cell.shape|Class][Marg.adhesion|Class][Epith.c.size|Class][Bare.nuclei|Class][Bl.cromatin|Class][Normal.nucleoli|Class][Mitoses|Class]"
modelstring(structures.imputed2$tabu)

# Compare graphically the structures
graphviz.compare(structures.omit$naive.bayes,structures.omit$tree.bayes)
##################################################################
# Parameter learning
##################################################################
print('#########################################################')
print('Part 3: Parameter Learning')
# Part 3: Parameter Learning
## Maximum Likelihood Estimate
#we pick an ordering of the variables to assign a direction to the Constraint
#based structures (gs,iamb...)
ordering = node.ordering(structures.imputed2$tree.bayes)
#lapply({function(x)pdag2dag(structures.omit$x,names(df.omit.train))},df.omit.train[4:9])
#bn.fit.omit <-lapply({function(dag)bn.fit(dag,method='mle')},structures.omit)
 gs<-pdag2dag(structures.omit$gs,ordering)
 iamb<-pdag2dag(structures.omit$iamb,ordering)
 fast.iamb<-pdag2dag(structures.omit$fast.iamb,ordering)
 mmpc<-pdag2dag(structures.omit$mmpc,ordering)
 si.hiton.pc<-pdag2dag(structures.omit$si.hiton.pc,ordering)

structures.omit$gs = gs
structures.omit$iamb = iamb
structures.omit$fast.iamb = fast.iamb
structures.omit$mmpc = mmpc
structures.omit$si.hiton.pc = si.hiton.pc

structures.imputed2$gs = gs
structures.imputed2$iamb = iamb
structures.imputed2$fast.iamb = fast.iamb
structures.imputed2$mmpc = mmpc
structures.imputed2$si.hiton.pc = si.hiton.pc

structures.imputed$gs = gs
structures.imputed$iamb = iamb
structures.imputed$fast.iamb = fast.iamb
structures.imputed$mmpc = mmpc
structures.imputed$si.hiton.pc = si.hiton.pc

#Parameter Learning for omit data
bn.fit.omit <-lapply(structures.omit,{function(dag)bn.fit(dag,method='mle',data=df.omit.train)})
bn.fit.omit.bayes <-lapply(structures.omit,{function(dag)bn.fit(dag,method='bayes',data=df.omit.train)})
#Parameter Learning for imputed data
bn.fit.imputed <-lapply(structures.imputed,{function(dag)bn.fit(dag,method='mle',data=df.imputed.train)})
bn.fit.imputed.bayes <-lapply(structures.imputed,{function(dag)bn.fit(dag,method='bayes',data=df.imputed.train)})
#Parameter Learning for imputed2 data
bn.fit.imputed2 <-lapply(structures.imputed2,{function(dag)bn.fit(dag,method='mle',data=df.imputed2.train)})
bn.fit.imputed2.bayes <-lapply(structures.imputed2,{function(dag)bn.fit(dag,method='bayes',data=df.imputed2.train)})

#Visualise as an example one of the node Conditional probability table:
bn.fit.barchart(bn.fit.imputed2$tabu$Cl.thickness)

##################################################################
# Accuracy comparison & Inference
##################################################################
print('#########################################################')
print('Part 4: Accuracy comparison & Inference')
# Part 4: Accuracy comparison & Inference
# gets the predictions on the three kinds of test sets (omit,imputed, imputed2)
predicted.omit <- lapply(bn.fit.omit,{function(fit)predict(fit, node = "Class", data = df.omit.test)})
predicted.omit.bayes <- lapply(bn.fit.omit.bayes,{function(fit)predict(fit, node = "Class", data = df.omit.test)})

predicted.imputed <- lapply(bn.fit.imputed,{function(fit)predict(fit, node = "Class", data = df.imputed.test)})
predicted.imputed.bayes <- lapply(bn.fit.imputed.bayes,{function(fit)predict(fit, node = "Class", data = df.imputed.test)})

predicted.imputed2 <- lapply(bn.fit.imputed,{function(fit)predict(fit, node = "Class", data = df.imputed.test)})
predicted.imputed2.bayes <- lapply(bn.fit.imputed.bayes,{function(fit)predict(fit, node = "Class", data = df.imputed2.test)})

#print everything
##############################################################################
print('imputed')
for(i in 1:9){
	print(names(predicted.imputed)[[i]])
	print(confusionMatrix(unlist(predicted.imputed[i]),unlist(df.imputed.test$Class)))
}
for(i in 1:9){
	print(names(predicted.imputed.bayes)[[i]])
	print(confusionMatrix(unlist(predicted.imputed.bayes[i]),unlist(df.imputed.test$Class)))
}
##############################################################################
print('omit')
for(i in 1:10){
	print(names(predicted.omit)[[i]])
	print(confusionMatrix(unlist(predicted.omit[i]),unlist(df.omit.test$Class)))
}
for(i in 1:10){
	print(names(predicted.omit.bayes)[[i]])
	print(confusionMatrix(unlist(predicted.omit.bayes[i]),unlist(df.omit.test$Class)))
}
##############################################################################
print('imputed2')
for(i in 1:9){
	print(names(predicted.imputed2)[[i]])
	print(confusionMatrix(unlist(predicted.imputed2[i]),unlist(df.imputed2.test$Class)))
}
for(i in 1:9){
	print(names(predicted.imputed2.bayes)[[i]])
	print(confusionMatrix(unlist(predicted.imputed2.bayes[i]),unlist(df.imputed2.test$Class)))
}

#Approximate inference

#example: What is the probability that the tumor is malignant if we a Cell.size
#of 4 and Bare.nuclei of 2

#we need to repeat since the function cpquery is stochastic

l<-vector("list", 2000)
for( i in 1:2000)
{
l[i] <- cpquery(bn.fit.imputed$naive.bayes,event=(Class == "malignant"),evidence=(Cell.size=="4")&(Bare.nuclei=="2"))
}

mean(as.numeric(l))
############################################################################
# UNDIRECTED GRAPH:

library(BDgraph)
#problem with bigger iter
 res<-bdgraph(df.imputed2,method ="gcgm", iter= 100, print = 10)
summary(res)

#we can also learn another structure using Marginal Pseudo Likelihhod
res2<-bdgraph.mpl(df.imputed2,iter= 1000)
summary(res2)

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