# ......................................................................................
# ..................Exercise 1 - Brief introduction to R, Combinatorics.................
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

# First we will go through some basics of R.
#
#  Brief introduction to R ####
#

# simple arithmetic operations
2+4
5/2

# BEWARE of brackets! Only round ones are used for counting!
# Square and compound have a different role in R.!
(((10+2)*(340-33))-2)/3

# combination number, factorials
choose(10,2)
factorial(4)

# data types ->numeric, character, logical,(complex)
# the class function determines the type of the object
a=2+3
class(a)

b="some text"
class(b)

c=(1>3)
class(c)

d=3+1i
class(d)

# * data structures in R ####
#
# - vector (column vector)
#
# - factor (special case of vector)
#
# - matrix (matrix with dimensions n x m)
#
# - data.frame (data frame with columns representing diferent types of informations and
# rows representing single records)

# vector definition
a = c(3,4,6,7)
a <- c(3,4,6,7)
a[2]

# other options
rep(1,4) # creates a vector with four ones

seq(1,10,2) # sequence from 1 to 10 with step 2

1:10  # sequence from 1 to 10 with step 1

b=c("A","B","C","D")
b

class(b)

# redefining an object to another type - eg as.vector, as.matrix, as.factor,...
b=as.factor(b)
b

# working with vectors - merging by columns/rows
cbind(a,b)

rbind(a,b)

c(a,b)

# matrix definition
A=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3)
B=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3,byrow=TRUE)
C=matrix(c(3,4,6,7,3,2),nrow=3,ncol=2)

B

B[1,3]

A[1,]

A[,2:3]

# diagonal matrix
diag(4)

diag(4,2)

# matrix operations - pay attention to matrix multiplication -> %*%
A+B

A-B

A*B

A%*%C


# Calculate slope and aspect of a digital terrain model

slope<-function(r, res=1){
  # returns a slope surface of elevation raster r of resolution res,
  # according to Burrough et McDonnell 2000, p. 191
  newr<-matrix(0, nrow=nrow(r), ncol=ncol(r))
  h<-nrow(r)
  w<-ncol(r)
  for(i in 2:(h-1)){
    for(j in 2:(w-1)){
      newr[i,j]<-sqrt( ((r[i+1,j]-r[i-1,j])/(2*res))^2 + ((r[i,j+1]-r[i,j-1])/(2*res))^2 )
    }
  }
  newr[1,]<-0; newr[h,]<-0; newr[,1]<-0; newr[,w]<-0; #adjust border
  return(newr)
}

# parameters
input_terrain <- 'c:/temp/terrain.txt'

# read data
m<-as.matrix(read.table(input_terrain))

# calculate slope
s<-slope(m)

# plot results
image(m, main="elevation")
image(s, main="slope")


## Strategy: For a bunch of Ns, compute the z_star by achieving desired alpha, then
## compute what beta would be for that N using the acquired z_star.
## Pick the smallest N at which beta crosses the desired value

# Inputs:
#   The desired alpha for a two-tailed test
# Returns: The z-critical value
get_z_star = function(alpha) {
    return(-qnorm(alpha / 2))
}

# Inputs:
#   z-star: The z-critical value
#   s: The standard error of the metric at N=1
#   d_min: The practical significance level
#   N: The sample size of each group of the experiment
# Returns: The beta value of the two-tailed test
get_beta = function(z_star, s, d_min, N) {
    SE = s /  sqrt(N)
    return(pnorm(z_star * SE, mean=d_min, sd=SE))
}

# Inputs:
#   s: The standard error of the metric with N=1 in each group
#   d_min: The practical significance level
#   Ns: The sample sizes to try
#   alpha: The desired alpha level of the test
#   beta: The desired beta level of the test
# Returns: The smallest N out of the given Ns that will achieve the desired
#          beta. There should be at least N samples in each group of the experiment.
#          If none of the given Ns will work, returns -1. N is the number of
#          samples in each group.

required_size = function(s, d_min, Ns=1:20000, alpha=0.05, beta=0.2) {
    for (N in Ns) {
        if (get_beta(get_z_star(alpha), s, d_min, N) <= beta) {
            return(N)
        }
    }

    return(-1)
}

# Example analytic usage
# This is the example from Lesson 1, for which the online calculate gave 3,623
# samples in each group

# s is the pooled standard error for N=1 in each group,
# which is sqrt(p*(1-p)*(1/1 + 1/1))
required_size(s=sqrt(0.1*0.9*2), d_min=0.02)

# Sizing: Example
# Cookie-based diversion
# Since the standard error is proportional to 1/sqrt(N), s, or
# the standard error for N=1, is equal to the mesaured standard error with 5000
# in each group times sqrt(5000)
required_size(s=0.00515*sqrt(5000), d_min=0.02)
# User-id-based diversion
required_size(s=0.0119*sqrt(5000), d_min=0.02)

# Sizing: Quiz
# Original size
required_size(s=0.0628*sqrt(1000), d_min=0.01, Ns=seq(10, 500000, 100))
# Size with event-based diversion
required_size(s=0.0209*sqrt(1000), d_min=0.01, Ns=seq(10, 500000, 100))
# Size with event-based diversion and English-only traffic
required_size(s=0.0188*sqrt(1000), d_min=0.015)
# Size with cookie-based diversion, English-only traffic, and
# click-through-probability instead of click-through-rate
required_size(s=0.0445*sqrt(1000), d_min=0.015, Ns=seq(10, 500000, 100))


###CHAPTER 5: BIAS VARIANCE TRADE-OFF
N <- 500
x <- seq(.09,.5,len=N)
f <- 2*sin(1/x)

y <- f + rnorm(N)
postscript("Plots/plot-05-01.ps")
plot(x,y,main="True f(x)=5 sin(1/x) and observations")
lines(x,f,type="l")
dev.off()

NN <- 5

postscript("Plots/plot-05-02.ps")
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N)
       ksmooth(x,y,kernel="box",bandwidth=.01)$y
     })

par(mfrow=c(2,2),mai=c(0,0,0,0),oma=c(1,1,1,1))
plot(x,f,type="l",lwd=1.5,ylim=range(c(f,as.vector(results))))
lines(x,results[,1],lty=4)

plot(x,f,ylim=range(results),type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N)
       ksmooth(x,y,kernel="box",bandwidth=.1)$y
     })

plot(x,f,type="l",lwd=1.5)
lines(x,results[,1],lty=4)

plot(x,f,type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
dev.off()


### CHALLENGER ###

# Get the data
library(ggplot2)
library(GGally)
library(dplyr)

data_1 = read.delim('challenger_data.txt')

ggplot(data_1, aes(T, I)) +
  geom_point(color = 'dark blue', alpha = .2) +
  xlab('Temperature') +
  ylab('Damage') +
  ggtitle('Challenger - temperature vs damage')

# Regression
model_1 = lm(I ~ T, data)

summary(model_1)

# Plot with reg line
ggplot(data_1, aes(T, I)) +
  geom_point(color = 'dark blue', alpha = .2) +
  xlab('Temperature') +
  ylab('Damage') +
  ggtitle('Challenger - temperature vs damage') +
  geom_line(aes(T, fitted(model_1)), color = 'red')

# Predict for 31 degrees
predict(model_1, data.frame(T = 31), interval = 'predict')

# Posterior prediction interval (same as frequentist)
pred_1 = predict(model_1, data.frame(T = 31))

k   = length(model_1$coefficients) - 1 # Subtract one to ignore intercept
SSE = sum(model_1$residuals**2)
n   = length(model_1$residuals)

resid_std_error = sqrt(SSE / (n-(1+k))) # Residual Standard Error

pred_1 - resid_std_error * qt(.975, model_1$df.residual) * sqrt(1 + 1/23)
# 10.82052 - 2.102*qt(.975,21)*sqrt(1+1/23+((31-mean(T))^2/22/var(T)))

# posterior probability that damage index is greater than zero
1-pt((0-10.82052)/(2.102*sqrt(1+1/23+((31-mean(T))^2/22/var(T)))),21)

### HEIGHT ###

# Get the data
data_2 = read.delim('http://www.randomservices.org/random/data/Galton.txt')

# Plot
data_2 %>% select(-c('Family')) %>% ggpairs(., lower = list(continuous = wrap("smooth", alpha = 0.3, size=0.1)))

# Regress
model_2 = lm(Height ~ Father + Mother + Gender, data_2)

summary(model_2)

### GOLFERS ###

# Get the data
data_3 = read.delim('http://www.stat.ufl.edu/~winner/data/pgalpga2008.dat', header = FALSE, sep = ' ')
data_3 = data_3[, c(4, 8, 15)]

colnames(data_3) <- c('dist', 'accuracy', 'gender')   # 1 = F, 2 = M

head(data_3)

data_3 %>% filter(gender == 1) %>% ggplot(., aes(dist, accuracy)) +
                                     geom_point(alpha = .5) + geom_smooth(method = 'lm') +
                                     ggtitle('Mean distance vs accuracy - Females')

data_3 %>% filter(gender == 2) %>% ggplot(., aes(dist, accuracy)) +
                                     geom_point(alpha = .5) + geom_smooth(method = 'lm') +
                                     ggtitle('Mean distance vs accuracy - Males')

# Fit a linear regression model to the female golfer data only with
# drive distance as the explanatory variable x and accuracy as the response variable y.
# Use the standard reference (non-informative) prior.

# Recall that in a linear regression, we are modeling E(y) = b0 + b1x.

# In this particular model, the intercept term is not interpretable,
# as we would not expect to see a 0-yard drive (but it is still necessary).
# Predictions should generally be made only within the range of the observed data.

# Report the posterior mean estimate of the slope parameter b relating drive distance to accuracy.
# Round your answer to two decimal places.

data_3_F = data_3 %>% filter(gender == 1)

model_3 = lm(accuracy ~ dist, data_3_F)

summary(model_3)

# Use the posterior mean estimates of the model coefficients to obtain a posterior predictive
# mean estimate of driving accuracy for a new female golfer whose average driving distance
# is x = 260 yards. Round your answer to one decimal place.

predict(model_3, data.frame(dist = 260), interval = 'predict')


# -----------------------
# App Title: t-test
# Author: Jimmy Wong
# -----------------------

#####################################################################################################################
#####################################################################################################################
## t-distribution shading area function
#####################################################################################################################
#####################################################################################################################

t.dist.area = function(tstat,tail,df)
{
  x = seq(-5,5,length.out=200)
  df = round(df, digits=3)

  if(tail=="right")
  {
    xmin=tstat
    xmax=5

    area = seq(xmin,xmax,length.out=200)
    dat = data.frame(x=area,ymin=0,ymax=dt(area,df=df))

    graph = ggplot() + geom_line(data.frame(x=x, y=dt(x,df=df)), mapping=aes(x=x, y=y)) +
      geom_ribbon(data=dat, mapping=aes(x=x, ymin=ymin, ymax=ymax), fill="navy") +
      ggtitle(paste("t-distribution with", df, "degrees of freedom")) +
      xlab("t-values") + ylab("Relative frequency") + theme_bw()
  } else if(tail=="left")
  {
    xmin=-5
    xmax=tstat

    area = seq(xmin,xmax,length.out=200)
    dat = data.frame(x=area,ymin=0,ymax=dt(area,df=df))

    graph = ggplot() + geom_line(data.frame(x=x, y=dt(x,df=df)), mapping=aes(x=x, y=y)) +
      geom_ribbon(data=dat, mapping=aes(x=x, ymin=ymin, ymax=ymax), fill="navy") +
      ggtitle(paste("t-distribution with", df, "degrees of freedom")) +
      xlab("t-values") + ylab("Relative frequency") + theme_bw()
  } else if(tail=="both")
  {
    xmin1=abs(tstat)
    xmax1=5
    area1 = seq(xmin1,xmax1,length.out=200)
    dat1 = data.frame(x=area1,ymin1=0,ymax1=dt(area1,df=df))

    xmin2=-5
    xmax2=-abs(tstat)
    area2 = seq(xmin2,xmax2,length.out=200)
    dat2 = data.frame(x=area2,ymin2=0,ymax2=dt(area2,df=df))

    graph = ggplot() + geom_line(data.frame(x=x, y=dt(x,df=df)), mapping=aes(x=x, y=y)) +
      geom_ribbon(data=dat1, mapping=aes(x=x, ymin=ymin1, ymax=ymax1),fill="navy") +
      geom_ribbon(data=dat2, mapping=aes(x=x, ymin=ymin2, ymax=ymax2),fill="navy") +
      ggtitle(paste("t-distribution with", df, "degrees of freedom")) +
      xlab("t-values") + ylab("Relative frequency") + theme_bw()
  }
  return(graph)
}

#####################################################################################################################
#####################################################################################################################
## Library and data sets
#####################################################################################################################
#####################################################################################################################

options(shiny.maxRequestSize=30*1024^2)
library(ggplot2)
library(shinyBS)
data(faithful)
data(mtcars)

#####################################################################################################################
#####################################################################################################################
## Shiny server
#####################################################################################################################
#####################################################################################################################

shinyServer(function(input, output) {
  #####################################################################################################################
  #####################################################################################################################
  ## Data Exploration Panel
  #####################################################################################################################
  #####################################################################################################################

  data = reactive({
    if(is.null(input$file) & !input$usedata)
    {
      return(NULL)
    } else if(!is.null(input$file) & !input$usedata)
    {
      file = read.csv(input$file$datapath, header=input$header, sep=input$sep, quote=input$quote)
      return(file)
    } else if(input$sampdat==1 & input$usedata)
    {
      return(data.frame(eruptions=faithful$eruptions))
    } else if(input$sampdat==2 & input$usedata)
    {
      mtcars$amcoded = rep(NA,length(mtcars$hp))
      mtcars$amcoded[which(mtcars$am==0)] = "automatic"
      mtcars$amcoded[which(mtcars$am==1)] = "manual"
      return(data.frame(transmission=mtcars$amcoded, horsepower=mtcars$hp))
    }
    })

  output$data.tab = renderDataTable({
    if(!input$usedata) data()
  })

  output$data.tab1 = renderDataTable({
    if(input$usedata) data()
  })

  output$datagraph = renderPlot({
    if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
    {
      dat=unlist(data())
      dat1=data.frame(x=as.numeric(as.character(dat)))

      if(input$usedata)
        lab = "Eruption times"
      else
        lab = paste(names(data())[1])

      ggplot(data=dat1) + geom_histogram(aes(x=x), fill="navy", alpha=.5) +
        xlab(lab) + ylab("Frequency") +
        ggtitle(paste("Histogram of",lab)) + theme_bw()
    } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
    {
      dat=data()
      dat1=data.frame(x=dat[[1]],y=dat[[2]])
      if(length(unique(dat1$x))>length(unique(dat1$y)))
      {
        dat1$x = as.numeric(as.character(dat1$x))
        ggplot(data=dat1) + geom_boxplot(aes(x=factor(y),y=x,fill=factor(y)),alpha=.5) +
          xlab(paste(names(dat)[2])) + ylab(paste(names(dat)[1])) + theme_bw() +
          ggtitle(paste("Boxplots of",paste(names(dat)[1]),"by",paste(names(dat)[2]))) +
          scale_fill_manual(name=paste(names(dat)[1]),values=c("seagreen2","gold2")) +
          theme(legend.position="bottom")
      } else
      {
        dat1$y = as.numeric(as.character(dat1$y))
        ggplot(data=dat1) + geom_boxplot(aes(x=factor(x),y=y,fill=factor(x)),alpha=.5) +
          xlab(paste(names(dat)[1])) + ylab(paste(names(dat)[2])) + theme_bw() +
          ggtitle(paste("Boxplots of",paste(names(dat)[2]),"by",paste(names(dat)[1]))) +
          scale_fill_manual(name=paste(names(dat)[2]),values=c("seagreen2","gold2")) +
          theme(legend.position="bottom")
      }
    } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
    {
      dat=data()
      dat1=data.frame(x=c(as.numeric(as.character(dat[[1]])),as.numeric(as.character(dat[[2]]))),
                       y=c(rep(names(dat)[1],length(dat[[1]])),rep(names(dat)[2],length(dat[[2]]))))
       ggplot(data=dat1) + geom_boxplot(aes(x=factor(y),y=x,fill=factor(y)),alpha=.5) +
        xlab("Explanatory variable") + ylab("Response variable") +
        scale_fill_manual(name="",values=c("seagreen2","gold2")) +
        ggtitle("Boxplots") + theme_bw() + theme(legend.position="bottom")
    }
  })

  output$summarystats = renderTable({
    if(input$displaystats & ((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata)))
    {
      vec = as.numeric(as.character(data()[[1]]))
      table = t(matrix(c((as.matrix(summary(vec)[1:6])),
                         round(sd(vec,na.rm=TRUE)))))

      if(input$usedata)
        rownames(table) = "Eruption times"
      else
        rownames(table) = names(data())[[1]]

      colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
      return(table)
    } else if(input$displaystats & ((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata)))
    {
      dat=data()
      dat1=data.frame(x=dat[[1]],y=dat[[2]])
      if(length(unique(dat1$x)) > length(unique(dat1$y)))
      {
        dat1$y = factor(dat1$y)
        dat1$x = as.numeric(as.character(dat1$x))
        dat1 = dat1[which(complete.cases(dat1)),]
        sum = tapply(dat1$x,dat1$y,summary)
        table = data.frame(matrix(c(sum[[1]],sum[[2]]),nrow=2,ncol=6,byrow=TRUE))
        std = tapply(dat1$x,dat1$y,sd,na.rm=TRUE)
        table$sd[1] = round(std[1],digits=2)
        table$sd[2] = round(std[2],digits=2)
        table = as.matrix(table)
        colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
        rownames(table) = c(levels(dat1$y)[1],levels(dat1$y)[2])
        return(table)
      } else if(length(unique(dat1$x)) < length(unique(dat1$y)))
      {
        dat1$x = factor(dat1$x)
        dat1$y = as.numeric(as.character(dat1$y))
        dat1 = dat1[which(complete.cases(dat1)),]
        sum = tapply(dat1$y,dat1$x,summary)
        table = data.frame(matrix(c(sum[[1]],sum[[2]]),nrow=2,ncol=6,byrow=TRUE))
        std = tapply(dat1$y,dat1$x,sd)
        table$sd[1] = round(std[1],digits=2)
        table$sd[2] = round(std[2],digits=2)
        table = as.matrix(table)
        colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
        rownames(table) = c(levels(dat1$x)[1],levels(dat1$x)[2])
        return(table)
      }
    } else if(input$displaystats & ((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata)))
    {
      dat = data()
      dat[,1] = as.numeric(as.character(dat[,1]))
      dat[,2] = as.numeric(as.character(dat[,2]))
      table = data.frame(t(as.matrix(apply(dat,2,summary)[-7,])))
      table$sd[1] = round(sd(dat[,1],na.rm=TRUE),digits=2)
      table$sd[2] = round(sd(dat[,2],na.rm=TRUE),digits=2)
      table = as.matrix(table)
      colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
      return(table)
    }
  })

  #####################################################################################################################
  #####################################################################################################################
  ## T-test Panel
  #####################################################################################################################
  #####################################################################################################################

  output$info = renderUI({
    HTML(as.character(code("Click here for hypothesis test information.")))
  })

  output$onesample = renderUI({
    HTML(as.character(code("Click here for one-sample t-test information.")))
  })

  output$twosample = renderUI({
    HTML(as.character(code("Click here for two-sample t-test information.")))
  })

  output$hypo1 = renderUI({
    if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
    {
      if(input$alt1=="less than")
        HTML("Ho: μ =", input$null1,"
 Ha: μ <",input$null1)
      else if(input$alt1=="greater than")
        HTML("Ho: μ =", input$null1,"
 Ha: μ >",input$null1)
      else
        HTML("Ho: μ =", input$null1,"
 Ha: μ ≠",input$null1)
    }
  })

  output$hypo2 = renderUI({
    if((input$datformat!=1 & !input$usedata) | (input$sampdat!=1 & input$usedata))
    {
      if(input$alt2=="less than")
        HTML("Ho: μ1-μ2 =",input$null2,
             "
 Ha: μ1-μ2 <",input$null2)
      else if(input$alt2=="greater than")
        HTML("Ho: μ1-μ2 =",input$null2,
             "
 Ha: μ1-μ2 >",input$null2)
      else
        HTML("Ho: μ1-μ2 =",input$null2,
             "
 Ha: μ1-μ2 ≠",input$null2)
    }
  })

  mod = reactive({
    input$teststart
    isolate({
    if(input$teststart>0)
    {
      if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
      {
        if(input$alt1=="less than")
          mod = t.test(x=as.numeric(as.character(unlist(data()))),alternative="less",mu=input$null1,conf.level=1-input$alpha)
        else if(input$alt1=="greater than")
          mod = t.test(x=as.numeric(as.character(unlist(data()))),alternative="greater",mu=input$null1,conf.level=1-input$alpha)
        else
          mod = t.test(x=as.numeric(as.character(unlist(data()))),alternative="two.sided",mu=input$null1,conf.level=1-input$alpha)
      } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        if(length(unique(dat[[1]])) > length(unique(dat[[2]])))
        {
          if(input$alt2=="less than")
            mod = t.test(as.numeric(as.character(dat[[1]]))~dat[[2]],
                         alternative="less",mu=input$null2,conf.level=1-input$alpha)
          else if(input$alt2=="greater than")
            mod = t.test(as.numeric(as.character(dat[[1]]))~dat[[2]],
                         alternative="greater",mu=input$null2,conf.level=1-input$alpha)
          else
            mod = t.test(as.numeric(as.character(dat[[1]]))~dat[[2]],
                         alternative="two.sided",mu=input$null2,conf.level=1-input$alpha)
        } else
        {
          if(input$alt2=="less than")
            mod = t.test(as.numeric(as.character(dat[[2]]))~dat[[1]],
                         alternative="less",mu=input$null2,conf.level=1-input$alpha)
          else if(input$alt2=="greater than")
            mod = t.test(as.numeric(as.character(dat[[2]]))~dat[[1]],
                         alternative="greater",mu=input$null2,conf.level=1-input$alpha)
          else
            mod = t.test(as.numeric(as.character(dat[[2]]))~dat[[1]],
                         alternative="two.sided",mu=input$null2,conf.level=1-input$alpha)
        }
      } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        if(input$alt2=="less than")
          mod = t.test(x=as.numeric(as.character(dat[[1]])),y=as.numeric(as.character(dat[[2]])),
                       alternative="less",mu=input$null2,conf.level=1-input$alpha)
        else if(input$alt2=="greater than")
          mod = t.test(x=as.numeric(as.character(dat[[1]])),y=as.numeric(as.character(dat[[2]])),
                       alternative="greater",mu=input$null2,conf.level=1-input$alpha)
        else
          mod = t.test(x=as.numeric(as.character(dat[[1]])),y=as.numeric(as.character(dat[[2]])),
                       alternative="two.sided",mu=input$null2,conf.level=1-input$alpha)
      }
    }
    })
  })

  output$est=renderUI({
    if(input$teststart>0 & input$showpoint & ((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata)))
    {
      HTML("x̅ =",round(mod()$estimate[1],2))
    } else if(input$teststart>0 & input$showpoint & ((input$datformat!=1 & !input$usedata) | (input$sampdat!=1 & input$usedata)))
    {
      HTML("x&#7731 =",round(mod()$estimate[1],2),"
 x&#7732 =",round(mod()$estimate[2],2),
           "
 x&#7731 - x&#7732 =",round(mod()$estimate[1]-mod()$estimate[2],2))
    }
  })

  output$test = renderTable({
    input$teststart
    isolate({
    if(input$teststart>0)
    {
      tab = matrix(c(mod()$parameter,mod()$statistic,mod()$p.value),nrow=1)
      colnames(tab) = c("df","t-statistic","p-value")
      rownames(tab) = "Values"
      tab
    }
    })
  })

  output$tdist = renderPlot({
    input$teststart
    isolate({
    if(input$alt1=="less than" | input$alt2=="less than")
    {
      tail="left"
    } else if(input$alt1=="greater than" | input$alt2=="greater than")
    {
      tail="right"
    } else if(input$alt1=="two-sided" | input$alt2=="two-sided")
    {
      tail="both"
    }

    return(t.dist.area(mod()$statistic,tail=tail,mod()$parameter))
    })
  })

  output$citab = renderTable({
    if(input$ci & input$teststart>0)
    {
      tab = matrix(c(mod()$conf.int[1],mod()$conf.int[2]),nrow=1)
      colnames(tab) = c("Lower bound","Upper bound")
      rownames(tab) = paste(round(1-input$alpha, digits=3)*100,"% CI",sep="")
      tab
    }
  })

  #####################################################################################################################
  #####################################################################################################################
  ## Diagnostics Panel
  #####################################################################################################################
  #####################################################################################################################

  output$qqplot = renderPlot({
      if((input$datformat==1 & !input$usedata) | (input$sampdat==1 & input$usedata))
      {
        dat=unlist(data())
        dat1=data.frame(x=as.numeric(as.character(dat)))
        ggplot(data=dat1, aes(sample=x)) + stat_qq(geom="point",color="navy",shape=1) +
          theme_bw() + theme(text=element_text(size=15)) + ggtitle("Q-Q Plot")
      } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        dat1=data.frame(x=dat[[1]],y=dat[[2]])
        if(length(unique(dat[[1]])) > length(unique(dat[[2]])))
        {
          dat1$x=as.numeric(as.character(dat1$x))
          ggplot(data=dat1, aes(sample=x)) + stat_qq(aes(color=factor(y)),geom="point",shape=1) + theme_bw() +
            theme(text=element_text(size=15)) + ggtitle("Q-Q Plot") + facet_wrap(~y) +
            scale_color_manual(name="", values=c("navy","gold2")) + guides(color=FALSE)
        } else
        {
          dat1$y=as.numeric(as.character(dat1$y))
          ggplot(data=dat1, aes(sample=y)) + stat_qq(aes(color=factor(x)),geom="point",shape=1) + theme_bw() +
            theme(text=element_text(size=15)) + ggtitle("Q-Q Plot") + facet_wrap(~x) +
            scale_color_manual(name="", values=c("navy","gold2")) + guides(color=FALSE)
        }
      } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        dat1=data.frame(x=c(as.numeric(as.character(dat[[1]])),as.numeric(as.character(dat[[2]]))),
                        y=c(rep(names(dat)[1],length(dat[[1]])),rep(names(dat)[2],length(dat[[2]]))))
        ggplot(data=dat1, aes(sample=x)) + stat_qq(aes(color=factor(y)),geom="point",shape=1) + theme_bw() +
          theme(text=element_text(size=15)) + ggtitle("Q-Q plot") + facet_wrap(~y) +
          scale_color_manual(name="", values=c("navy","gold2")) + guides(color=FALSE)
      }
  })

  output$sw = renderTable({
      if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
      {
        dat=unlist(data())
        dat1=data.frame(x=as.numeric(as.character(dat)))

        validate(
          need(try(shapiro.test(dat1$x)), "Do not need to conduct normality test")
        )

        norm = shapiro.test(dat1$x)

        tab = matrix(c(norm$statistic,norm$p.value),nrow=1)
        colnames(tab) = c("W statistic","p-value")
        rownames(tab) = "Data"
        tab
      } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        dat1=data.frame(x=dat[[1]],y=dat[[2]])
        if(length(unique(dat[[1]])) > length(unique(dat[[2]])))
        {
          dat1$x=as.numeric(as.character(dat1$x))

          norm1 = shapiro.test(dat1$x[which(dat1$y==unique(dat1$y)[1])])
          norm2 = shapiro.test(dat1$x[which(dat1$y==unique(dat1$y)[2])])

          tab = matrix(c(norm1$statistic,norm2$statistic,norm1$p.value,norm2$p.value),ncol=2)
          colnames(tab) = c("W statistic","p-value")
          rownames(tab) = c("Data 1","Data 2")
          tab
        } else
        {
          dat1$y=as.numeric(as.character(dat1$y))

          norm1 = shapiro.test(dat1$y[which(dat1$x==unique(dat1$x)[1])])
          norm2 = shapiro.test(dat1$y[which(dat1$x==unique(dat1$x)[2])])

          tab = matrix(c(norm1$statistic,norm2$statistic,norm1$p.value,norm2$p.value),ncol=2)
          colnames(tab) = c("W statistic","p-value")
          rownames(tab) = c("Data 1","Data 2")
          tab
        }
      } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()

        norm1 = shapiro.test(as.numeric(as.character(dat[[1]])))
        norm2 = shapiro.test(as.numeric(as.character(dat[[2]])))

        tab = matrix(c(norm1$statistic,norm2$statistic,norm1$p.value,norm2$p.value),ncol=2)
        colnames(tab) = c("W statistic","p-value")
        rownames(tab) = c("Data 1","Data 2")
        tab
      }
  })

})


# matrice

elementi <- c(2,4,3,1,5,7)
prva <- matrix( elementi,
                nrow = 2,
                ncol =3,
                byrow = TRUE)
prva

druga <- matrix( elementi,
                nrow = 2,
                ncol =3,
                byrow = FALSE)
druga

treca <- matrix( elementi,
                 nrow = 2,
                 ncol =3)
treca

# indeksiranje
na.poziciji.2.2 <- druga[2,2]
na.poziciji.2.2

prva
prva.vrsta.od.prva <- prva[1,]
prva.vrsta.od.prva
druga.kolona.od.prva <- prva[,2]
druga.kolona.od.prva

matrica.A <- matrix(
  c(1,2,3,4,5),
  nrow = 4,
  ncol = 3)
matrica.A

podmatrica.A <- matrica.A[c(2,4), c(1,3)]
podmatrica.A

zamenili.prvu.i.trecu.kolonu <- matrica.A[,c(3,2,1)]
zamenili.prvu.i.trecu.kolonu

matrica.A[2,2] <- 22
matrica.A

matrica.A[2,] <- c(7,8,9)
matrica.A

matrica.A[,2] <- c(0.5,1.5)
matrica.A

matrica.A <- matrix(
  c(1,2,3,4,5,6),
  nrow = 4,
  ncol = 3)
matrica.A
dimnames(matrica.A) <- list(
  c("najvisa","skoro najvisa", "skoro najniza", "najniza"),
  c("prva", "druga", "treca")
  )
matrica.A

treca.vrsta.matrice.A <- matrica.A["skoro najniza",]
treca.vrsta.matrice.A

# operacije nad matricama
elementi <- c(2,4,3,1,5,7)
prva <- matrix( elementi,
                nrow = 2,
                ncol =3,
                byrow = TRUE)
prva
druga <- matrix( elementi,
                 nrow = 2,
                 ncol =3,
                 byrow = FALSE)
druga
zbir <- prva + druga

prva
transponovana.prva <- t(prva)
transponovana.prva

prva
druga
spojene.po.koloni <- cbind (prva, druga)
spojene.po.koloni

prva
druga
spojene.po.vrsti <- rbind (prva, druga)
spojene.po.vrsti


#' Scaling data
#'
#' @description Rescale data
#'
#' @param x numeric vector
#' @param lim_inf numeric value of the inferior limit (0 by default)
#' @param lim_sup numeric value of the superior limit (1 by default)
#'
#' @return numeric vector
#'
#' @export
#'
#' @examples
#'
#' x <- seq(-3,3,l = 100)
#'
#' range(x)
#'
#' y <- scale01(x)
#'
#' range(y)
#'
#' plot(x,y)
#'

scale01 <- function(x, lim_inf = 0, lim_sup = 1){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(length(x) == 1){
    stop("length of x must be > 1")
  }

  if(is.numeric(lim_sup) == F){
    stop("lim_sup must be numeric")
  }

  if(is.numeric(lim_inf) == F){
    stop("lim_inf must be numeric")
  }

  if(length(lim_sup) != 1){
    stop("lim_sup must be just one numeric value")
  }

  if(length(lim_inf) != 1){
    stop("lim_inf must be just one numeric value")
  }

  if(lim_sup <= lim_inf){
    stop("lim_sup must be > lim_inf")
  }

  max_x <- max(x, na.rm = T)

  min_x <- min(x, na.rm = T)

  out <- (lim_sup-lim_inf) * ((x - min_x)/(max_x - min_x)) + lim_inf

  return(out)
}


#  the rank sum test
Methodist=c(62,60,60,25,24,23,20,13,12,6)
Catholic=c( 62,62,24,24,22,20,19,10,8,8)
Pentecostal=c(37,31,15,15,14,14,14,5,3,2 )
n=30
data.value <- c( Methodist,Catholic,Pentecostal)

data.rank <- rank(data.value)
data <- data.frame(data.value, data.rank)
print(data)
 Sumofranks=c(182.5,167.5,115)
 #test statistic
 H=(12/(n*(n+1)))*((Sumofranks[1]^2+Sumofranks[2]^2+Sumofranks[3]^2)/10)-3*(n+1)
 print(H)


# P-valueBasics.r
#
# Using R to create a null distribution for a fair coin
# and calculate a p value for an event
#

# Use a function to generate the coin flips

# 0 = Tails and 1 = Heads

FlipCoin <- function(n) sample(0:1,n,rep=T)

heads <- FlipCoin(20) # to start calculation

# Flip the 20 coins 10000 times

for(i in 1:10000) heads[i] <- sum(FlipCoin(20)==1)

hist(heads, main="Number of heads out of 20 tosses")

histinfo <- hist(heads)

print(histinfo)

# Use the Binomial Distribution to work out the probability of
# getting 16 heads out of 20 flips of a fair coin

binomial <- dbinom(16, size=20, prob=0.5) + dbinom(17, size=20, prob=0.5) + dbinom(18, size=20, prob=0.5) + dbinom(19, size=20, prob=0.5) + dbinom(20, size=20, prob=0.5)

print(binomial)


## 1. Condition vs Intersection ##

p_m <- 515/2000
p_m_given_l <- 32/90
p_m_and_l <- 32/2000

p_l <- 90/2000
p_m_or_l <- p_m + p_l - p_m_and_l

## 2. Conditional Probability & Complements ##

p_b_given_m <- 0.1486
p_c_given_l <- 0.0928
p_non_b_given_c <- 0.7622
p_non_b_given_m <- 1 - p_b_given_m
p_non_c_given_l <- 1 - p_c_given_l
p_b_given_c <- 1 - p_non_b_given_c

## 3. Distinguishing Between Event and Condition ##

p_m_given_non_l <- 483/1910
p_non_l_given_m <- 483/515
p_m_and_non_l <- 483/2000
p_non_l_and_m <- 483/2000

## 4. More On Intersection Probabilities ##

p_ram <- 0.0822
p_gl <- 0.0184
p_ram_given_gl <- 0.0022
p_gl_and_ram <- p_gl * p_ram_given_gl
p_non_ram_given_gl <- 1 - p_ram_given_gl
p_gl_and_non_ram <- p_gl * p_non_ram_given_gl
p_gl_or_ram <- p_gl + p_ram - p_gl_and_ram

## 5. Conditional Probability and Independence ##

k_and_l <- 'independent'
l_and_m <- 'independent'
k_and_m <- 'dependent'

## 6. Dependent Events ##

# Exercise 1 & 2
l_and_m <- 'dependent'
l_and_non_m <- 'dependent'

# Exercise 3
p_l <- 90/2000
p_m_given_l <- 32/90
p_l_and_m <- p_l * p_m_given_l

# Exercise 4
p_not_m_given_l <- 58/90
p_l_and_non_m <- p_l * p_not_m_given_l

## 7. Independence for Three Events ##

p_et <- 0.0432
p_ac <- 0.0172
p_ps <- 0.0236
p_et_and_ps <- p_et * p_ps
p_et_and_ac <- p_et * p_ac
p_ac_and_ps <- p_ac * p_ps
p_et_and_ac_and_ps <- p_et * p_ac * p_ps

Data Analyst in R/Step 5 - Probability and Statistics/4. Conditional Probability in R/2. Conditional Probability Intermediate.r


ex1 = function(a, b)
{
	plot(log2, a, b, col="red", lwd=2, main = "f(x)= log2 x, x in [a,b]")
}

ex2 = function()
{
	for(pr in c(0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9))
	{
		pdf(file=
			paste("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework2\\plots\\binom_", pr, ".pdf", sep=""),
			width=4, height=4
		   )

		x = 0:20
		plot(x, dbinom(x, size=20, prob=pr),
     		     	type="h",
     			main=paste("Binomial Distribution (n=20, p=", pr, ")", sep=""),
     			ylab="Probability",
     			xlab ="# Successes",
     			lwd=3)
		dev.off()
	}
}

ex3 = function()
{
	x = seq(-7, 7, .1)
	y = dnorm(x, mean=0, sd=.5)
	plot(x, y, type="l", col="red", lwd=2)
	par(new=T)
	y = dnorm(x, mean=0, sd=1)
	plot(x, y, type="l", col="green", lwd=2, yaxt='n', xaxt='n')
	par(new=T)
	y = dnorm(x, mean=0, sd=2)
	plot(x, y, type="l", col="blue", lwd=2, yaxt='n', xaxt='n')
}

CLT = function(n)
{
	vret = vector("double", 1000)
	for(i in 1:1000)
	{
		v = runif(n, 0, 20)
		vret[i] = mean(v)
	}
	vret
}

ex3b = function()
{
	par(mfrow=c(2,2))

	for(n in c(1, 5, 10, 100))
	{
		y = CLT(n)
		hist(y, nclass=50, col="red", main=paste("Histogram uniform of", n))
	}

}

CLT2 = function(n)
{
	vret = vector("double", 1000)
	for(i in 1:1000)
	{
		v = rbinom(n, 20, 0.1)
		vret[i] = mean(v)
	}
	vret
}

ex3c = function()
{
	par(mfrow=c(2,2))

	for(n in c(1, 5, 10, 100))
	{
		y = CLT2(n)
		hist(y, nclass=50, col="blue", main=paste("Histogram binomial of", n))
	}
}


# -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
# Compuationally verifying that the t distribution with n df is generated from
# the sampling distribution of the mean of (n+1) samples from a normal distribution.
# (specifically, it is the distribution of sqrt(n+1)*(xbar - mu)/S)
# -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

# To derive the t distribution from here, we need to multiply numerator and denominator
# by sigma and rearrange to get ((xbar - mu)/((sigma^2)/sqrt(n))) / sqrt((S^2)/(sigma^2))
# Then for this fraction, the top is ~ Z, the bottom is ~ sqrt(chisq(n-1)/n-1).

# Please be aware that due to some quirk in the calculation of the kernel density, one finds
# that the area under the curve can increase as the number of points -> Inf. Clearly this
# contravenes the laws of probability. It can be largely rectified by specifying the number of
# points to estimate at (argument n). HOWEVER, I'm finding an intermittent bug whereby the
# density function is still plotting too large an area under the curve / not accepting the
# n argument. The code is as-is, and if it happens, I suggest simply re-plotting.

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Function definitions

# Function to plot the theoretical distribution - to compare against
plot.analytic <- function(pdf, xlim = c(-3,3), ylim = c(0,0.5), res = 100, line.only = F, ...) {
    if(!is.vector(xlim) | !is.numeric(xlim) | !(length(xlim)==2)) stop("xlim must be limits of x axis")
    if(!is.vector(ylim) | !is.numeric(ylim) | !(length(ylim)==2)) stop("ylim must be limits of y axis")
    if(!is.function(pdf)) stop("pdf must be given as the density function of the distribution")
    sx <- seq(xlim[1], xlim[2], length.out = res)
    px <- pdf(sx, ...)
    if(!line.only) plot(sx, px, type="l", ylim=ylim, xlab = "X", ylab = "Density") else {
        lines(sx, px)
    }
}

# Function that simulates the sampling distribution for x_bar.
xbar_smp <- function(rng=rnorm, n = 1000, size = 10, xlim = NULL, ylim = c(0,0.5), line.only = T, ...) {

    #Generate n samples of size 'size' (rng = random number generator specified)
    smp <- matrix(rng(n*size, ...), n, size)
    #Sample mean
    xbar <- rowSums(smp)/size
    #Sample sd (avoiding apply for efficiency reasons)
    S <- sqrt(rowSums(smp^2)/(size-1) - (xbar^2)*(size/(size-1)))

    #Standardise
    xbar <- (xbar - mean(xbar))/(S/sqrt(size))

    #Plot
    if(!line.only & is.null(xlim)) {
        plot(density(xbar, n=n), ylim=ylim, col = 2, xlab = "X", ylab = "Density")
    } else if(!line.only & !is.null(xlim)) {
        plot(density(xbar, n=n), xlim = xlim, ylim=ylim, col = 2, xlab = "X", ylab = "Density")
    } else {
        lines(density(xbar, n=n), col = 2)
    }
    invisible(xbar)
}

# Function that simulates the distribution of (S2.x/var.x)/(S2.y/var.y)
# Note that (n-1)S2x/varx ~ Chisq(n-1), so the above is the ratio of two
# Chisq distributions with (possibly) different dfs.

S2_ratio_smp <- function(n = 1000, size = 10, var.x = 1, var.y = 1, mean.x = 0, mean.y = 0,
                         rng=rnorm, xlim = NULL, ylim = c(0,0.8), line.only = T) {

    #Generate n samples of size 'size' (rng = random number generator specified)
    smp.x <- matrix(rng(n*size, mean.x, sqrt(var.x)), n, size)
    smp.y <- matrix(rng(n*size, mean.y, sqrt(var.y)), n, size)

    #Sample mean
    x.bar <- rowSums(smp.x)/size
    y.bar <- rowSums(smp.y)/size
    #Sample sd (avoiding apply for efficiency reasons)
    S2.x <- rowSums(smp.x^2)/(size-1) - (x.bar^2)*(size/(size-1))
    S2.y <- rowSums(smp.y^2)/(size-1) - (y.bar^2)*(size/(size-1))

    #Test statistic
    results <- (S2.x/S2.y)/(var.x/var.y)

    #Plot
    if(!line.only & is.null(xlim)) {
        plot(density(results, n=n), ylim=ylim, col = 3, xlab = "X", ylab = "Density")
    } else if(!line.only & !is.null(xlim)) {
        plot(density(results, n=n), xlim = xlim, ylim=ylim, col = 3, xlab = "X", ylab = "Density")
    } else {
        lines(density(results, n=n), col = 3)
    }
    invisible(results)
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# t - distribution:
# -----------------
# Plot theoretical cauchy distribution / t distribution with 1 df.
# It is immediate from the definition that the two distributions are the same.
plot.analytic(dt, df = 1, xlim = c(-10,10))

# Plot density generated from 5,000 samples of size 2 from a standard normal dist.
# Should be distributed close to the theoretical distn plotted in black
xbar_smp(size = 2, n = 10000)
# Increase sample sizes (df) for the sampling distn of xbar
xbar_smp(size = 10, n = 10000)
xbar_smp(size = 20, n = 10000)

# Plot theoretical standard normal distribution
plot.analytic(dnorm, line.only = T)

# F - distribution:
# -----------------

# Simulate F distribution with sample size of 10
smp_size <- 10
S2_ratio_smp(n = 100000, size = smp_size, xlim = c(0,10), line.only = F)
# Verifying that changing the mean/variance makes 0 difference
S2_ratio_smp(n = 100000, size = smp_size, mean.x = 1000, xlim = c(0,10), line.only = F)
S2_ratio_smp(n = 100000, size = smp_size, mean.x = 1000, var.x = 10, xlim = c(0,10), line.only = F)

# Compare to theoretical (black line)
plot.analytic(df, df1 = smp_size-1, df2 = smp_size-1, line.only = T)

# Compare distribution of different sample sizes
S2_ratio_smp(n = 100000, size = 4, xlim = c(0,10), ylim = c(0,1), line.only = F)
S2_ratio_smp(n = 100000, size = 7, xlim = c(0,10), line.only = T)
S2_ratio_smp(n = 100000, size = 10, xlim = c(0,10), line.only = T)
S2_ratio_smp(n = 100000, size = 20, xlim = c(0,10), line.only = T)
S2_ratio_smp(n = 100000, size = 40, xlim = c(0,10), line.only = T)
plot.analytic(df, df1 = 39, df2 = 39, line.only = T)

# Compare summary of different distributions
smp_size <- c(4,7,10,20,40)
results <- sapply(1:length(smp_size), function(x) S2_ratio_smp(n = 100000, size = smp_size[x], line.only = T))
results <- noquote(format(apply(results, 2, function(x) {op <- c(mean(x), var(x))
                        names(op) = c("Mean","Var"); op}), digits = 2))
colnames(results) <- paste("|smp|", smp_size, sep = " = ")
print(results)

# As expected, mean -> 1. Variance of distribution looks to be -> 0 as n -> +Inf

S2_ratio_smp(n = 100000, size = smp_size, var.x = 10, xlim = c(0,10), line.only = F)
debugonce(S2_ratio_smp)
S2_ratio_smp(n = 100000, size = smp_size, var.x = 10, xlim = c(0,10), line.only = F)


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

#gerando serie random walk
#tornar reprodutivel
set.seed(4312)
x = cumsum(sample(c(-1,1),100,T))
print(x)
serie = ts(x,start = c(1900),end = c(2000), frequency = 1)
print(serie)
autoplot(serie)

#faz a previsao
prev = naive(serie, h=5)
class(prev)
print(prev)
print(prev$fitted)
print(prev$residuals)
autoplot(prev)
print(prev)

prev2 = naive(serie, h=5, level = c(95, 99))
print(prev2)
autoplot(prev2)

split.screen( figs = c( 2, 1 ) )
screen(1)
plot(prev)
screen(2)
plot(prev2)
close.screen( all = TRUE )

#naive sazonal
autoplot(AirPassengers)
prev3 = snaive(AirPassengers, h=12)
print(prev3)
autoplot(prev3)

#comparando a previsao com o ultimo ano
prev3$mean
window(AirPassengers,start=c(1960))

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/6.3.R Naive.r


# Chapter 7 Lab: Non-linear Modeling

library(ISLR)
attach(Wage)

# Polynomial Regression and Step Functions

fit=lm(wage~poly(age,4),data=Wage)
coef(summary(fit))
fit2=lm(wage~poly(age,4,raw=T),data=Wage)
coef(summary(fit2))
fit2a=lm(wage~age+I(age^2)+I(age^3)+I(age^4),data=Wage)
coef(fit2a)
fit2b=lm(wage~cbind(age,age^2,age^3,age^4),data=Wage)
agelims=range(age)
age.grid=seq(from=agelims[1],to=agelims[2])
preds=predict(fit,newdata=list(age=age.grid),se=TRUE)
se.bands=cbind(preds$fit+2*preds$se.fit,preds$fit-2*preds$se.fit)
par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0))
plot(age,wage,xlim=agelims,cex=.5,col="darkgrey")
title("Degree-4 Polynomial",outer=T)
lines(age.grid,preds$fit,lwd=2,col="blue")
matlines(age.grid,se.bands,lwd=1,col="blue",lty=3)
preds2=predict(fit2,newdata=list(age=age.grid),se=TRUE)
max(abs(preds$fit-preds2$fit))
fit.1=lm(wage~age,data=Wage)
fit.2=lm(wage~poly(age,2),data=Wage)
fit.3=lm(wage~poly(age,3),data=Wage)
fit.4=lm(wage~poly(age,4),data=Wage)
fit.5=lm(wage~poly(age,5),data=Wage)
anova(fit.1,fit.2,fit.3,fit.4,fit.5)
coef(summary(fit.5))
(-11.983)^2
fit.1=lm(wage~education+age,data=Wage)
fit.2=lm(wage~education+poly(age,2),data=Wage)
fit.3=lm(wage~education+poly(age,3),data=Wage)
anova(fit.1,fit.2,fit.3)
fit=glm(I(wage>250)~poly(age,4),data=Wage,family=binomial)
preds=predict(fit,newdata=list(age=age.grid),se=T)
pfit=exp(preds$fit)/(1+exp(preds$fit))
se.bands.logit = cbind(preds$fit+2*preds$se.fit, preds$fit-2*preds$se.fit)
se.bands = exp(se.bands.logit)/(1+exp(se.bands.logit))
preds=predict(fit,newdata=list(age=age.grid),type="response",se=T)
plot(age,I(wage>250),xlim=agelims,type="n",ylim=c(0,.2))
points(jitter(age), I((wage>250)/5),cex=.5,pch="|",col="darkgrey")
lines(age.grid,pfit,lwd=2, col="blue")
matlines(age.grid,se.bands,lwd=1,col="blue",lty=3)
table(cut(age,4))
fit=lm(wage~cut(age,4),data=Wage)
coef(summary(fit))

# Splines

library(splines)
fit=lm(wage~bs(age,knots=c(25,40,60)),data=Wage)
pred=predict(fit,newdata=list(age=age.grid),se=T)
plot(age,wage,col="gray")
lines(age.grid,pred$fit,lwd=2)
lines(age.grid,pred$fit+2*pred$se,lty="dashed")
lines(age.grid,pred$fit-2*pred$se,lty="dashed")
dim(bs(age,knots=c(25,40,60)))
dim(bs(age,df=6))
attr(bs(age,df=6),"knots")
fit2=lm(wage~ns(age,df=4),data=Wage)
pred2=predict(fit2,newdata=list(age=age.grid),se=T)
lines(age.grid, pred2$fit,col="red",lwd=2)
plot(age,wage,xlim=agelims,cex=.5,col="darkgrey")
title("Smoothing Spline")
fit=smooth.spline(age,wage,df=16)
fit2=smooth.spline(age,wage,cv=TRUE)
fit2$df
lines(fit,col="red",lwd=2)
lines(fit2,col="blue",lwd=2)
legend("topright",legend=c("16 DF","6.8 DF"),col=c("red","blue"),lty=1,lwd=2,cex=.8)
plot(age,wage,xlim=agelims,cex=.5,col="darkgrey")
title("Local Regression")
fit=loess(wage~age,span=.2,data=Wage)
fit2=loess(wage~age,span=.5,data=Wage)
lines(age.grid,predict(fit,data.frame(age=age.grid)),col="red",lwd=2)
lines(age.grid,predict(fit2,data.frame(age=age.grid)),col="blue",lwd=2)
legend("topright",legend=c("Span=0.2","Span=0.5"),col=c("red","blue"),lty=1,lwd=2,cex=.8)

# GAMs

gam1=lm(wage~ns(year,4)+ns(age,5)+education,data=Wage)
library(gam)
gam.m3=gam(wage~s(year,4)+s(age,5)+education,data=Wage)
par(mfrow=c(1,3))
plot(gam.m3, se=TRUE,col="blue")
plot.gam(gam1, se=TRUE, col="red")
gam.m1=gam(wage~s(age,5)+education,data=Wage)
gam.m2=gam(wage~year+s(age,5)+education,data=Wage)
anova(gam.m1,gam.m2,gam.m3,test="F")
summary(gam.m3)
preds=predict(gam.m2,newdata=Wage)
gam.lo=gam(wage~s(year,df=4)+lo(age,span=0.7)+education,data=Wage)
plot.gam(gam.lo, se=TRUE, col="green")
gam.lo.i=gam(wage~lo(year,age,span=0.5)+education,data=Wage)
library(akima)
plot(gam.lo.i)
gam.lr=gam(I(wage>250)~year+s(age,df=5)+education,family=binomial,data=Wage)
par(mfrow=c(1,3))
plot(gam.lr,se=T,col="green")
table(education,I(wage>250))
gam.lr.s=gam(I(wage>250)~year+s(age,df=5)+education,family=binomial,data=Wage,subset=(education!="1. < HS Grad"))
plot(gam.lr.s,se=T,col="green")


#!/usr/bin/env Rscript

# R - https://www.r-project.org/
#
# Usage:
# ./gcd.r 11 22 33 121
# [1] 11
#
# Or:
# Rscript ./gcd.r 11 22 33 121
# [1] 11
#

gcd <- function (a, b) {
  if (b == 0) {
    a
  } else {
    gcd(b, a %% b)
  }
}

gcdn <- function(ns) {
  Reduce(gcd, ns)
}

args <- commandArgs(trailingOnly=TRUE)
ns <- mapply(as.integer, args)
gcdn(ns)


library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(readr)
library(ggthemes)

### Functions that evaluate theoretical fitness according to Sella and Hirsh
predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

w_vs_eps <- function(Ne, L, s, epsstart, epsstop, epssteps = 0.01)
{
  eps <- seq(epsstart, epsstop, epssteps)
  w_ave <- vapply(eps, function(eps){predict_mean_fitness(Ne, L, s, eps)}, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

#########################################################################
### Epistasis vs Fitness: theoretically derived and simulated fitness ###
#########################################################################
# import simulation results
t_N100 <- read_csv("../processed_results/varying_eps_N100_max3.csv")
t_N10 <- read_csv("../processed_results/varying_eps_N10_max3.csv")

t <- rbind(t_N100, t_N10)

# calculate a mean fitness across time when the population reached epistasis
t %>% mutate(q = 1-epistasis_coef) %>%
  group_by(q, sel_coef, mu_prob, Ne, k_start, rep) %>% #one mean per simulation
  summarise(mean_f_over_time = mean(mean_fitness)) -> t_sum

L = 100 #Number of maximum mutations

### Sub-figure N=10, s=0.01
pop_size = 10
s = 0.01

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N10_s0.01 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time, color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size = 0.4) +
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 10, s = 0.01", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

### Sub-figure N=10, s=0.001
pop_size = 10
s = 0.001

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N10_s0.001 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time,color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4)+
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 10, s = 0.001", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

### Sub-figure N=100, s=0.01
pop_size = 100
s = 0.01

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N100_s0.01 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time,color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4)+
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 100, s = 0.01", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

### Sub-figure N=100, s=0.001
pop_size = 100
s = 0.001

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N100_s0.001 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time,color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4)+
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 100, s = 0.001", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

# extract the legend form the first sub-figure
grobs <- ggplotGrob(p_N100_s0.001)$grobs
legend <- grobs[[which(sapply(grobs, function(x) x$name) == "guide-box")]]

# arrange subfigures
prow <- plot_grid(p_N10_s0.001 + theme(legend.position="none"),
                  p_N10_s0.01 + theme(legend.position="none", axis.title.y = element_blank()),
                  p_N100_s0.001 + theme(legend.position="none"),
                  p_N100_s0.01 + theme(legend.position="none", axis.title.y = element_blank()),
                  labels=c("A","B","C","D"),
                  align = 'vh',
                  hjust = -1,
                  ncol=2,
                  nrow=2)

p <- plot_grid(prow, legend, rel_widths = c(2, .3))

save_plot("../plots/fitness_vs_epistasis.png", p,
          ncol = 2, # we're saving a grid plot of 2 columns
          nrow = 2, # and 2 rows
          # each individual subplot should have an aspect ratio of 1.3
          base_height=4,
          base_width=4)

#########################################################################
### Two regimes: selection driven and drift driven                    ###
#########################################################################
# a function that calculates Q* (min of Q)
f <- function(L, s, q, k){exp(-s*k**q)}
p_num <- function(L, s, N, q, k){choose(L, k)*f(L, s, q, k)**(2*N-2)}
Z <- function(L, s, N, q){sum(p_num(L, s, N, q, 0:L))}
fave <- function(L, s, N, q){sum(f(L, s, q, 0:L)*p_num(L, s, N, q, 0:L))/Z(L, s, N, q)}

# assume p(k) independent of f(k) (i.e., no selection)
p_num2 <- function(L, s, N, q, k){choose(L, k)}
Z2 <- function(L, s, N, q){sum(p_num2(L, s, N, q, 0:L))}
fave2 <- function(L, s, N, q){sum(f(L, s, q, 0:L)*p_num2(L, s, N, q, 0:L))/Z2(L, s, N, q)}

# assume k <= kmax only (limited drift)
Z3 <- function(L, s, N, q, kmax){sum(p_num(L, s, N, q, 0:kmax))}
fave3 <- function(L, s, N, q, kmax){sum(f(L, s, q, 0:kmax)*p_num(L, s, N, q, 0:kmax))/Z3(L, s, N, q, kmax)}

eval_model <- function(L, s, N) {
  q <- seq(0, 2, .01)
  df <- data.frame(
    q = q,
    full_model = vapply(q, function(x) fave(L, s, N, x), numeric(1)),
    no_selection = vapply(q, function(x) fave2(L, s, N, x), numeric(1)),
    limited_drift = vapply(q, function(x) fave3(L, s, N, x, 20), numeric(1))
  ) %>% gather(formula, f_ave, -q)
}

# get a data frame of 3 models evaluated for different Q values
df <- eval_model(L = 100, s = 0.01, N = 10)

df %>% filter(formula == "full_model") -> df1
df %>% filter(formula == "no_selection") -> df2
df %>% filter(formula == "limited_drift") -> df3

name <- data.frame(x = c(1.76, 1.45, 1), y = c(0.34, 0.8, 0.25) , model = c("Full model", "Selection driven", "Drift driven"))

# Make a plot of the 3 models
p_models <- ggplot() +
  geom_line(
    data = df3,
    aes(q, f_ave, color = formula),
    size = 1,
    linetype = "dotted",
    color = "#955804",
    lineend = "butt") +
  geom_line(
    data = df2,
    aes(q, f_ave, color = formula),
    size = 1,
    linetype = "dashed",
    color = "#3f72af",
    lineend = "round") +
  geom_line(
    data = df1,
    aes(q, f_ave, color = formula),
    size = 1.1,
    lineend = "round") +
  geom_text(data = name, aes(x, y, label = model)) +
  xlab('q') +
  ylab('Mean fitness') +
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 10, s = 0.01", size = 12, fontface = 'bold') +
  theme(plot.title = element_text(hjust = 0), legend.position="none") +
  scale_color_manual(values = c("#000000", "#979797", "#979797"))

save_plot("../plots/two_regimes.png",
          p_models,
          # each individual subplot should have an aspect ratio of 1.3
          base_aspect_ratio = 1.2)

#########################################################################
### Theoretical calculations of Q*                                    ###
#########################################################################

# predicted Q minimum (Q*)
qmin <- function(N, L, s){log(L*log(2)/(2*s*N))/log(L/2)}

# function that evalutes min Q (Q*) vs selection coefficient
qmin_vs_s <- function(Ne, L, s_start, s_stop, s_steps = 0.001)
{
  s <- seq(s_start, s_stop, s_steps)
  qmin <- vapply(s, function(s){qmin(Ne, L, s)}, 1)
  data.frame(s, qmin, Ne, L)
}

# make a data frame of Q* vs selection coefficient for N=10
df1 <- qmin_vs_s(10, 100, 0.0001, 0.1)

# make a data frame of Q* vs selection coefficient for N=100
df2 <- qmin_vs_s(100, 100, 0.0001, 0.1)

# make a data frame of Q* vs selection coefficient for N=1000
df3 <- qmin_vs_s(1000, 100, 0.0001, 0.1)

df <- rbind(df1, df2, df3)

# a function that calculates Q* (min of Q)
f <- function(L, s, q, k){exp(-s*k**q)}
p_num <- function(L, s, N, q, k){choose(L, k)*f(L, s, q, k)**(2*N-2)}
Z <- function(L, s, N, q){sum(p_num(L, s, N, q, 0:L))}
fave <- function(L, s, N, q){sum(f(L, s, q, 0:L)*p_num(L, s, N, q, 0:L))/Z(L, s, N, q)}

# numerically find optimal q
fopt_gen <- function(L, s, N) {
  function(q) fave(L, s, N, q)
}

# make a data frame with numerically inferred q minimum
num_min_q <- data.frame()
for (i in 1:25) {
  for (n in c(10, 100, 1000)) {
    s <- 0.0001*1.2^i
    qmin <- optimize(fopt_gen(100, s, n), interval = c(0, 10))$minimum
    row <- data.frame(s, qmin, n)
    num_min_q <- rbind(num_min_q, row)
  }
}

p_qmin <- ggplot(df, aes(x = s, y = qmin, color = factor(Ne))) +
  geom_line(size = 1.1, lineend = "round") +
  geom_point(data = num_min_q, aes(x = s, y = qmin, color = factor(n))) +
  geom_hline(yintercept = 1) +
  scale_y_continuous(breaks=seq(0,2.5,0.5)) +
  scale_x_log10(breaks=c(0.0001, 0.001, 0.01, 0.1), labels = c("0.0001", "0.001", "0.01", "0.1")) +
  coord_cartesian(ylim=c(0,2.6),xlim=c(0.000099999,0.1)) +
  xlab('s') +
  ylab('q*') +
  scale_color_manual(values = c("#9AC9D6", "#6E7FB3", "#6D0079")) +
  guides(col = guide_legend(title="N"))

save_plot("../plots/minimum_q_vs_selection.png",
          p_qmin,
          # each individual subplot should have an aspect ratio of 1.3
          base_aspect_ratio = 1.3)

#########################################################################
### Simulations with high mutation rate and no selection model        ###
#########################################################################
# evaluate fitness vs Q for the formula that's doesn't consider selection.
df <- eval_model(L = 100, s = 0.01, N = 100) %>% filter(formula == "no_selection")
t_N100a <- read_csv("../processed_results/varying_eps_N100_max3.csv")
t_N100b <- read_csv("../processed_results/varying_eps_N100_max4.csv")

t <- rbind(t_N100a, t_N100b)

# calculate a mean fitness across time when the population reached epistasis
t %>% mutate(q = 1-epistasis_coef) %>%
  group_by(q, sel_coef, mu_prob, Ne, k_start, rep) %>% #one mean per simulation
  summarise(mean_f_over_time = mean(mean_fitness)) -> t_sum

t_sum %>% filter(sel_coef == 0.01) -> f

p_mu <- ggplot() +
  geom_line(data = df, aes(q, f_ave), size = 1.1) +
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 100, s = 0.01", size = 12, fontface = 'bold') +
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time, color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4) +
  xlab('q') +
  ylab('Mean fitness') +
  guides(col = guide_legend(title="Mutation\nrate")) +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1", "1"),
                     values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F", "#8E063B"))

save_plot("../plots/no_selection_model_vs_mu.png", p_mu,
          # each individual subplot should have an aspect ratio of 1.3
          base_height=5,
          base_width=6)


v <- c(18,9,12,25)
w <- c(5,2,4,6)
W <- 10

Tabweights<-c(0,w)
TabValues<-c(0,v)
n<-length(w)
TabMatrix<-matrix(NA,nrow =n+1,ncol = W+1)

TabMatrix[,]<-0

for (j in 2:W+1){
  for (i in 2:n+1){
      if (Tabweights[i] > j) {
        TabMatrix[i,j] = TabMatrix[i-1,j]
      }
      else
      {
        TabMatrix[i,j]<-max(TabMatrix[i-1,j], TabValues[i] + TabMatrix[i-1,j-Tabweights[i]])
      }
  }
}

cat("The best value is",TabMatrix[i,j])

i = n+1
w = W+1
ItemSelected = c()
while(i>1 & w>0)
  {
  if(TabMatrix[i,w]!=TabMatrix[i-1,w])
    {
    ItemSelected<-c(ItemSelected,(i)-1)
    w = w - Tabweights[i]
    i = i - 1
   }
  else
  {
    i = i - 1
  }
}

cat("The items selected are",ItemSelected)


#' BPR link cost function
#'
#' This function calculates the travel costs as a function of link flow using the classic separable BPR cost function. Specifically, c(x) = Alpha*(1+0.15 (x/Beta)^pow) for pow > 0; c(x) = Alpha for pow = 0.
#' @param x Traffic volume on link
#' @param Alpha Free flow travel time parameter
#' @param Beta Link capacity parameter
#' @param pow Polynomial order of cost function. Defaults to 4.
#' @return Vector of link costs
#' @keywords BPR link cost
#' @examples
#' x <- 1:25
#' costs <- LinkCost(x,Alpha=5,Beta=20)
#' plot(x,costs)
#' @export

LinkCost <- function(x,Alpha,Beta,pow=4){
	Beta[pow==0] <- 1
	Alpha*(1+(pow>0)*0.15*(x/Beta)^pow)
}


require(MASS)

# Standard error for means
stderr = function(x){ sqrt(var(x,na.rm=TRUE)/length(na.omit(x))) }

# Geometric mean
gmean=function(x) { exp(mean(log(x))) }

# Power-law distribution functions
dpareto=function(x, s=1, l=1) s * l^s / x^(s + 1);
ppareto=function(x, s=1, l=1) (x >= l) * (1 - (l / x)^s);
qpareto=function(u, s=1, l=1) l/(1 - u)^(1 / s);
rpareto=function(n, s=1, l=1) qpareto(runif(n), s, l);

# Chi-square goodness of fit, d.f.=(discrete bins) - ((num parameters used in fit)+1)
goodfit.chisq.test=function(x,dfunc,params) {
    n=length(x)
    p=length(params)+1
    xvals=floor(min(x)):(max(x))
    ofset=min(x)-1
    counts=rep(0,length(xvals))
    for(i in 1:n) { counts[x[i]-ofset]=counts[x[i]-ofset]+1 }
    ob=counts[counts>5]
    df=length(ob)-p
    cl=call(dfunc, xvals[counts>5], params)
    if(is.call(cl)) {
        ex=eval(cl)
        ex=round(ex*sum(ob),0)
        ctmat=as.matrix(cbind(ob,ex))
        statistic=chisq.test(ctmat, correct=F)$statistic
        p.value=1-pchisq(statistic,df)
        list(statistic=statistic, df=df, p.value=p.value)
    } else {
        warning("unrecognized function")
    }
}

# List of distributions fit to empirical data x, overlaid on plot
normhist=function(x,col=8,normcol=4,meancol=4,sdcol=5,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=par("usr")[1]
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    nx=seq(lim1,lim2,length=1000)
    ny=dnorm(nx,mean=nm,sd=nsd)
    if(!is.na(normcol)){ lines(nx,ny,col=normcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dnorm(nm,mean=nm,sd=nsd)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dnorm(nm+nsd,mean=nm,sd=nsd)),col=sdcol) }
    if(!is.na(sdcol)){ lines(c(nm-nsd,nm-nsd),c(0,dnorm(nm-nsd,mean=nm,sd=nsd)),col=sdcol) }
    p=ks.test(x,"pnorm",nm,nsd)$p
    legend("topright",inset=0.05,legend=c(paste("Normal( ",round(nm,5),", ",round(nsd,5)," )"), "KS-test", paste("p =",signif(p,5))),bty="n")
}

lognormhist=function(x,col=8,lnormcol=4,meancol=4,sdcol=5,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=par("usr")[1]
    lim2=par("usr")[2]
    nm=gmean(x)
    nsd=sd(x)
    lnm=mean(log(x))
    lnsd=sd(log(x))
    nx=seq(lim1,lim2,length=1000)
    ny=dlnorm(nx,meanlog=lnm,sdlog=lnsd)
    if(!is.na(lnormcol)){ lines(nx,ny,col=lnormcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dlnorm(nm,meanlog=lnm,sdlog=lnsd)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dlnorm(nm+nsd,meanlog=lnm,sdlog=lnsd)),col=sdcol) }
    p=ks.test(x,"plnorm",lnm,lnsd)$p
    legend("topright",inset=0.05,legend=c(paste("Lognormal( ",round(lnm,5),", ",round(lnsd,5)," )"), "KS-test", paste("p =",signif(p,5))),bty="n")
}

gammahist=function(x,shape,legtxt="",col=8,gamcol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=0
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    nx=seq(lim1,lim2,length=1000)
    ny=dgamma(nx,shape=shape,rate=1/nm)
    if(!is.na(gamcol)){ lines(nx,ny,col=gamcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dgamma(nm,shape=shape,rate=1/nm)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dgamma(nm+nsd,shape=shape,rate=1/nm)),col=sdcol) }
    p=ks.test(x,"pgamma",shape,1/nm)$p
    leg=c("KS-test",paste("p =",signif(p,5)))
    if(nchar(legtxt)>0) {
        leg=c(legtxt, leg)
    } else {
        leg=c(paste("Gamma( ",round(shape,5),", 1/",round(nm,5)," )",sep=""), leg)
    }
    legend("topright",inset=0.05,legend=leg,bty="n")
}

exphist=function(x,col=8,expcol=4,meancol=4,sdcol=NA,border=F,xlab="",...) {
    gammahist(x,shape=1,paste("Exponential( 1, 1/",round(mean(x),5)," )",sep=""), col=col,gamcol=expcol,meancol=meancol,sdcol=sdcol,border=border,xlab=xlab,...)
}

discretehist=function(x,dfunc,param,legtxt="",col=8,denscol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,h=1,col=col,border=border,xlab=xlab,...)
    lim1=0
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    nx=(lim1):(lim2)
    cl=call(dfunc, nx, param)
    cl2=call(dfunc, floor(nm), param)
    cl3=call(dfunc, floor(nm+nsd), param)
    if(is.call(cl)) {
        ny=eval(cl)
        if(!is.na(denscol)){ lines(nx,ny,col=denscol,type="s") }
        if(!is.na(meancol)){ lines(c(nm,nm),c(0,eval(cl2)),col=meancol) }
        if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,eval(cl3)),col=sdcol) }
        p=goodfit.chisq.test(x,dfunc,param)$p.value
        leg=c(expression(paste("Pearson ",chi^2,"-test")),paste("p =",signif(p,5)))
        if(nchar(legtxt)>0){ leg=c(legtxt,leg) }
        legend("topright",inset=0.05,legend=leg,bty="n")
    } else {
        warning("not a recognized function")
    }
}

geomhist=function(x,col=8,geomcol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    param=1/mean(x)
    discretehist(x,"dgeom",param,paste("Geometric( 1/",round(mean(x),5)," )",sep=""),col,geomcol,meancol,sdcol,border,xlab,...)
}

poishist=function(x,col=8,poiscol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    param=mean(x)
    discretehist(x,"dpois",param,paste("Poisson( ",round(param,5)," )",sep=""),col,poiscol,meancol,sdcol,border,xlab,...)
}

paretohist=function(x,col=8,pcol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=par("usr")[1]
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    location=min(x)
    nx=seq(lim1,lim2,length=1000)

    # estimate shape parameter, by linear regression of head of distribution on log-log
    logx=log(x)
    lxbins=seq(min(logx),max(logx),length=50)
    lxcounts=rep(0,10)
    for(i in 1:10) { lxcounts[i]=length(logx[logx>=lxbins[i] & logx<lxbins[i+1]])}
    lxmids=(lxbins[2:11]+lxbins[1:10])/2
    shape=-lm(log(lxcounts)~lxmids)$coefficients[2]

    ny=dpareto(nx,shape,location)
    if(!is.na(pcol)){ lines(nx,ny,col=pcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dpareto(nm,shape,location)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dpareto(nm+nsd,shape,location)),col=sdcol) }
    p=ks.test(x,"ppareto",shape,location)$p
    legend("topright",inset=0.05,legend=c(paste("Pareto( ",round(shape,5),", ",round(location,5)," )",sep=""),"KS-test",paste("p =",signif(p,5))),bty="n")
}

powerlawhist=paretohist

# Plot 6 distributions for comparison of fit
allhist=function(x,...) {
    par(mfrow=c(2,3))
    options(warn=-1)
    try(normhist(x,nbins=50,...),T)
    try(lognormhist(x,nbins=50,...),T)
    try(exphist(x,nbins=50,...),T)
    try(geomhist(x,nbins=50,...),T)
    try(poishist(x,nbins=50,...),T)
    try(paretohist(x,nbins=50,...),T)
    options(warn=1)
}


##########################################################################
#
# Author: Dariya K. Sydykova
##########################################################################

# load packages necessary to run the following script
library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(here)

# set up input file. Output plot files are generated automatically and are stored in /evolving_q_sim/test_plots
root_dir <- here() # get the directory of the root of the project

# this function calculates population fitness according to Sella and Hirsh's theory
# the function takes in as an argument size of the population (`Ne`), maximum number of mutations (`L`), selection coefficient (`s`), and epistasis coefficient (`eps`)
predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

# this function calculates population fitness for different values of epistasis coefficient.
w_vs_eps <- function(Ne, L, s, epsstart, epsstop, epssteps = 0.01)
{
  eps <- seq(epsstart, epsstop, epssteps)
  w_ave <- vapply(eps, function(eps){predict_mean_fitness(Ne, L, s, eps)}, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

# this function calculates population fitness for different sizes of population.
w_vs_Ne <- function(eps, L, s, Nestart, Nestop, Nesteps = 0.1) {
  Ne <- seq(Nestart, Nestop, Nesteps)
  w_ave <- vapply(Ne, function(Ne) {
    predict_mean_fitness(Ne, L, s, eps)
  }, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

# set parameters to be used in numerical derivations
q <- 1
eps <- 1 - q
s <- 0.01
an_f1 <- w_vs_Ne(eps, 100, s, 0, 1000) %>% mutate(q = q)

q <- 1.5
eps <- 1 - q
s <- 0.01
an_f2 <- w_vs_Ne(eps, 100, s, 0, 1000) %>% mutate(q = q)

q <- 0.5
eps <- 1 - q
s <- 0.01
an_f3 <- w_vs_Ne(eps, 100, s, 0, 1000) %>% mutate(q = q)

# combine all output
rbind(an_f1, an_f2, an_f3) -> an_f

# plot numerically calculated fitness for different N and q
p1 <- ggplot(an_f, aes(x = Ne, y = w_ave, color = factor(q))) +
  geom_line(size = 1, lineend = "round", linejoin = "round") +
  scale_color_manual(name = "q", values = c("#d3d4d8", "#3fbac2", "#4d606e")) +
  xlab("N") +
  ylab("Mean fitness") +
  scale_x_log10(limits = c(1, 1000), breaks = c(1, 10, 100, 1000), labels = c("1", "10", "100", "1000")) +
  coord_cartesian(ylim = c(0, 1)) +
  theme(
    axis.title = element_text(size = 14),
    axis.text = element_text(size = 12),
    legend.text = element_text(size = 11),
    legend.title = element_text(size = 12)
  )

# set parameters to be used in numerical derivations
N <- 10
s <- 0.01
an_f1 <- w_vs_eps(N, 100, s, -1, 1) %>% mutate(q = 1 - eps)

N <- 50
s <- 0.01
an_f2 <- w_vs_eps(N, 100, s, -1, 1) %>% mutate(q = 1 - eps)

N <- 100
s <- 0.01
an_f3 <- w_vs_eps(N, 100, s, -1, 1) %>% mutate(q = 1 - eps)

# combine all output
rbind(an_f1, an_f2, an_f3) -> an_f

# plot numerically calculated fitness for different N and q
p2 <- ggplot(an_f, aes(x = q,y = w_ave)) +
  geom_line(
    aes(color = factor(Ne)),
    size = 1.2,
    lineend = "round",
    linejoin = "round"
  ) +
  scale_color_manual(values = c("#f67280", "#c06c84", "#6c5b7c")) +
  scale_y_continuous(breaks = seq(0, 1, 0.2)) +
  coord_cartesian(ylim = c(0, 1)) +
  xlab('q') +
  ylab('Mean fitness') +
  guides(col = guide_legend(title = "N",reverse = TRUE))

p <- plot_grid(p1, p2, labels = c("A", "B"))

# save the plot
save_plot(
  paste0(root_dir, "/evolving_q_sim/plots/theoretical_fitness_s", s, ".png"),
  p,
  base_height = 4,
  base_width = 9
)


### Examen Parcial 2 - Inferencia Estadistica 2
### Sergio García Prado

rm(list = ls())

### Ejercicio 1
###############################################################################

### Ejercicio 1 - Apartado A

observed1 <- c(0.87, 0.20, 0.99, 0.40, 0.39, 0.72, 0.33, 0.88, 0.22, 0.45,
               0.01, 0.37, 0.59, 0.80, 0.93, 0.54, 0.66, 0.49, 0.73, 0.68)

(n1 <- length(observed1))
#20

## Función de distribución bajo hipótesis nula.
CummulativeH0 <- function(x) {
  ifelse(x < 0, 0,
  ifelse(1 < x, 1,
  (1 / 3) * x ^ 4 * (5 - 2 * x)))
}

## Por ser una hipótesis simple, podemos utilizar el test de kolgomorov-smirnov
test1 <- ks.test(observed1, CummulativeH0)

(D1 <- test1$statistic)
# 0.4149008

(pvalue1 <- test1$p.value)
# 0.001244618

## Nos vemos obligados a rechazar la hipótesis de que los datos observados
## pertenezcan a la distribución definida en la hipótesis nula.

### Ejercicio 1 - Apartado B

alpha <- 0.05

## Para simular la potencia calculamos el promedio sobre la variable indicador
## que toma el valor 1 cuando rechazamos la hipótesis nula, y 0 en cuando la
## aceptamos.

(power1 <- mean(replicate(1000, ks.test(runif(n1), CummulativeH0)$p.value < alpha)))
# 0.985

### Ejercicio 2
###############################################################################

# Fijamos el número de simulaciones bootstrap.
nsims2 <- 1000

observed2 <- c(2.27,2.28,0.05,0.56,0.59,1.21,0.46,1.74,1.66,0.66,1.94,0.33,
               0.33,0.22,2.16,1.69,0.45,1.13,1.00,1.85,1.28,7.61,0.03,0.86,
               0.66,3.84,1.42,0.80,0.25,5.03,2.23,0.83,4.33,1.35,0.91,0.87,
               0.06,6.80,1.62,0.02,0.05,3.40,0.72,1.58,0.53,0.90,0.35,0.95,
               0.95,0.46)

(n2 <- length(observed2))
# 50

(observed2.mean <- mean(observed2))
# 1.4654

(observed2.sd <- sd(observed2))
# 1.609788

## Generamos una muestra bootstrap paramétrica asumiendo una distribución
## normal en los datos.
bootstrap.sample <- matrix(rnorm(n = n2 * nsims2, mean = observed2.mean, sd = observed2.sd),
                           nsims2, n2)

bootstrap.mean <- rowMeans(bootstrap.sample)

## Utilizamos el mismo alpha que en el ejercicio anterior (alpha = 0.05)

quantile(bootstrap.mean, c(alpha / 2, 1 - alpha / 2))
# 2.5%     97.5%
# 1.054534 1.886941

### Ejercicio 3
###############################################################################

observed3 <- c(20, 18, 8, 14)

(k3 <- length(observed3))
# 4

(n3 <- sum(observed3))
# 60

### Ejercicio 3 - Apartado A

PoissonExpected <- function(n, k, lambda) {
  ## Método 1

  # n * c(dpois(0:(k - 2), lambda = lambda),
  #       ppois(k - 2, lambda = lambda, lower.tail = FALSE))

  ## Método 2:

  Probability <- function(x) {
    lambda ^ x * exp(- lambda) / factorial(x)
  }

  n * c(Probability(0:(k - 2)), 1 - sum(Probability(0:(k - 2))))
}

NegativeBinomialExpected <- function(n, k, size, prob) {
  ## Método 1

  # n * c(dnbinom(0:(k - 2), size = size, prob = prob),
  #       pnbinom(k - 2, size = size, prob = prob, lower.tail = FALSE))

  ## Método 2:

  Probability <- function(x) {
    (x + 1) * prob ^ 2 * (1 - prob) ^ x
  }

  n * c(Probability(0:(k - 2)), 1 - sum(Probability(0:(k - 2))))
}

(expected3 <- PoissonExpected(n3, k3, 1.2))
# 18.071653 21.685983 13.011590  7.230774

(Q3 <- sum((observed3 - expected3) ^ 2 / expected3))
# 9.099696

(pvalue3 <- 1 - pchisq(Q3, k3 - 1))
# 0.02799433

## Nos vemos obligados a rechazar la hipótesis nula (los datos siguen una
## distribución de Poisson(1.2)) en favor de la alternativa (no pertenecen
## a dicha distribución).

### Ejercicio 3 - Apartado B

(null3 <- PoissonExpected(n3, k3, 1.2))
# 18.071653 21.685983 13.011590  7.230774

(alternative3 <- NegativeBinomialExpected(n3, k3, 2, 2 / 3))
# 26.666667 17.777778  8.888889  6.666667

(Q3b <- sum((alternative3 - null3) ^ 2 / null3))
# 6.142462

(power3b <- 1 - pchisq(qchisq(1 - alpha, df = k3 - 1), df = k3 - 1, ncp = Q3b))
# 0.5286654

### Ejercicio 3 - Apartado C

fn <- function(n) {
  null <- PoissonExpected(n, k3, 1.2)
  alternative <- NegativeBinomialExpected(n, k3, 2, 2 / 3)
  Q <- sum((alternative - null) ^ 2 / null)
  power <- 1 - pchisq(qchisq(1 - alpha, df = k3 - 1), df = k3 - 1, ncp = Q)
  return(power)
}

(n.exact3 <- uniroot(function(n) {fn(n) - 0.9}, c(1, 1000))$root)
# 138.4281

ceiling(n.exact3)
# 139

## Necesitamos un tamaño muestral de 139 observaciones para poder obtener una
## potencia == 0.9 en el contraste acerca de si los datos siguen una
## distribución de Poisson(1.2) cuando realmente pertenecen a una distribución
## BinomialNegativa(2, 2/3)


### Code skeleton for Series 6, Exercise 1
### Please replace all triple questionmarks by some
### code.

set.seed(3)
(true.par <- mean(rgamma(100000000, shape = 2, rate = 2), trim = 0.1))

set.seed(1)
sample40 <- rgamma(n = 40, shape = 2, rate = 2)
mean(sample40, trim = 0.1)

###################################################
### TASK a)
###################################################
require("boot")
tm <- function(x, ind) {mean(x[ind], trim = 0.1)}

# nominal levels at which we want to evaluate coverage
levels <- c(round(seq(0.7, 0.99, 0.01), 2), round(seq(0.992, 0.996, 0.002), 3))
nl <- length(levels)
# desired coverage
conf <- 0.9

# outer layer
M <- 50
# inner layer and final estimate
B <- 500

# function called by the outer bootstrap
# estimates confidence intervals on second layer of bootstrap
boot.outer.fnn <- function(data, ind, B){
  res.boot.inner <- boot(data = data[ind], statistic = tm, R = B,
                         sim = "ordinary")
  bci <- boot.ci(res.boot.inner, conf = levels,
                 type = c("basic"))
  ci <- bci[["basic"]][,4:5]
  # returns theta_hat*, all lower bound and all upper bounds
  out <- c(res.boot.inner$t0, ci[,1], ci[,2])
  names(out) <- c("tm", paste("lower", levels, sep="_"), paste("upper", levels, sep="_"))
  out
}

# get the confidence interval on the nominal levels 1-alpha and 1-alpha' based on B samples
# this can be pulled from $t0
get.ci <- function(res.boot.outer, conf, level.prime) {
  if(!is.na(level.prime)) {
    level.indices <- c(which(levels == conf), which(levels == level.prime))
  } else {
    # if we don't find any applicable level, we cheat and use the highest available
    level.indices <- c(which(levels == conf), nl)
  }

  lower0 <- res.boot.outer$t0[2:(nl + 1)]
  upper0 <- res.boot.outer$t0[(nl + 2):(2*nl + 1)]

  matrix(cbind(lower0[level.indices], upper0[level.indices]), nrow = 2,
         dimnames =  list(c("basic", "double"), c("lower", "upper")))
}

res.boot.outer <-  boot(sample40, statistic = boot.outer.fnn, R = M, B = B)

# function to find 1 - alpha'
get.level.prime <- function(res.boot.outer, conf){
  thh <- res.boot.outer$t0[1]
  # 1 + 33 + 33
  lower <- res.boot.outer$t[, 2:34] # lower from 2 to 34
  upper <- res.boot.outer$t[, 35:67] # upper from 35 to 67
  included <- lower <= thh & thh <= upper
  colnames(included) <- levels
  cover <- apply(included, 2, mean)
  if(max(cover) >= conf){
    level.prime <- min(levels[cover >= conf])
  } else {
    # if we are unable to to receive the desired coverage
    level.prime <- NA
  }
  level.prime
}

(level.prime <- get.level.prime(res.boot.outer, conf))
get.ci(res.boot.outer, conf, level.prime)

###################################################
### TASK b, c)
###################################################

##' Checks if a confidence interval contains the true parameter (separately
##' for the lower and the upper end)
##'
##' @param ci: Output of the function boot.ci which contains CIs
##' @param ty: Type of confidence interval
##' @param true.par: True parameter
##'
##' @return Vector with two elements where first one corresponds to the lower
##'         end and the second to the upper end of the confidence interval.
##'         If the CI is [CI_l, CI_u], the first element is 1 if theta < CI_l
##'         and 0 otherwise. The second element is 1 if theta > CI_u and 0
##'         otherwise.
check_ci <- function(ci, ty, true.par) {
  # Get confidence interval of type ty from object ci
  lower.upper <- ci[ty,]

  res <- if (true.par < lower.upper[1]) {
    c(1, 0)
  } else if (true.par > lower.upper[2]) {
    c(0, 1)
  } else {
    c(0, 0)
  }
  names(res) <- c("lower", "upper")

  return(res)
}

##' Runs one simulation run, i.e. creates new data set, calculates bootstrap
##' CIs, and checks if true parameter is contained.
##'
##' @param n: Size of sample
##' @param true.par: True parameter
##' @param B: Number of bootstrap replicates in inner bootstrap
##' @param M: Number of bootstrap replicates in outer bootstrap
##' @param conf: desired coverage
##' @param type: Type of bootstrap CIs, only "basic" or "double"
##'
##' @return A vector containing the result of the function check_ci for each
##'         of the confidence intervals and the estimated 1-alpha'
do_sim <- function(n, true.par, B = 500, M = 50, conf = 0.9,
                   type = c("basic", "double")) {
  # Generate the data
  x <- rgamma(n = n, shape = 2, rate = 2)
  # Evaluate the double bootstrap
  res.boot.outer <-  boot(x, statistic = boot.outer.fnn, R = M, B = B)
  # find 1 - alpha'
  level.prime <- get.level.prime(res.boot.outer, conf)
  # find CIs at level 1-alpha and 1-alpha'
  res.ci <- get.ci(res.boot.outer, conf, level.prime)

  # Check if CIs contain true.par
  res <- vector(mode = "integer", length = 0)
  for (ty in type) {
    res <- c(res, check_ci(ci = res.ci, ty = ty, true.par = true.par))
    names(res)[(length(res) - 1):length(res)] <-
      paste(c(ty, ty), c("lower", "upper"), sep = "_") #add names in the format
    #'type_lower' and 'type_upper'
  }
  # store 1 - alpha' as well
  res <- c(res, level.prime)
  names(res)[length(res)] <- "level.prime"

  return(res)
}

##########################
### Run simulation     ###
##########################
set.seed(22)
require("boot")
sample.size <- c(10, 40, 160, 640)
n.sim <- 200
type <- c("basic", "double")

# The object RES stores the results, i.e. each row corresponds
# to the non-coverage rate for the lower and upper ends of the
# confidence intervals, i.e. the percentage of times that theta < CI_l
# and the percentage of times that theta > CI_u, if the CI is
# denoted by (CI_l, CI_u). Further we add one column for the median of the estimated 1 - alpha',
# one for the fraction of times we could not find 1 - alpha' and one for n.
RES <- matrix(NA, nrow = length(sample.size), ncol = 7)
colnames(RES) <- c(paste(rep(type, each = 2),
                         rep(c("lower", "upper"), times = length(type)),
                         sep = "_"), "median_level_prime", "NA_fraction", "n")

for (j in 1:length(sample.size)) {
  n <- sample.size[j]
  cat("n =",  n ,"\n")
  # The object res.sim stores the results, i.e. each row corresponds
  # to the output of the function do_sim. This means that each row contains 0
  # and 1 encoding whether the true parameter was inside the CI or outside
  # as well as 1 - alpha'.
  res.sim <- matrix(NA, nrow = n.sim, ncol = length(type) * 2 + 1)
  for (i in 1:n.sim) {
    cat("."); if(i %% 20 == 0) cat(i ,"\n")
    # Simulate one data-set
    res.sim[i, ] <- do_sim(n = n, true.par = true.par, type = type)
  }
  # Compute the upper and lower non-coverage rate, the median of 1 - alpha'
  # and the fraction of simulation runs, where we did not find 1 - alpha'
  RES[j, ] <- c(apply(res.sim[,1:(length(type) * 2)], 2, mean),
                median(res.sim[,(length(type) * 2) + 1 ], na.rm = TRUE),
                mean(is.na(res.sim[,(length(type) * 2) + 1 ])), n)
}

y.lim <- max(RES[, 1:(length(type) * 2)])

# Plot of lower non-coverage
plot(basic_lower ~ n, data = RES, col = 1, pch = 1, ylim = c(0, y.lim),
     log = "x", ylab = "One-sided non-coverage",
     main = "Non-coverage of the lower end of the CIs.")
points(double_lower ~ n, data = RES, col = 2, pch = 2, xlog = TRUE)
lines(basic_lower ~ n, data = RES, col = 1, lty = 1, xlog = TRUE)
lines(double_lower ~ n, data = RES, col = 2, lty = 2, xlog = TRUE)
abline(h = 0.05, lty = 5)
legend("topright", legend = c("reversed", "double bootstrap"),
       pch = 1:2, lty = 1:2, col = 1:2)

# do it analogously for the upper non-coverage


### Code skeleton for Series 5, Exercise 2
### Please replace all triple questionmarks by some
### code.

###################################################
### TASK a)
###################################################
set.seed(3)
(true.par <- mean(rgamma(100000000, shape = 2, rate = 2), trim = 0.1))

print(true.par)

###################################################
### TASK b)
###################################################
set.seed(1)
sample40 <- rgamma(n = 40, shape = 2, rate = 2)

print(mean(sample40, trim = 0.1))

###################################################
### TASK c)
###################################################
require("boot")
tm <- function(x, ind) {mean(x[ind], trim = 0.1)}

res.boot <- boot(data = sample40, statistic = tm, R = 10000,
                 sim = "ordinary")
print(boot.ci(res.boot, conf = 0.95, type = c("basic", "norm", "perc")))

###################################################
### TASK d)
###################################################

##' Checks if a confidence interval contains the true parameter (separately
##' for the lower and the upper end)
##'
##' @param ci: Output of the function boot.ci which contains CIs
##' @param ty: Type of confidence interval
##' @param true.par: True parameter
##'
##' @return Vector with two elements where first one corresponds to the lower
##'         end and the second to the upper end of the confidence interval.
##'         If the CI is [CI_l, CI_u], the first element is 1 if theta < CI_l
##'         and 0 otherwise. The second element is 1 if theta > CI_u and 0
##'         otherwise.
check_ci <- function(ci, ty, true.par) {
  # Get confidence interval of type ty from object ci
  lower.upper <- switch (ty,
                         "norm" = ci[["normal"]][2:3],
                         "perc" = ci[["percent"]][4:5],
                         "basic" = ci[["basic"]][4:5]
  )

  res <- if (true.par < lower.upper[1]) {
    c(1, 0)
  } else if (true.par > lower.upper[2]) {
    c(0, 1)
  } else {
    c(0, 0)
  }
  names(res) <- c("lower", "upper")

  return(res)
}

##' Runs one simulation run, i.e. creates new data set, calculates bootstrap
##' CIs, and checks if true parameter is contained.
##'
##' @param n: Size of sample
##' @param true.par: True parameter
##' @param R: Number of bootstrap replicates
##' @param type: Type of bootstrap CIs, see function boot.ci
##'
##' @return A vector containing the result of the function check_ci for each
##'         of the confidence intervals
do_sim <- function(n, true.par, R = 500,
                   type = c("basic", "norm", "perc")) {
  # Generate the data
  x <- rgamma(n = 40, shape = 2, rate = 2)
  # Construct the CIs for the trimmed mean
  res.boot <- boot(data = x, statistic = tm, R = R, sim = "ordinary")
  res.ci <- boot.ci(res.boot, conf = 0.95, type = type)

  # Check if CIs contain true.par
  res <- vector(mode = "integer", length = 0)
  for (ty in type) {
    res <- c(res, check_ci(ci = res.ci, ty = ty, true.par = true.par))
    names(res)[(length(res) - 1):length(res)] <-
      paste(c(ty, ty), c("lower", "upper"), sep = "_") #add names in the format
                                                       #'type_lower' and 'type_upper'
  }

  return(res)
}

##########################
### Run simulation     ###
##########################
set.seed(22)
require("boot")
sample.size <- c(10, 40, 160, 640)
n.sim <- 200
type <- c("basic", "norm", "perc")

# The object RES stores the results, i.e. each row corresponds
# to the non-coverage rate for the lower and upper ends of the
# confidence intervals, i.e. the percentage of times that theta < CI_l
# and the percentage of times that theta > CI_u, if the CI is
# denoted by (CI_l, CI_u). The last column of RES corresponds to
# the number of observations.
RES <- matrix(NA, nrow = length(sample.size), ncol = length(type) * 2 + 1)
colnames(RES) <- c(paste(rep(type, each = 2),
                         rep(c("lower", "upper"), times = length(type)),
                         sep = "_"), "n")

for (j in 1:length(sample.size)) {
  n <- sample.size[j]
  # The object res.sim stores the results, i.e. each row corresponds
  # to the output of the function do_sim. This means that each row contains 0
  # and 1 encoding whether the true parameter was inside the CI or outside.
  # Also see the function check_ci.
  res.sim <- matrix(NA, nrow = n.sim, ncol = length(type) * 2)
  for (i in 1:n.sim) {
    # Compute CIs and check if true.par is contained in them
    res.sim[i, ] <- do_sim(n = n, true.par = true.par, type = type)
  }
  # Compute the upper and lower non-coverage rate
  RES[j, ] <- c(apply(res.sim, 2, mean), n)
}

print(RES)

###################################################
### TASK e)
###################################################
y.lim <- max(RES[, -ncol(RES)])

# Plot of lower non-coverage
plot(basic_lower ~ n, data = RES, col = 1, pch = 1, ylim = c(0, y.lim),
     log = "x", ylab = "One-sided non-coverage",
     main = "Non-coverage of the lower end of the CIs.")
points(norm_lower ~ n, data = RES, col = 2, pch = 2, xlog = TRUE)
points(perc_lower ~ n, data = RES, col = 3, pch = 3, xlog = TRUE)
lines(basic_lower ~ n, data = RES, col = 1, lty = 1, xlog = TRUE)
lines(norm_lower ~ n, data = RES, col = 2, lty = 2, xlog = TRUE)
lines(perc_lower ~ n, data = RES, col = 3, lty = 3, xlog = TRUE)
abline(h = 0.025, lty = 5)
legend("topright", legend = c("quantile", "normal", "reverse"),
       pch = 1:3, lty = 1:3, col = 1:3)

# do it analogously for the upper non-coverage


library(CreditMetrics)
set.seed(1)

RatingClasses <- c("AAA", "AA", "A", "BBB", "BB", "B", "CCC", "D")
TransitionMatrix <- matrix(c(90.710,	8.340,	0.710,	0.075,	0.095,	0.025,	0.022,	0.023,
                             0.710,	90.550,	7.810,	0.720,	0.060,	0.120,	0.020,	0.010,
                             0.092,	2.220,	91.250,	5.420,	0.720,	0.230,	0.011,	0.057,
                             0.020,	0.420,	5.890,	85.880,	5.290,	1.190,	1.140,	0.170,
                             0.036,	0.124,	0.670,	7.730,	80.590,	8.790,	1.010,	1.050,
                             0.011,	0.119,	0.230,	0.440,	6.510,	83.440,	4.060,	5.190,
                             0.220,	0.000,	0.230,	1.330,	2.360,	11.210,	64.830,	19.820,
                             0, 0, 0, 0, 0, 0, 0, 100
)/100, 8, 8, dimnames = list(RatingClasses, RatingClasses), byrow = TRUE)
TransitionMatrix

library(markovchain)

MCModel <- new("markovchain", transitionMatrix = TransitionMatrix, states=RatingClasses, byrow = TRUE, name="MarkovChainModel")
MCModel

MCModel@states

transitionProbability(MCModel,"AAA","AA")

#CREDIT SPREAD

LGD <- 0.40

CreditRiskSpread<-cm.cs(TransitionMatrix, LGD)
CreditRiskSpread

# reference value
Rating <- c("B", "BB", "CCC")
EAD <- c(4000, 10000, 500000)
Rindex <- 0.02

RefValue<-cm.ref(TransitionMatrix, LGD, EAD, Rindex, Rating)

RefValue$constVal
RefValue$constPV

absorbingStates(MCModel)


fib <- function(n) {
  if (n < 2) n else Recall(n - 1) + Recall(n - 2)
}

fibLinear <- function(n) {
  fibs <- c(0, 1)
  while (n > 0) {
    temp <- fibs[2]
    fibs[2] <- sum(fibs)
    fibs[1] <- temp
    n <- n - 1
  }
  fibs[1]
}

fibFormula <- function(n) {
  round(((5 ^ 0.5 + 1) / 2) ^ n / 5 ^ 0.5)
}

fibTailRecursive <- function(n, prevFib = 0, fib = 1) {
  if (n == 0) prevFib else Recall(n - 1, fib, prevFib + fib)
}

fibFastDoubling <- function(n) {
  fibFastAuxiliary <- function(n) {
    if (n == 0) return(list(0, 1))

    fibs <- Recall(floor(n / 2))
    prevFib <- fibs[[1]]
    fib <- fibs[[2]]
    a <- prevFib * (fib * 2 - prevFib)
    b <- prevFib * prevFib + fib * fib
    if (n %% 2 == 0) list(a, b) else list(b, a + b)
  }
  fibFastAuxiliary(n)[[1]];
}

args = commandArgs(trailingOnly=TRUE)
input = if (length(args) > 0) as.numeric(args[1]) else 29
print(fibFastDoubling(input))


#Intro
png("#45_confidence_interval_around_model.png" , width = 480, height = 480 )
par(mar=c(2,2,1,1))

# We create 2 vectors x and y. It is a polynomial function.
x <- runif(300,  min=-30, max=30)
y <-  -1.2*x^3 + 1.1 * x^2 - x + 10 + rnorm(length(x),0,100*abs(x))

# Basic plot of x and y :
plot(x,y,col=rgb(0.4,0.4,0.8,0.6), pch=16 , cex=1.3 , xlab="" , ylab="")

# Can we find a polynome that fit this function ?
model=lm(y ~ x + I(x^2) + I(x^3))

# I can get the features of this model :
summary(model)
model$coefficients
summary(model)$adj.r.squared

#For each value of x, I can get the value of y estimated by the model, and the confidence interval around this value.
myPredict <- predict( model , interval="predict" )

#Finally, I can add it to the plot using the line and the polygon function with transparency.
ix <- sort(x,index.return=T)$ix
lines(x[ix], myPredict[ix , 1], col=2, lwd=2 )
polygon(c(rev(x[ix]), x[ix]), c(rev(myPredict[ ix,3]), myPredict[ ix,2]), col = rgb(0.7,0.7,0.7,0.4) , border = NA)

dev.off()


#Copyright (c) 2016 Riccardo Francescato
p = 5 # number of rows
N = p^2
alpha = .05
RawLatin=c("A","B","C","D","E",
  			"B","C","D","E","A",
  			"C","D","E","A","B",
  			"D","E","A","B","C",
  			"E","A","B","C","D")
RawData = c(-1,-5,-6,-1,-1,
  		   	-8,-1, 5, 2,11,
  		   	-7,13, 1, 2,-4,
  		   	 1, 6, 1,-2,-3,
  		   	-3, 5,-5, 4, 6)

data = matrix(RawData,nrow=p,ncol=p,byrow = TRUE)
latin = matrix(RawLatin,nrow=p,ncol=p,byrow = TRUE)

SStot = sum(data^2) - sum(data)^2/N

SSrows = 0
for(i in 1:p){
	SSrows = SSrows + sum(data[i,])^2
}
SSrows = SSrows *(1/p) - sum(data)^2/N

SScol = 0
for(i in 1:p){
	SScol = SScol + sum(data[,i])^2
}
SScol = SScol *(1/p) - sum(data)^2/N

TreatTot = vector(,p)
for(i in 1:p){
	TreatTot[i]=0
}

for(i in 1:N){
	if(RawLatin[i]=="A") TreatTot[1]=TreatTot[1]+RawData[i]
	if(RawLatin[i]=="B") TreatTot[2]=TreatTot[2]+RawData[i]
	if(RawLatin[i]=="C") TreatTot[3]=TreatTot[3]+RawData[i]
	if(RawLatin[i]=="D") TreatTot[4]=TreatTot[4]+RawData[i]
	if(RawLatin[i]=="E") TreatTot[5]=TreatTot[5]+RawData[i]
}

SStreat=0
for(i in 1:p){
	SStreat = SStreat + TreatTot[i]^2
}
SStreat = SStreat *(1/p) - sum(data)^2/N

SSerr = SStot - SSrows - SScol - SStreat

MStreat = SStreat/(p-1)
MSrows = SSrows/(p-1)
MScols = SScol/(p-1)
MSerr = SSerr/((p-2)*(p-1))

F0 = MStreat/MSerr
Fa = qf(alpha,df1=p-1,df2=((p-2)*(p-1)),lower.tail=F)

if(F0 > Fa) print(paste0(" reject H0 ", F0)) else print(paste0(" Accept H0 ", F0))
cat(paste0(" Treatments  SS: ",SStreat," Df: ", p-1 ," MS: ",MStreat, " F0: ",F0,
		"\n Rows  SS: ",SSrows," Df: ", p-1 ," MS: ",MSrows,
		"\n Cols  SS: ",SScol," Df: ", p-1 ," MS: ",MScols,
		"\n Error  SS: ",SSerr," Df: ", (p-2)*(p-1) ," MS: ",MSerr,
		"\n Total  SS: ",SStot," Df: ", (p^2)-1))

delivery.df = data.frame(
  Opersators = c(rep("O1", p), rep("O2", p), rep("O3", p), rep("O4", p), rep("O5", p)),
  Batches = c(rep(c("B1", "B2", "B3", "B4","B5"), p)),
  Formulation = RawLatin,
  Data = RawData
)

delivery.mod1 = lm(Data ~ Formulation+Batches+Opersators, delivery.df)
anova(delivery.mod1)


### 判別分析の例
### - 企業別の利益データ (2007-2012年度)

## データの読み込み ("jpcompany.csv"を用いる)
raw <- read.csv(file="data/jpcompany.csv",row.names=1) # データの読み込み
scan(file="data/jpcompany.txt",what=character(),sep=";") # 説明の表示

## データの内容を表示
## print(raw)    # 全データの表示
head(raw,n=3) # 最初の3個を表示
## tail(raw,n=3) # 最後の3個を表示

## 判別分析のためにデータを整形
## class: 2011年から2012年に掛けて営業利益が増収(pos)/減収(neg)
## 特徴量: 売上高に占める各利益の割合
mydata <- data.frame(class=ifelse(raw[,26]-raw[,22]>0,"pos","neg"))
for (k in 1:5){
    mydata <- data.frame(mydata,raw[,(4*k+1)+(1:3)]/raw[,4*k+1])
}
names(mydata)[2:ncol(mydata)] <- # 特徴量の名前
    paste(rep(c("営業利益率","経常利益率","純利益率"),5),
          rep((1:5)+2006,each=3),sep=".")
rownames(mydata) <- raw[,2]  # 各社の名前
mydata <- na.exclude(mydata) # 欠損(NA)の除去
head(mydata,n=3) # 最初の3個を表示

## データの一部とラベルの関係を図示
item <- c(1,5,8,11,14)
## print(names(mydata)[item]) # 項目名の表示
## データの散布図: 図(a)
ggpairs(mydata,
        columns=item, mapping=aes(colour=class)) +
    theme(text=element_text(family="HiraMaruProN-W4"))
## ## ggscatmat を用いる場合 (class以外が表示される)
## ggscatmat(mydata,
##           columns=item, color="class", alpha=.5) +
##     theme(text=element_text(family="HiraMaruProN-W4"))

## データ全体で判別式を作成
model <- lda(class ~ ., data=mydata)
table(true=mydata$class,predict=predict(model)$class)

## 線形判別関数の値の分布をクラス毎に表示
predict.tr <- predict(model)
res.tr <- data.frame(x=as.vector(predict.tr$x),
                    class=mydata$class,
                    d=c(neg=0,pos=1)[mydata$class])
## 判別関数の値の分布: 図(b)
ggplot(res.tr, aes(x)) +
    geom_histogram(aes(fill=class)) +
    facet_grid(class ~ .) + theme(legend.position="none")

## 全体を用いると判別があまり良好でないので
## 2011年の経常利益率で層別に調べてみる
## (業種別に調べると良いかもしれないが各業種のデータが少ない)
conditions <- c("経常利益率.2011<0.05",
                "経常利益率.2011>0.05&経常利益率.2011<0.1",
                "経常利益率.2011>0.1&経常利益率.2011<0.2",
                "経常利益率.2011>0.2")
for(i in 1:4){
    subdata <- subset(mydata, subset=eval(parse(text=conditions[i])))
    submodel <- lda(class ~ ., data=subdata)
    tbl <- table(true=subdata$class,predict=predict(submodel)$class)
    print(conditions[i])
    print(tbl)
    ## 線形判別関数の値の分布をクラス毎に表示
    predict.tr <- predict(submodel)
    res.tr <- data.frame(x=as.vector(predict.tr$x),
                         class=subdata$class,
                         d=c(neg=0,pos=1)[subdata$class])
    ## 層別の判別関数の値の分布: 図(c)-(f)
    gg <- ggplot(res.tr, aes(x)) +
        geom_histogram(aes(fill=class)) +
        facet_grid(class ~ .) +
        theme(text=element_text(family="HiraMaruProN-W4"),
              legend.position="none") +
        labs(title=conditions[i])
    print(gg)
}