nxt <- function(d, mu=0., sigma=1.) {
  n <- length(d$x)
  d$x <- d$x + rnorm(n,mu,sigma)
  d$y <- d$y + rnorm(n,mu,sigma)
  return(d)
}

nxt.unif <- function(d, mu=0., sigma=1.) {
  n <- length(d$x)
  limit <- sqrt(3)*sigma
  d$x <- d$x + runif(n,mu-limit,mu+limit)
  d$y <- d$y + runif(n,mu-limit,mu+limit)
  return(d)
}

plot.snap <- function(d, i, prefix, edge=10.0) {
  png(sprintf("%s_%5.5d.png", prefix, i), width=760, height=760)
  plot(d$x, d$y, xlim=c(-edge/2.,edge/2.), ylim=c(-edge/2.,edge/2.), main="", xlab="", ylab="", cex=0.2, col="grey")
  dev.off()
}

plot.snap <- function(d, i, prefix, edge=10.0) {
  png(sprintf("%s_%5.5d.png", prefix, i), width=760, height=760)
  plot(d$x, d$y, xlim=c(-edge/2.,edge/2.), ylim=c(-edge/2.,edge/2.), main="", xlab="", ylab="", cex=0.2, col="grey")
  dev.off()
}

snaps <- function(n, n.iter, prefix, mu=0.0, sigma=1.0, edge=10.0) {
  std.x <- numeric(n.iter)
  std.y <- numeric(n.iter)
  d <- data.frame(x=numeric(n), y=numeric(n))
  for(i in 1:n.iter) {
    plot.snap(d, i, prefix, edge)
    d <- nxt(d, mu, sigma)
    std.x[i] <- sd(d$x)
    std.y[i] <- sd(d$y)
    print(sprintf("Iteration %d made", i))
  }
  return(list(data=d,std.x=std.x,std.y=std.y))
}

snaps.unif <- function(n, n.iter, prefix, mu=0.0, sigma=1.0, edge=10.0) {
  std.x <- numeric(n.iter)
  std.y <- numeric(n.iter)
  d <- data.frame(x=numeric(n), y=numeric(n))
  for(i in 1:n.iter) {
    plot.snap(d, i, prefix, edge)
    d <- nxt.unif(d, mu, sigma)
    std.x[i] <- sd(d$x)
    std.y[i] <- sd(d$y)
    print(sprintf("Iteration %d made", i))
  }
  return(list(data=d,std.x=std.x,std.y=std.y))
}

process.normal <- function(n.part=3000, n.snaps=900) {
  par(mfrow=c(1,1))
  l<-snaps(n.part, n.snaps, "normal/snap", 0.0, 0.03, 10)
  d <- l$data
  png(file="normal/marginal.png", width=760*2, height=760)
  par(mfrow=c(1,2))
  hist(d$x, main="", xlab="x", ylab="Densità", prob=TRUE, col="pink")
  lines(density(d$x),lw=2,col="red")
  mu <- mean(d$x)
  s  <- sd(d$x)
  x.min <- -10.0/2
  x.max <-  10.0/2
  x <- seq(from=x.min,to=x.max,by=10/100)
  lines(x, dnorm(x,mu,s), col="black", lw=2)
  rug(jitter(d$x))
  hist(d$y, main="", xlab="y", ylab="Densità", prob=TRUE, col="pink")
  lines(density(d$y),lw=2,col="red")
  mu <- mean(d$y)
  s  <- sd(d$y)
  y.min <- -10.0/2
  y.max <-  10.0/2
  y <- seq(from=y.min,to=y.max,by=10/100)
  lines(y, dnorm(y,mu,s), col="black", lw=2)
  rug(jitter(d$y))
  par(mfrow=c(1,1))
  dev.off()
  png(file="normal/devstd.png", height=720, width=720)
  par(mfrow=c(2,1))
  plot((1:n.snaps)/30, l$std.x, type="l", xlab="Tempo (s)", ylab="Dev.std. asse X (m)", col="red")
  plot((1:n.snaps)/30, l$std.y, type="l", xlab="Tempo (s)", ylab="Dev.std. asse Y (m)", col="red")
  par(mfrow=c(1,1))
  dev.off()
}

process.unif <- function(n.part=3000, n.snaps=900) {
  par(mfrow=c(1,1))
  l<-snaps.unif(n.part, n.snaps, "uniform/snap", 0.0, 0.03, 10)
  d <- l$data
  png(file="uniform/marginal.png", width=760*2, height=760)
  par(mfrow=c(1,2))
  hist(d$x, main="", xlab="x", ylab="Densità", prob=TRUE, col="pink")
  lines(density(d$x),lw=2,col="red")
  mu <- mean(d$x)
  s  <- sd(d$x)
  x.min <- -10.0/2
  x.max <-  10.0/2
  x <- seq(from=x.min,to=x.max,by=10/100)
  lines(x, dnorm(x,mu,s), col="black", lw=2)
  rug(jitter(d$x))
  hist(d$y, main="", xlab="y", ylab="Densità", prob=TRUE, col="pink")
  lines(density(d$y),lw=2,col="red")
  mu <- mean(d$y)
  s  <- sd(d$y)
  y.min <- -10.0/2
  y.max <-  10.0/2
  y <- seq(from=y.min,to=y.max,by=10/100)
  lines(y, dnorm(y,mu,s), col="black", lw=2)
  rug(jitter(d$y))
  par(mfrow=c(1,1))
  dev.off()
  png(file="uniform/devstd.png", height=720, width=720)
  par(mfrow=c(2,1))
  plot((1:n.snaps)/30, l$std.x, type="l", xlab="Tempo (s)", ylab="Dev.std. asse X (m)", col="red")
  plot((1:n.snaps)/30, l$std.y, type="l", xlab="Tempo (s)", ylab="Dev.std. asse Y (m)", col="red")
  par(mfrow=c(1,1))
  dev.off()
}


# take input from the user
num = as.integer(readline(prompt="Enter a number: "))
# initialize sum
sum = 0
# find the sum of the cube of each digit
temp = num
while(temp > 0) {
digit = temp %% 10
sum = sum + (digit ^ 3)
temp = floor(temp / 10)
}
# display the result
if(num == sum) {
print(paste(num, "is an Armstrong number"))
} else {
print(paste(num, "is not an Armstrong number"))
}


fisheryatesknuthshuffle <- function(n)
{
   a <- seq_len(n)
   while(n >=2)
   {
      k <- sample.int(n, 1)
      if(k != n)
      {
         temp <- a[k]
         a[k] <- a[n]
         a[n] <- temp
      }
      n <- n - 1
   }
   a
}

#Example usage:
fisheryatesshuffle(6)                # e.g. 1 3 6 2 4 5
x <- c("foo", "bar", "baz", "quux")
x[fisheryatesknuthshuffle(4)]        # e.g. "bar"  "baz"  "quux" "foo"


# percentile of normal distribution using r
# we will use qnorm function
# 75th percentile of Normal distribution Mean = 530 and SD=205
mu=530
sigma=205
z_75percentile=0.67
y=mu+sigma*z_75percentile
print(y)
 print("  Thus , 25% of the tax returns in this classification exceed $667.35 in the amount owed the government.")


# For details of this cuts this file is demonstrating see http://arxiv.org/abs/1512.04644

# assumes theta bounds are +/- around 0, w.o.l.g.
# this allows us to easily take the projection through reference angle of theta = 0

animation_steps = 60

#theta_ub = 0.261799 # 15 degrees in radians
theta_ub = 0.5236 # 30 degrees in radians
vi_ub = 1.2
vi_lb = 0.8

vj_ub = 1.2
vj_lb = 0.8

vi_sigma = vi_ub+vi_lb
vj_sigma = vj_ub+vj_lb

wi_ub = vi_ub^2
wi_lb = vi_lb^2

wj_ub = vj_ub^2
wj_lb = vj_lb^2

vj_val = vj_lb
wj_val = vj_val^2

line_width = 3
receding_color = rgb(0.5,0.5,0.5)
lnc1_color = "darkorange1"
lnc2_color = "dodgerblue1"

file_name_prefix = "lnc"

vj_steps = seq(vj_lb, vj_ub, length.out=animation_steps)
#vj_steps = c((vj_lb+vj_ub)/2)
for (i in 1:length(vj_steps)) {

  vj_val = vj_steps[i]
  wj_val = vj_val^2

  pdf(paste("./pdfs/",file_name_prefix,"_",sprintf("%03d",i),".pdf",sep=""), pointsize=14, width=7, height=7, bg="white")
    x_lims = c(vi_lb*vj_lb*cos(theta_ub), vi_ub*vj_ub)
    y_lims = c(wi_lb, wi_ub)
    #print(x_lims)
    #print(y_lims)

    wi_steps = seq(wi_lb, wi_ub, length.out=30)

    plot(x_lims, y_lims,
      main="Lifted Nonlinear Cuts for AC Power Flow",
      sub=substitute(paste(w[i] %in% {}, "(", wil, ",", wiu,")  ", w[j] %in% {}, "(", wjl, ",", wju,")  ", theta %in% {}, "(", -tu, ",", tu, ")", sep=""), list(wil = wi_lb, wiu = wi_ub, wjl = wj_lb, wju = wj_ub, tu = theta_ub) ),
      xlab=expression({w^r}[ij]), ylab=expression(w[i]), type="n")

    # cut through theta=0
    points(sqrt(wi_steps*wj_val), wi_steps, type="l", lwd=line_width)

    # cut through the extreme value of theta, theta_ub
    points(sqrt(wi_steps*wj_val)*cos(theta_ub), wi_steps, type="l", lty=1, lwd=line_width, col=receding_color)

    # UB connecting line
    points(c(sqrt(wi_ub*wj_val)*cos(theta_ub), sqrt(wi_ub*wj_val)), c(wi_ub, wi_ub), type="l", lty=1, lwd=line_width, col=receding_color)

    # LB connecting line
    points(c(sqrt(wi_lb*wj_val)*cos(theta_ub), sqrt(wi_lb*wj_val)), c(wi_lb, wi_lb), type="l", lty=1, lwd=line_width, col=receding_color)

    # lnc 1
    # vj_ub*cos(theta_ub)*vj_sigma*w_i == vi_sigma*vj_sigma*wr_ij - vi_ub*cos(theta_ub)*vi_sigma*w_j - vi_ub*vj_ub*cos(theta_ub)*(vi_lb*vj_lb - vi_ub*vj_ub)
    lnc1_m = vi_sigma*vj_sigma/(vj_ub*cos(theta_ub)*vj_sigma)
    lnc1_b = (-vi_ub*vi_sigma*wj_val - vi_ub*vj_ub*(vi_lb*vj_lb - vi_ub*vj_ub))/(vj_ub*vj_sigma)
    abline(lnc1_b, lnc1_m, col=lnc1_color, lwd=line_width)

    # lnc 2
    # vj_lb*cos(theta_ub)*vj_sigma*w_i  == vi_sigma*vj_sigma*wr_ij - vi_lb*cos(theta_ub)*vi_sigma*w_j - vi_lb*vj_lb*cos(theta_ub)*(vi_ub*vj_ub - vi_lb*vj_lb)
    lnc2_m = vi_sigma*vj_sigma/(vj_lb*cos(theta_ub)*vj_sigma)
    lnc2_b = (-vi_lb*vi_sigma*wj_val - vi_lb*vj_lb*(vi_ub*vj_ub - vi_lb*vj_lb))/(vj_lb*vj_sigma)
    abline(lnc2_b, lnc2_m, col=lnc2_color, lwd=line_width)

    # documentation
    text( x_lims[1], y_lims[2]*0.97, pos=4, substitute(paste(w[j], " = ", wjv), list(wjv = sprintf("%.4f",wj_val))) ) #,     adj = c( 0, 1 ), col = "blue" )

    legend("bottomright", c("Surface", "Receding", "LNC 1", "LNC 2"), col = c("black", receding_color, lnc1_color, lnc2_color),
         lwd = c(line_width, line_width, line_width),
         merge = TRUE, bg="white")

  dev.off()
}


############################################################
# For macaque paper, 09.20
# Just does some of the Chi-squared tests for gene counts.
# Gregg Thomas
############################################################

this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

cat("----------\n\n")

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

cat("HUMAN AND MACAQUE GENE RATIOS BY CNV TYPE\n\n")
gene_ratios = matrix(c(1212,5483,226,1132), nrow=2, dimnames=list(c("macaque", "human"), c("del","dup")))
gene_ratio_chi = chisq.test(gene_ratios)
print(gene_ratio_chi)
cat("----------\n\n")
#
cat("HUMAN AND MACAQUE 10KB UPSTREAM RATIOS BY CNV TYPE\n\n")
up_ratios = matrix(c(469,3132,147,647), nrow=2, dimnames=list(c("macaque", "human"), c("del","dup")))
up_ratio_chi = chisq.test(up_ratios)
print(up_ratio_chi)
cat("----------\n\n")
#
cat("HUMAN AND MACAQUE 10KB DOWNSTREAM RATIOS BY CNV TYPE\n\n")
down_ratios = matrix(c(537,3174,149,693), nrow=2, dimnames=list(c("macaque", "human"), c("del","dup")))
down_ratio_chi = chisq.test(down_ratios)
print(down_ratio_chi)
cat("----------\n\n")
#
cat("HUMAN AND MACAQUE TRANSCRIPT RATIOS BY CNV TYPE\n\n")
transcript_ratios = matrix(c(2665,22246,476,4176), nrow=2, dimnames=list(c("macaque", "human"), c("del","dup")))
transcript_ratio_chi = chisq.test(transcript_ratios)
print(transcript_ratio_chi)
cat("----------\n\n")

cat("HUMAN AND MACAQUE EXON RATIOS BY CNV TYPE\n\n")
exon_ratios = matrix(c(936,7597,425,2587), nrow=2, dimnames=list(c("macaque", "human"), c("del","dup")))
exon_ratio_chi = chisq.test(exon_ratios)
print(exon_ratio_chi)
cat("----------\n\n")
# Numbers for these test come from adding full and partial events in TABLE 1
cat("----------\n\n")

cat("MACAQUE TOTAL CNVS BY TYPE TO CNVS OVERLAPPING EXONS BY TYPE\n\n")
mq_exon_ratio = matrix(c(432,90,3214,291), nrow=2, dimnames=list(c("total", "exon"), c("dup","del")))
mq_exon_chi = chisq.test(mq_exon_ratio)
print(mq_exon_chi)
cat("----------\n\n")
#
cat("HUMAN TOTAL CNVS BY TYPE TO CNVS OVERLAPPING EXONS BY TYPE\n\n")
hu_exon_ratio = matrix(c(1784,443,13745,2267), nrow=2, dimnames=list(c("total", "exon"), c("dup","del")))
hu_exon_chi = chisq.test(hu_exon_ratio)
print(hu_exon_chi)
cat("----------\n\n")
# Numbers for these test come from adding full and partial events in TABLE 2 and from cnv_counts.r


# Intro to Computational Finance with R

# Section 1 - Return Calculations

# Assign the URL to the CSV file
data_url <- "http://assets.datacamp.com/course/compfin/sbuxPrices.csv"

# Load the data frame using read.csv
sbux_df <- read.csv(data_url, header=TRUE, stringsAsFactors=FALSE)

# The sbux_df data frame is already loaded in your work space

# Check the structure of 'sbux_df'
str(sbux_df)

# Check the first and last part of 'sbux_df'
head(sbux_df)
tail(sbux_df)

# Get the class of the Date column of 'sbux_df'
class(sbux_df$Date)

# The sbux_df data frame is already loaded in your work space
closing_prices <- sbux_df['Adj.Close',drop=FALSE]

# The sbux_df data frame is already loaded in your work space

# Find indices associated with the dates 3/1/1994 and 3/1/1995
index_1 <- which(sbux_df$Date == '3/1/1994')
index_2 <- which(sbux_df$Date == '3/1/1995')

# Extract prices between 3/1/1994 and 3/1/1995
some_prices <- sbux_df[index_1:index_2, 'Adj.Close']

# The sbux_df data frame is already loaded in your work space

# Create a new data frame that contains the price data with the dates as the row names
sbux_prices_df <- sbux_df[, "Adj.Close", drop=FALSE]
rownames(sbux_prices_df) <- sbux_df$Date
head(sbux_prices_df)

# With Dates as rownames, you can subset directly on the dates.
# Find indices associated with the dates 3/1/1994 and 3/1/1995.
price_1 <- sbux_prices_df['3/1/1994', ];
price_2 <- sbux_prices_df['3/1/1995', ];

# Now add all relevant arguments to the plot function below to get a nicer plot
plot(sbux_df$Adj.Close, type='l', col='blue', lwd=2, ylab='Adjusted close', main='Monthly closing price of SBUX')
legend(x='topleft', legend='SBUX', lty=1, lwd=2, col='blue')

# The sbux_df data frame is already loaded in your work space
sbux_prices_df <- sbux_df[, "Adj.Close", drop=FALSE]

# Denote n the number of time periods
n <- nrow(sbux_prices_df)
sbux_ret <- (sbux_prices_df[2:n,1] - sbux_prices_df[1:(n-1),1]) / sbux_prices_df[1:(n-1),1]

# Notice that sbux_ret is not a data frame object
class(sbux_ret)# The sbux_df data frame is already loaded in your work space
sbux_prices_df <- sbux_df[, "Adj.Close", drop=FALSE]

# Denote n the number of time periods:
n <- nrow(sbux_prices_df)
sbux_ret <- ((sbux_prices_df[2:n, 1] - sbux_prices_df[1:(n-1), 1])/sbux_prices_df[1:(n-1), 1])

# Notice that sbux_ret is not a data frame object
class(sbux_ret)

# Now add dates as names to the vector and print the first elements of sbux_ret to the console to check
names(sbux_ret) <- sbux_df[2:n, 1]
head(sbux_ret)

# The sbux_df data frame is already loaded in your work space
sbux_prices_df <- sbux_df[, "Adj.Close", drop=FALSE]

# Denote n the number of time periods:
n <- nrow(sbux_prices_df)
sbux_ret <- ((sbux_prices_df[2:n, 1] - sbux_prices_df[1:(n-1), 1])/sbux_prices_df[1:(n-1), 1])

# Compute continuously compounded 1-month returns
sbux_ccret <- log(sbux_prices_df[2:n, 1]) - log(sbux_prices_df[1:(n-1), 1])

# Assign names to the continuously compounded 1-month returns
names(sbux_ccret) <- sbux_df[2:n,1]

# Show sbux_ccret
head(sbux_ccret)

# The sbux_df data frame is already loaded in your work space
sbux_prices_df <- sbux_df[, "Adj.Close", drop=FALSE]

# Denote n the number of time periods:
n <- nrow(sbux_prices_df)
sbux_ret <- ((sbux_prices_df[2:n, 1] - sbux_prices_df[1:(n-1), 1])/sbux_prices_df[1:(n-1), 1])

# Compute continuously compounded 1-month returns
sbux_ccret <- log(sbux_prices_df[2:n,1]) - log(sbux_prices_df[1:(n-1),1])
names(sbux_ccret) <- sbux_df[2:n,1]
head(sbux_ccret)

# Compare the simple and cc returns
head(cbind(sbux_ret, sbux_ccret))

# The simple returns (sbux_ret) and the continuously compounded returns (sbux_ccret) have been preloaded in your workspace

# Plot the returns on the same graph
plot(sbux_ret, type="l", col="blue", lwd=2, ylab="Return",
               main="Monthly Returns on SBUX")

# Add horizontal line at zero
abline(h=0)

# Add a legend
legend(x="bottomright", legend=c("Simple", "CC"),
       lty=1, lwd=2, col=c("blue","red"))

# Add the continuously compounded returns
lines(sbux_ccret, col='red', lwd=2)

# The simple returns (sbux_ret) and the continuously compounded returns (sbux_ccret) have been preloaded in your workspace

# Compute gross returns
sbux_gret <- sbux_ret + 1

# Compute future values
sbux_fv <-  cumprod(sbux_gret)

# Plot the evolution of the $1 invested in SBUX as a function of time
plot(sbux_fv, type="l", col="blue", lwd=2, ylab="Dollars",
     main="FV of $1 invested in SBUX")

# Section 2 Random Variables and Probabilities

# X ~ N(0.05, (0.10)^2)
mu_x <- 0.05
sigma_x <- 0.10

# Pr(X > 0.10)
1 - pnorm(0.10, mean = mu_x, sd = sigma_x)

# Pr(X < -0.10)
pnorm(-0.10, mean = mu_x, sd = sigma_x)

# Pr(-0.05 < X < 0.15)
1 - pnorm(-0.05, mean = mu_x, sd = sigma_x) - pnorm(0.15, mean = mu_x, sd = sigma_x, lower.tail=FALSE)

# The mean (mu_x) and the standard deviation (sigma_x) are still in your workspace

# 1%, 5%, 95% and 99% quantile
qnorm(c(0.01, 0.05, 0.95, 0.99), mean = mu_x, sd = sigma_x)

# Normally distributed monthly returns
x_vals <- seq(-0.25, 0.35, length.out = 100)
MSFT <- dnorm(x_vals, mean = 0.05, sd = 0.1)
SBUX <- dnorm(x_vals, mean=0.025, sd=0.05)

# MSFT and x_vals are still in your workspace

# Normal curve for MSFT
plot(x_vals, MSFT, type='l', col='blue', ylab='Normal curves', ylim=c(0,8))

# MSFT, SBUX and x_vals are still in your workspace

# Normal curve for MSFT
plot(x_vals, MSFT, type = "l", col = "blue", ylab = "Normal curves",
     ylim = c(0, 8))

# Add a normal curve for SBUX
lines(x_vals, SBUX, col='red')

# Add a plot legend
legend("topleft", legend = c("Microsoft", "Starbucks"),
       col = c("blue", "red"), lty = 1)

# R ~ N(0.04, (0.09)^2)
mu_R <- 0.04
sigma_R <- 0.09

# Initial wealth W0 equals $100,000
W0 <- 100000

# The 1% value-at-risk
(1 + qnorm(0.01, mean = mu_R, sd = sigma_R)) * W0 - W0

# The 5% value-at-risk
(1 + qnorm(0.05, mean = mu_R, sd = sigma_R)) * W0 - W0

# r ~ N(0.04, (0.09)^2)
mu_r <- 0.04
sigma_r <- 0.09

# Initial wealth W0 equals $100,000
W0 <- 100000

# The 1% value-at-risk
(1 + (exp(qnorm(0.01, mean = mu_r, sd = sigma_r)) - 1)) * W0 - W0

# The 5% value-at-risk
(1 + (exp(qnorm(0.05, mean = mu_r, sd = sigma_r)) - 1)) * W0 - W0

# Vectors of prices
PA <- c(38.23, 41.29)
PC <- c(41.11, 41.74)

# Simple monthly returns
RA <- (PA[2] - PA[1]) / PA[1]
RC <- (PC[2] - PC[1]) / PC[1]

# The simple returns on Amazon (RA) and Costco (RC) are still in your workspace

# Continuously compounded returns
rA <- log(PA[2]) - log(PA[1])
rC <- log(PC[2]) - log(PC[1])

# The prices for Amazon (PA) are still in your workspace

# Cash dividend per share
DA <- 0.1

# Simple total return
RA_total <- ((PA[2] + DA) - PA[1])/PA[1]

# Dividend yield
DY <- DA / PA[1]

# The simple monthly return on Amazon (RA) is still in your workspace

# Simple annual return
RA_annual <- ((1 + RA)^12) - 1

# Continuously compounded annual return
rA_annual <- log(1 + RA_annual)

# The simple returns on Amazon (RA) and Costco (RC) are still in your workspace

# Portfolio shares
xA <- 8000/10000
xC <- 2000/10000

# Simple monthly return
xA * RA + xC * RC

# Section 3 Bivariate Distributions

# Standard deviations and correlation
sig_x <- 0.10
sig_y <- 0.05
rho_xy <- 0.9

# Covariance between X and Y
sig_xy <- rho_xy * sig_x * sig_y

# Covariance matrix
Sigma_xy <- matrix(c(sig_x^2, sig_xy, sig_xy, sig_y^2), nrow=2, ncol=2, byrow=TRUE)

# Load the mvtnorm package
library("mvtnorm")

# The covariance matrix (Sigma_xy) is still in your workspace

# Means
mu_x <- 0.05
mu_y <- 0.025

# Simulate 100 observations
set.seed(123)  # for reproducibility
xy_vals <- rmvnorm(100, mean = c(mu_x, mu_y), sigma=Sigma_xy)

# Have a look at the first observations
head(xy_vals)

# The simulated values (xy_vals) are still in your workspace

# Create scatterplot
plot(xy_vals, pch=16, cex=2, col='blue', main='Bivariate normal: rho=0.9', xlab='x', ylab='y')

# Simulated values (xy_vals) and means (mu_x, mu_y) are still in your workspace

# create scatterplot
plot(xy_vals[, 1], xy_vals[, 2], pch = 16, cex = 2, col = "blue",
     main = "Bivariate normal: rho=0.9", xlab = "x", ylab = "y")

# Add lines
abline(v=mu_x, h=mu_y)

# Means (mu_x, mu_y) and covariance matrix (Sigma_xy) are still in your workspace

# create scatterplot
plot(xy_vals[, 1], xy_vals[, 2], pch = 16, cex = 2, col = "blue",
     main = "Bivariate normal: rho=0.9", xlab = "x", ylab = "y")

# Add lines
abline(h = mu_y, v = mu_x)

# Add line segments
segments(x0 = 0, y0 = -1e10, x1 = 0, y1 = 0, col="red")
segments(x0 = -1e10, y0 = 0, x1 = 0, y1 = 0, col="red")

# Compute joint probability
pmvnorm(lower = c(-Inf, -Inf), upper = c(0, 0), mean = c(mu_x, mu_y), sigma = Sigma_xy)

# Standard deviations and correlation
sig_x <- 0.10
sig_y <- 0.05
rho_xy <- -0.9
# Covariance between X and Y
sig_xy <- rho_xy * sig_x * sig_y
# Covariance matrix
Sigma_xy <- matrix(c(sig_x^2, sig_xy, sig_xy, sig_y^2), nrow = 2, ncol = 2)

# Means
mu_x <- 0.05
mu_y <- 0.025
# Simulate 100 observations
set.seed(123)  # for reproducibility
xy_vals <- rmvnorm(100, mean=c(mu_x, mu_y), sigma = Sigma_xy)
head(xy_vals)

# Create scatterplot
plot(xy_vals[, 1], xy_vals[, 2], pch = 16, cex = 2, col = "blue",
     main = "Bivariate normal: rho=-0.9", xlab = "x", ylab = "y")
# Add lines
abline(h = mu_y, v = mu_x)
# Add line segments
segments(x0 = 0, y0 = -1e10, x1 = 0, y1 = 0, col="red")
segments(x0 = -1e10, y0 = 0, x1 = 0, y1 = 0, col="red")

# Compute joint probability
pmvnorm(lower = c(-Inf, -Inf), upper = c(0, 0),
        mean = c(mu_x, mu_y), sigma = Sigma_xy)

# Standard deviations and correlation
sig_x <- 0.10
sig_y <- 0.05
rho_xy <- 0
# Covariance between X and Y
sig_xy <- rho_xy * sig_x * sig_y
# Covariance matrix
Sigma_xy <- matrix(c(sig_x^2, sig_xy, sig_xy, sig_y^2), nrow = 2, ncol = 2)

# Means
mu_x <- 0.05
mu_y <- 0.025
# Simulate 100 observations
set.seed(123)  # for reproducibility
xy_vals <- rmvnorm(100, mean=c(mu_x, mu_y), sigma = Sigma_xy)
head(xy_vals)

# Create scatterplot
plot(xy_vals[, 1], xy_vals[, 2], pch = 16, cex = 2, col = "blue",
     main = "Bivariate normal: rho=0", xlab = "x", ylab = "y")
# Add lines
abline(h = mu_y, v = mu_x)
# Add line segments
segments(x0 = 0, y0 = -1e10, x1 = 0, y1 = 0, col="red")
segments(x0 = -1e10, y0 = 0, x1 = 0, y1 = 0, col="red")

# Compute joint probability
pmvnorm(lower = c(-Inf, -Inf), upper = c(0, 0),
        mean = c(mu_x, mu_y), sigma = Sigma_xy)

# Section 4 Simulating Time Series Data

set.seed(123);
# Simulate 250 observations from the described MA(1) model
ma1_sim <- 0.05 + arima.sim(model=list(ma=0.5), n=250, mean=0, sd=0.1)

set.seed(123);
# Simulate 250 observations from the described MA(1) model
ma1_sim <- arima.sim(model=list(ma=0.5), n=250, mean=0, sd=0.1) + 0.05;

# A line plot of the simulated observations
plot(ma1_sim, type='l', xlab='time', ylab='y(t)', main='MA(1) Process: mu=0.05, theta=0.5')
abline(h=0)

set.seed(123);
# Simulate 250 observations from the described MA(1) model
ma1_sim <- arima.sim(model=list(ma=0.5), n=250, mean=0, sd=0.1) + 0.05;
# Generate the theoretical ACF with upto lag 10
acf_ma1_model <- ARMAacf(ma=0.5, lag.max=10)

# Split plotting window in three rows
par(mfrow=c(3,1))

# First plot: The simulated observations
plot(ma1_sim, type="l",main="MA(1) Process: mu=0.05, theta=0.5",xlab="time",ylab="y(t)")
abline(h=0)

# Second plot: Theoretical ACF
plot(1:10, acf_ma1_model[2:11], type="h", col="blue",  ylab="ACF", main="theoretical ACF")

# Third plot: Sample ACF
# Assign to tmp the Sample ACF
tmp <- acf(ma1_sim, lag.max=10, main='Sample ACF')

# Reset graphical window to only one graph
par(mfrow=c(1,1))

set.seed(123);
# Simulate 250 observations from the described MA(1) model
ma1_sim <- arima.sim(model=list(ma=0.9), n=250, mean=0, sd=0.1) + 0.05;
# Generate the theoretical ACF with upto lag 10
acf_ma1_model <- ARMAacf(ma=0.9, lag.max=10)

# Split plotting window in three rows
par(mfrow=c(3,1))

# First plot: The simulated observations
plot(ma1_sim, type="l",main="MA(1) Process: mu=0.05, theta=0.9",xlab="time",ylab="y(t)")
abline(h=0)

# Second plot: Theoretical ACF
plot(1:10, acf_ma1_model[2:11], type="h", col="blue", main="theoretical ACF")

# Third plot: Sample ACF
tmp=acf(ma1_sim, lag.max=10, main="Sample ACF")

# Reset graphical window to only one graph
par(mfrow=c(1,1))

set.seed(123);
# Simulate 250 observations from the described AR(1) model
ar1_sim <- arima.sim(model=list(ar=0.5), n=250, mean=0, sd=0.1) + 0.05
# Generate the theoretical ACF with ten lags
acf_ar1_model <- ARMAacf(ar=0.5, lag.max=10)

# Split plotting window in three rows
par(mfrow=c(3,1))

# Generate the same three graphs as in the previous exercise
par(mfrow=c(3,1))

# First plot: The simulated observations
plot(ar1_sim, type="l", main="AR(1) Process: mu=0.05, phi=0.5",xlab="time",ylab="y(t)")
abline(h=0)

# Second plot: Theoretical AFC
plot(1:10, acf_ar1_model[2:11], type="h", col="blue", main="theoretical ACF")

# Third plot: Sample AFC
tmp <- acf(ar1_sim, lag.max=10., main='Sample ACF')

# Reset plotting window to default
par(mfrow=c(1,1));

# Section 5 - Analyzing Stock Returns

# Load relevant packages
library(PerformanceAnalytics);library(zoo);library(tseries);

# Get the monthly adjusted closing price data on VBLTX, FMAGX and SBUX from Yahoo! using the tseries function get.hist.quote(). Set the sample to Jan 1998 through Dec 2009.

# Get the adjusted closing prices from Yahoo!
VBLTX_prices <- get.hist.quote(instrument="vbltx", start="1998-01-01",end="2009-12-31", quote="AdjClose",provider="yahoo", origin="1970-01-01",compression="m", retclass="zoo", quiet=TRUE)

FMAGX_prices <- get.hist.quote(instrument="fmagx", start="1998-01-01",end="2009-12-31", quote="AdjClose",provider="yahoo", origin="1970-01-01",compression="m", retclass="zoo", quiet=TRUE)

SBUX_prices <- get.hist.quote(instrument="sbux", start="1998-01-01",end="2009-12-31", quote="AdjClose",provider="yahoo", origin="1970-01-01",compression="m", retclass="zoo", quiet=TRUE)

# Change the class of the time index to yearmon which is appropriate for monthly data
# index() and as.yearmon() are functions in the zoo package

index(VBLTX_prices) <- as.yearmon(index(VBLTX_prices))
index(FMAGX_prices) <- as.yearmon(index(FMAGX_prices))
index(SBUX_prices) <- as.yearmon(index(SBUX_prices))

# Inspect your data
start(VBLTX_prices)
end(VBLTX_prices)

# The variables VBLTX_prices, FMAGX_prices and SBUX_prices are preloaded in your workspace

# Create merged price data
all_prices = merge(VBLTX_prices, FMAGX_prices, SBUX_prices)
# Rename columns
colnames(all_prices) <- c("VBLTX", "FMAGX", "SBUX")

# Calculate cc returns as difference in log prices
all_returns = diff(log(all_prices))

# Look at the return data
start(all_returns)
end(all_returns)
colnames(all_returns)
head(all_returns)

# 'all_returns' is preloaded in your workspace.

# Plot returns after using the PerformanceAnalytics function chart.TimeSeries().
# This function creates a slightly nicer looking plot than plot.zoo()
chart.TimeSeries(all_returns, legend.loc="bottom", main=" ")

# The previous charts are a bit hard to read. The PerformanceAnalytics function
# chart.Bar makes it easier to compare the returns of different assets on the
# same plot
chart.Bar(all_returns, legend.loc="bottom", main=" ")

# Cumulative return plot - must use simple returns (!) and not cc returns for this
# Use PerformanceAnalytics function chart.CumReturns()
simple_returns <- diff(all_prices)/lag(all_prices, k=-1);
chart.CumReturns(simple_returns, wealth.index=TRUE, legend.loc='topleft', main='Future Value of $1 invested')

# Create matrix with returns
return_matrix <- coredata(all_returns);

# Generate four panel plots
par(mfrow=c(2,2))
hist(return_matrix[,"VBLTX"],main="VBLTX monthly returns",
     xlab="VBLTX", probability=T, col="slateblue1")
boxplot(return_matrix[,"VBLTX"],outchar=T, main="Boxplot", col="slateblue1")
plot(density(return_matrix[,"VBLTX"]),type="l", main="Smoothed density",
     xlab="monthly return", ylab="density estimate", col="slateblue1")
qqnorm(return_matrix[,"VBLTX"], col="slateblue1")
qqline(return_matrix[,"VBLTX"])
par(mfrow=c(1,1))

# Create matrix with returns
return_matrix <- coredata(all_returns);

# Show boxplot of three series on one plot
boxplot(return_matrix[,"VBLTX"], return_matrix[,"FMAGX"], return_matrix[,"SBUX"],
        names=colnames(return_matrix), col="slateblue1")

# Do the same thing using the PerformanceAnalytics function chart.Boxplot
chart.Boxplot(all_returns)

# Note: all_returns is preloaded in your workspace

# Create matrix with returns
return_matrix <- coredata(all_returns);

summary(return_matrix)

# Compute descriptive statistics by column using the base R function apply()
args(apply)
apply(return_matrix, 2, mean)
apply(return_matrix, 2, var)
apply(return_matrix, 2, sd)

apply(return_matrix, 2, skewness)
apply(return_matrix, 2, kurtosis)
# A nice PerformanceAnalytics function that computes all of the relevant descriptive statistics is table.Stats
table.Stats(all_returns)

# Note: return_matrix is preloaded in your workspace

# Annualized continuously compounded mean
12 * apply(return_matrix, 2, mean)
# Annualized simple mean
exp(12*apply(return_matrix, 2, mean)) - 1;

# Annualized standard deviation values
12^0.5 * apply(return_matrix, 2, sd)

# Note: return_matrix is preloaded in your workspace

# Display all possible pair-wise scatter plots
pairs(return_matrix, pch=16, col='slateblue1')

# Compute 3 x 3 covariance and correlation matrices
var(return_matrix)
cor(return_matrix)

# Section 6 Constant expected return model

VBLTX_prices <- get.hist.quote(instrument="vbltx", start="2005-09-01", end="2010-09-30", quote="AdjClose",provider="yahoo", origin="1970-01-01",compression="m", retclass="zoo", quiet = TRUE)
FMAGX_prices <- get.hist.quote(instrument="fmagx", start="2005-09-01", end="2010-09-30", quote="AdjClose",provider="yahoo", origin="1970-01-01",compression="m", retclass="zoo", quiet = TRUE)
SBUX_prices <- get.hist.quote(instrument="sbux", start="2005-09-01",end="2010-09-30", quote="AdjClose",provider="yahoo", origin="1970-01-01",compression="m", retclass="zoo", quiet = TRUE)

# Change the class of the time index to yearmon, which is appropriate for monthly data.
# index() and as.yearmon() are functions in the zoo package
index(VBLTX_prices) <- as.yearmon(index(VBLTX_prices))
index(FMAGX_prices) <- as.yearmon(index(FMAGX_prices))
index(SBUX_prices) <- as.yearmon(index(SBUX_prices))

# Create merged price data
all_prices <- merge(VBLTX_prices, FMAGX_prices, SBUX_prices)
# Rename columns
colnames(all_prices) <- c("VBLTX", "FMAGX", "SBUX")

# Calculate cc returns as difference in log prices
all_returns <- diff(log(all_prices))

# Create matrix with returns
return_matrix <- coredata(all_returns)

# The variable return_matrix is preloaded in your workspace

# Number of observations
n_obs <- nrow(return_matrix)

# Estimates of sigma2hat
sigma2hat_vals <- apply(return_matrix, 2, var)

# Standard Error of sigma2hat
se_sigma2hat <- sigma2hat_vals / sqrt(n_obs/2)

se_sigma2hat

# Calculate the correlation matrix
cor_matrix <- cor_matrix(return_matrix)

# Get the lower triangular part of that 'cor_matrix'
rhohat_vals <- c(cor_matrix[4],cor_matrix[7],cor_matrix[8])

# Set the names
names(rhohat_vals) <- c("VBLTX,FMAGX","VBLTX,SBUX","FMAGX,SBUX")

# Compute the estimated standard errors for correlation
se_rhohat <- (1 - rhohat_vals^2) / sqrt(nrow(return_matrix))

se_rhohat

# The "all_returns" zoo object is preloaded in your workspace
t.test(all_returns[,1])

# The "all_returns" zoo object is preloaded in your workspace

# Test the correlation between VBLTX,FMAGX
cor.test(all_returns[,1],all_returns[,2])

# The "all_returns" zoo object is preloaded in your workspace

# Test the normality of the returns of VBLTX
jarque.bera.test(all_returns[,1])

library("boot")
# Function for bootstrapping sample mean:
mean_boot <- function(x, idx) {
  ans <- mean(x[idx])
  ans
}
# Construct VBLTX_mean_boot:
VBLTX_mean_boot <- boot(return_matrix[, 'VBLTX'], statistic = mean_boot, 999)

# Print the class of VBLTX_mean_boot
class(VBLTX_mean_boot)

# Print VBLTX_mean_boot
VBLTX_mean_boot

# Plot bootstrap distribution and qq-plot against normal
plot(VBLTX_mean_boot)

# Section 7 - Intro to Portfolio Theory

# Load relevant packages
library("PerformanceAnalytics")
library("zoo")

# Load the data
ds_url <- "http://s3.amazonaws.com/assets.datacamp.com/course/compfin/lab8.RData"
load(url(ds_url))
# Explore the data set
head(returns_df)
tail(returns_df)

# The returns_df data is preloaded in your workspace

# Estimate the parameters: multivariate
mu_hat_annual <- apply(returns_df,2,mean)*12
sigma2_annual <- apply(returns_df, 2, var)*12
sigma_annual <- sqrt(sigma2_annual)
cov_mat_annual <- cov(returns_df)*12
cov_hat_annual <- cov(returns_df)[1,2]*12
rho_hat_annual <- cor(returns_df)[1,2]

# The annual estimates of the CER model parameters for Boeing and Microsoft
mu_boeing <- mu_hat_annual["rboeing"]
mu_msft <- mu_hat_annual["rmsft"]
sigma2_boeing <-  sigma2_annual["rboeing"]
sigma2_msft <- sigma2_annual["rmsft"]
sigma_boeing <- sigma_annual["rboeing"]
sigma_msft <- sigma_annual["rmsft"]
sigma_boeing_msft <- cov_hat_annual
rho_boeing_msft <- rho_hat_annual

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# The ratio Boeing stock vs Microsoft stock (adds up to 1)
boeing_weights <- seq(from=-1, to=2, by=0.1)
msft_weights <- seq(from=2, to=-1, by=-0.1)

# Portfolio parameters
mu_portfolio <-  mu_boeing * boeing_weights + mu_msft * msft_weights

sigma2_portfolio <- boeing_weights^2 * sigma2_boeing + msft_weights^2 * sigma2_msft + 2*boeing_weights*msft_weights*sigma_boeing_msft

sigma_portfolio <- sqrt(sigma2_portfolio)

# Plotting the different portfolios
plot(sigma_portfolio, mu_portfolio, type="b", pch=16, ylim=c(0, max(mu_portfolio)), xlim=c(0, max(sigma_portfolio)), xlab=expression(sigma[p]), ylab=expression(mu[p]),col=c(rep("green", 18), rep("red", 13)))
text(x=sigma_boeing, y=mu_boeing, labels="Boeing", pos=4)
text(x=sigma_msft, y=mu_msft, labels="Microsoft", pos=4)

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# Annual risk-free rate of 3% per year for the T-bill
t_bill_rate <- 0.03

# Ratio Boeing stocks
boeing_weights <- seq(from=-1, to=2, by=0.1)
t_bill_weights <- (1 - boeing_weights)
# Portfolio parameters
mu_portfolio_boeing_bill <- boeing_weights * mu_boeing + t_bill_weights * t_bill_rate

sigma_portfolio_boeing_bill <- boeing_weights * sigma_boeing

# Plot previous exercise
plot(sigma_portfolio, mu_portfolio, type="b", pch=16, ylim=c(0, max(mu_portfolio)), xlim=c(0, max(sigma_portfolio)), xlab=expression(sigma[p]), ylab=expression(mu[p]),col=c(rep("green", 18), rep("red", 13)))
text(x=sigma_boeing, y=mu_boeing, labels="Boeing", pos=4)
text(x=sigma_msft, y=mu_msft, labels="MSFT", pos=4)

# Portfolio Combination Boeing and T-bills
points(sigma_portfolio_boeing_bill, mu_portfolio_boeing_bill, col='blue', type='b')

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# Sharp ratio Boeing
sharp_ratio_boeing <- (mu_boeing - t_bill_rate) / sigma_boeing

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# The global minimum variance portfolio
global_min_var_portfolio <- globalMin.portfolio(mu_hat_annual, cov_mat_annual)

global_min_var_portfolio

# Summary of global_min_var_portfolio that takes into account the annual risk-free rate of 3% per year
summary(global_min_var_portfolio, risk.free=0.03)

# Portfolio weights Boeing and Microsoft
plot(global_min_var_portfolio)

# Plot previous exercises
plot(sigma_portfolio, mu_portfolio, type="b", pch=16, ylim=c(0, max(mu_portfolio)), xlim=c(0, max(sigma_portfolio)), xlab=expression(sigma[p]), ylab=expression(mu[p]),col=c(rep("green", 18), rep("red", 13)))
text(x=sigma_boeing, y=mu_boeing, labels="Boeing", pos=4)
text(x=sigma_msft, y=mu_msft, labels="MSFT", pos=4)

# Plot the position of the global minimum variance portfolio
text(x=global_min_var_portfolio$sd, y=global_min_var_portfolio$er, labels="Global min", pos=2)

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# The tangency portfolio
tangency_portfolio <-  tangency.portfolio(mu_hat_annual, cov_mat_annual, risk.free=0.03)

tangency_portfolio

# Summary of tangency_portfolio with annual risk free rate of 3%
summary(tangency_portfolio, risk.free=0.03)

# Portfolio weights Boeing and Microsoft
plot(tangency_portfolio)

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# Annual risk-free rate of 3% per year for the T-bill
t_bill_rate <- 0.03

# Set of tangency portfolio weights
tangency_weights <- seq(from=0, to=2, by=0.1)
t_bill_weights <- 1 - tangency_weights
# Portfolio parameters
mu_portfolio_tangency_bill <- tangency_weights * tangency_portfolio$er + t_bill_weights * t_bill_rate

sigma_portfolio_tangency_bill <- tangency_weights * tangency_portfolio$sd

# Plot previous exercises
plot(sigma_portfolio, mu_portfolio, type="b", pch=16, ylim=c(0, max(mu_portfolio)), xlim=c(0, max(sigma_portfolio)), xlab=expression(sigma[p]), ylab=expression(mu[p]),col=c(rep("green", 18), rep("red", 13)))
text(x=sigma_boeing, y=mu_boeing, labels="Boeing", pos=4)
text(x=sigma_msft, y=mu_msft, labels="MSFT", pos=4)

# Plot portfolio combinations of tangency portfolio and T-bills
text(x=tangency_portfolio$sd, y=tangency_portfolio$er, labels="Tangency", pos=2)
points(sigma_portfolio_tangency_bill, mu_portfolio_tangency_bill, col='blue', type='b', pch=16)

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# Define the portfolio ratio's
tangency_weight <- 0.3
t_bill_weight <- (1 - tangency_weight)

# Define the portfolio parameters
mu_portfolio_efficient <- tangency_weight * tangency_portfolio$er + t_bill_weight * 0.03

sd_portfolio_efficient <- tangency_weight * tangency_portfolio$sd

# Plot previous exercises
plot(sigma_portfolio, mu_portfolio, type="b", pch=16, ylim=c(0, max(mu_portfolio)), xlim=c(0, max(sigma_portfolio)), xlab=expression(sigma[p]), ylab=expression(mu[p]),col=c(rep("green", 18), rep("red", 13)))
text(x=sigma_boeing, y=mu_boeing, labels="Boeing", pos=4)
text(x=sigma_msft, y=mu_msft, labels="MSFT", pos=4)
text(x=tangency_portfolio$sd, y=tangency_portfolio$er, labels="Tangency", pos=2)
points(sigma_portfolio_tangency_bill, mu_portfolio_tangency_bill, type="b", col="blue", pch=16)

# Plot Efficient Portfolio with 30% Tangency

text(x=sd_portfolio_efficient, y=mu_portfolio_efficient, labels="Efficient Portfolio with 30% Tangency", pos=4, cex=0.75)
points(sd_portfolio_efficient, mu_portfolio_efficient, type='b', col='orange', pch=16, cex=2)

# All data and CER parameters are preloaded in your workspace.
# Type "ls()" in the console to see them.

# Calculate the weight of the tangency portfolio in the portfolio
tangency_weight  <- sigma_boeing / tangency_portfolio$sd

# Calculate the portfolio parameters
mu_portfolio_efficient <- t_bill_rate + tangency_weight * (tangency_portfolio$er - t_bill_rate)

sd_portfolio_efficient <- tangency_weight * tangency_portfolio$sd

# Plot previous exercises
plot(sigma_portfolio, mu_portfolio,bg="NA", type="b", pch=16, ylim=c(0, max(mu_portfolio)), xlim=c(0, max(sigma_portfolio)), xlab=expression(sigma[p]), ylab=expression(mu[p]),col=c(rep("green", 18), rep("red", 13)))
text(x=sigma_boeing, y=mu_boeing, labels="Boeing", pos=4)
text(x=sigma_msft, y=mu_msft, labels="MSFT", pos=4)
text(x=tangency_portfolio$sd, y=tangency_portfolio$er, labels="Tangency", pos=2)
points(sigma_portfolio_tangency_bill, mu_portfolio_tangency_bill, type="b", col="blue", pch=16)

# Plot Efficient Portfolio with the same risk as Boeing
points(sd_portfolio_efficient, mu_portfolio_efficient, type="p", col="orange", pch=16, cex=2)
text(x=sd_portfolio_efficient, y=mu_portfolio_efficient, labels="Efficient Portfolio with same risk as Boeing", pos=2, cex=0.75)

# Section 8 - Computing Efficient Potfolio

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# Load the relevant packages
library("zoo")

# Load the working environment
load(url("http://s3.amazonaws.com/assets.datacamp.com/course/compfin/lab9.RData"))

# Explore the data set
head(returns_df)
tail(returns_df)

# Timeplots with stocks on individual graphs
my.panel <- function(...) {
  lines(...)
  abline(h=0)
}
plot(returns_df, lwd=2, panel=my.panel, col="blue")

# Timeplots with stocks on same graph
plot(returns_df, plot.type = "single", main="Returns", col=1:4, lwd=2)
abline(h=0)
legend(x="bottomleft", legend=colnames(returns_df), col=1:4, lwd=2)

# All data is preloaded in your workspace.  Type 'ls()' in the console to see what has been loaded.

# Parameters CER model
mu_hat_month <- apply(returns_df, 2, mean)
mu_hat_month
sigma2_month <-apply(returns_df, 2, var)

sigma2_month
sigma_month <-sqrt(sigma2_month)

sigma_month
cov_mat_month <- var(returns_df)
cov_mat_month
cor_mat_month <- cor(returns_df)

cor_mat_month

# Pairwise scatterplots
pairs(coredata(returns_df), col='blue', pch=16)

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# Calculate the global minimum variance portfolio
global_min_var_portfolio = globalMin.portfolio(er=mu_hat_month, cov.mat=cov_mat_month, shorts=TRUE)

global_min_var_portfolio

# Plot the portfolio weights of our four stocks
plot(global_min_var_portfolio)

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# set restriction matrices
D_matrix <- 2* cov_mat_month
D_matrix
d_vector <- rep(0,4)
d_vector
A_matrix <- cbind(rep(1,4),diag(4))
A_matrix
b_vector <- c(1,rep(0,4))
b_vector

# use solve.QP to minimize portfolio variance
quad_prog <- solve.QP(D_matrix, d_vector, A_matrix, b_vector)

quad_prog

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# The global minimum variance portfolio
global_min_var_portfolio <- globalMin.portfolio(mu_hat_month, cov_mat_month, shorts=FALSE)

global_min_var_portfolio

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# highest average return
mu_target <- max(mu_hat_month)

# short sales allowed
efficient_porfolio_short <- efficient.portfolio(er = mu_hat_month, cov.mat = cov_mat_month, target = mu_target, shorts = TRUE)

efficient_porfolio_short
plot(efficient_porfolio_short)

# no short sales allowed
efficient_porfolio_no_short <- efficient.portfolio(er = mu_hat_month, cov.mat = cov_mat_month, target = mu_target, shorts = FALSE)

efficient_porfolio_no_short
plot(efficient_porfolio_no_short)

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# The efficient frontier of risky assets
efficient_frontier <- efficient.frontier(mu_hat_month, cov_mat_month, alpha.min=-1, alpha.max=1)
summary(efficient_frontier)

summary(efficient_frontier)

# The plot
plot(efficient_frontier, plot.assets=T, col= "blue", lwd = 2)

# All data and CER parameters are preloaded in your workspace.  Type 'ls()' in the console to see them.

# risk free rate
t_bill_rate <- 0.005

# Tangency portfolio short sales allowed
tangency_portfolio_short <- tangency.portfolio(er = mu_hat_month,
                                               cov.mat =cov_mat_month,
                                               risk.free = t_bill_rate,
                                               shorts = T)

summary(tangency_portfolio_short)
#plot
plot(tangency_portfolio_short)

# Tangency portfolio short sales not allowed
tangency_portfolio_no_short <- tangency_portfolio_no_short <- tangency.portfolio(er = mu_hat_month,
                                               cov.mat =cov_mat_month,
                                               risk.free = t_bill_rate,
                                               shorts = F)

summary(tangency_portfolio_no_short)
#plot
plot(tangency_portfolio_no_short)

Introduction to Computational Finance with R.r


# Master Thesis Project - Extreme Value Theory
# We use here QQ-plots to assess graphically the
# goodness of fit of our extreme distributions

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks then
# getting the LVMH and the Total data
df_plain <- loadStockData_plain(CHOICE)

# Fitting
	# Computing the 95 % - quantiles for each of the stocks
	quantiles <- c(quantile(df_plain[[1]],0.95), quantile(df_plain[[2]],0.95), quantile(df_plain[[3]],0.975),
					quantile(df_plain[[4]],0.95), quantile(df_plain[[5]],0.95))

	# Getting the data above the threshold
	data_bnp <- df_plain[[1]]
	data_bnp <- data_bnp[data_bnp > quantiles[1]]

	data_carrefour <- df_plain[[2]]
	data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]

	data_lvmh <- df_plain[[3]]
	data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]

	data_sanofi <- df_plain[[4]]
	data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]

	data_total <- df_plain[[5]]
	data_total <- data_total[data_total > quantiles[5]]

	# Fitting the data, and getting the corresponding location, scale and
	# shape parameters respectively, for each stock
	bnp_fit <- (gev.fit(data_bnp))
	carrefour_fit <- gev.fit(data_carrefour)
	lvmh_fit <- gev.fit(data_lvmh)
	sanofi_fit <- gev.fit(data_sanofi)
	total_fit <- gev.fit(data_total)

	# Saving the GEV parameters for later use
	params_bnp <- bnp_fit$mle
	params_carrefour <- carrefour_fit$mle
	params_lvmh <- lvmh_fit$mle
	params_sanofi <- sanofi_fit$mle
	params_total <- total_fit$mle

# Drawing the QQ-plots
N <- dim(df_plain)[1]
qVect <- (N + 1 - 1:N)/(N + 1)

	# Ordering the samples (increasing sort)
	data_bnp <- sort(df_plain[[1]])
	data_carrefour <- sort(df_plain[[2]])
	data_lvmh <- sort(df_plain[[3]])
	data_sanofi <- sort(df_plain[[4]])
	data_total <- sort(df_plain[[5]])

	# Getting the quantiles of the fitting distributions
	gev_bnp <- qgev(qVect,params_bnp[3],params_bnp[1],params_bnp[2])
	gev_carrefour <- qgev(qVect,params_carrefour[3],params_carrefour[1],params_carrefour[2])
	gev_lvmh <- qgev(qVect,params_lvmh[3],params_lvmh[1],params_lvmh[2])
	gev_sanofi <- qgev(qVect,params_sanofi[3],params_sanofi[1],params_sanofi[2])
	gev_total <- qgev(qVect,params_total[3],params_total[1],params_total[2])

	# Plotting for all the Data
	quartz()
    png(file = "QQ_BNP.png")
	plot(qVect,gev_bnp, main = "QQ-plot BNP", xlab ="", ylab = "")
	abline(lm(gev_bnp~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_Carrefour.png")
	plot(qVect, gev_carrefour, main = "QQ-plot Carrefour", xlab ="", ylab = "")
	abline(lm(gev_carrefour~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_LVMH.png")
	plot(qVect, gev_lvmh, main = "QQ-plot LVMH", xlab ="", ylab = "")
	abline(lm(gev_lvmh~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_Sanofi.png")
	plot(qVect, gev_sanofi, main = "QQ-plot Sanofi", xlab ="", ylab = "")
	abline(lm(gev_sanofi~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_Total.png")
	plot(qVect, gev_total, main = "QQ-plot Total", xlab ="", ylab = "")
	abline(lm(gev_total~qVect), col = "red")
	dev.off()
	graphics.off()

	# Plotting only for the high quantiles

		# Computing the 95 % - quantiles for each of the stocks
		quantiles <- c(quantile(df_plain[[1]],0.95), quantile(df_plain[[2]],0.95), quantile(df_plain[[3]],0.975),
					quantile(df_plain[[4]],0.95), quantile(df_plain[[5]],0.95))

		# Getting the data above the threshold
		data_bnp <- df_plain[[1]]
		data_bnp <- data_bnp[data_bnp > quantiles[1]]

		data_carrefour <- df_plain[[2]]
		data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]

		data_lvmh <- df_plain[[3]]
		data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]

		data_sanofi <- df_plain[[4]]
		data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]

		data_total <- df_plain[[5]]
		data_total <- data_total[data_total > quantiles[5]]

		# BNP
		N_BNP <- length(data_bnp)
		qVectBNP <- (N_BNP + 1 - 1:N_BNP)/(N_BNP + 1)

		data_bnp <- sort(data_bnp)
		gev_bnp <- qgev(qVectBNP,params_bnp[3],params_bnp[1],params_bnp[2])

		quartz()
    	png(file = "QQ_BNP2.png")
		plot(qVectBNP,gev_bnp, main = "QQ-plot BNP Paribas, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_bnp~qVectBNP), col = "red")
		dev.off()
		graphics.off()

		# Carrefour
		N_Carrefour <- length(data_carrefour)
		qVectCarrefour <- (N_Carrefour + 1 - 1:N_Carrefour)/(N_Carrefour + 1)

		data_carrefour <- sort(data_carrefour)
		gev_carrefour <- qgev(qVectCarrefour,params_carrefour[3],params_carrefour[1],params_carrefour[2])

		quartz()
    	png(file = "QQ_Carrefour2.png")
		plot(qVectCarrefour,gev_carrefour, main = "QQ-plot Carrefour, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_carrefour~qVectCarrefour), col = "red")
		dev.off()
		graphics.off()

		# LVMH
		N_LVMH <- length(data_lvmh)
		qVectLVMH <- (N_LVMH + 1 - 1:N_LVMH)/(N_LVMH + 1)

		data_lvmh <- sort(data_lvmh)
		gev_lvmh <- qgev(qVectLVMH,params_lvmh[3],params_lvmh[1],params_lvmh[2])

		quartz()
    	png(file = "QQ_LVMH2.png")
		plot(qVectLVMH,gev_lvmh, main = "QQ-plot LVMH, above \n97.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_lvmh~qVectLVMH), col = "red")
		dev.off()
		graphics.off()

		# Sanofi
		N_Sanofi <- length(data_sanofi)
		qVectSanofi <- (N_Sanofi + 1 - 1:N_Sanofi)/(N_Sanofi + 1)

		data_sanofi <- sort(data_sanofi)
		gev_sanofi <- qgev(qVectSanofi,params_sanofi[3],params_sanofi[1],params_sanofi[2])

		quartz()
    	png(file = "QQ_Sanofi2.png")
		plot(qVectSanofi,gev_sanofi, main = "QQ-plot Sanofi, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_sanofi~qVectSanofi), col = "red")
		dev.off()
		graphics.off()

		# Total
		N_Total <- length(data_total)
		qVectTotal <- (N_Total + 1 - 1:N_Total)/(N_Total + 1)

		data_total <- sort(data_total)
		gev_total <- qgev(qVectTotal,params_total[3],params_total[1],params_total[2])

		quartz()
    	png(file = "QQ_Total2.png")
		plot(qVectTotal,gev_total, main = "QQ-plot Total, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_total~qVectTotal), col = "red")
		dev.off()
		graphics.off()


z1 <- 1.5 + 3i
z2 <- 1.5 + 1.5i
print(z1 + z2)   #  3+4.5i
print(z1 - z2)   #  0+1.5i
print(z1 * z2)   #  -2.25+6.75i
print(z1 / z2)   #  1.5+0.5i
print(-z1)       #  -1.5-3i
print(Conj(z1))  #  1.5-3i
print(abs(z1))   #  3.354102
print(z1^z2)     #  -1.102483-0.383064i
print(exp(z1))   #  -4.436839+0.632456i
print(Re(z1))    #  1.5
print(Im(z1))    #  3


# trees.r
# MWL, Lecture 2
# Author(s): [Phil Snyder]

#install.packages("mlbench") # we can download new libraries right from the R terminal!
library(mlbench)
#help(package="mlbench")
data(BreastCancer)
#help(topic="BreastCancer", package="mlbench")
BreastCancer$Id <- NULL # Just get rid of this column. We won't need it.

# Let's fit a tree to our data
library(rpart) # rpart stands for "recursive partitioning"
basicTree <- rpart(Class ~ ., BreastCancer, method='class')
basicTree
plot(basicTree)
text(basicTree, cex=0.7) # cex controls text size
# Try leaving the "type='class'" parameter out of the next line.
# What do you think happens? Is this maybe a good thing to do in this application?
basicTreePredictions <- predict(basicTree, BreastCancer, type='class')
basicTreeResults <- table(basicTreePredictions == BreastCancer$Class) / length(basicTreePredictions)
basicTreeResults # TRUE: 0.9642, FALSE: 0.0357

# Why don't we try growing our tree so far down that every node contains only one class?
godTree <- rpart(Class ~ ., BreastCancer, method='class',
                 control=c(cp=-1, minsplit=2, minbucket=1))
plot(godTree)
text(godTree, cex=0.6)
godTreePredictions <- predict(godTree, BreastCancer, type='class')
godTreeResults <- table(godTreePredictions == BreastCancer$Class) / length(godTreePredictions)
godTreeResults # TRUE: 1, FALSE: 0

"
Amazing! We have a perfect predictor. All other machine learning algorithms cower in
sight of the glorious predictive power of godTree.

Of course, I'm kidding. What happens when a new data point comes along and, due to
uncertainty, randomness, etc., doesn't conform perfectly to the model we have constructed?
We are interested in how well our predictor performs on *unseen*, future data, so we must
'holdout' some data when we fit our model, then see how well the model performs on our
holdout data. This will give us a good estimate of how well our model *actually* performs
on unseen data.

In general, we partition our data into a 'train' set, which we fit our model to,
and a 'test' set, which we evaluate our model on. This is the most basic form of
cross-validation.
"

partition <- sample(nrow(BreastCancer), floor(0.7 * nrow(BreastCancer)))
trainData <- BreastCancer[partition,]
testData <- BreastCancer[-partition,] # can you guess what the '-' operator is doing here?

godTree <- rpart(Class ~ ., trainData, method='class',
                 control=c(cp=-1, minsplit=2, minbucket=1))
godTreeTrainPredictions <- predict(godTree, trainData, type='class')
godTreeTestPredictions <- predict(godTree, testData, type='class')

godTreeTrainResults <- table(godTreeTrainPredictions
                             == trainData$Class) / length(godTreeTrainPredictions)
godTreeTrainResults # Accuracy on train set TRUE: 1, FALSE: 0
godTreeTestResults <- table(godTreeTestPredictions
                               == testData$Class) / length(godTreeTestPredictions)
godTreeTestResults # Accuracy on test set (approx.) TRUE: 0.9523, FALSE: 0.0476

# Still pretty good, but this is a relatively easy classification problem.
# When we have significantly higher accuracy on the training data as opposed to the
# test data, this is called 'overfitting'. We fit our model to the train data *too* well.

"
We now have a model, and a way to accurately test the predictive power of our model by
partitioning our data into a training set and a test set. The question remains, what
parameters should our model have, and what values should they take on?
In the case of linear regression, our parameters are
the slope and intercept of the regression line. In the case of decision trees, our
parameters should control how far down we grow our tree. There are a few ways to do this,
but in the rpart function we may control the growth of our tree by varying the
complexity parameter (cp), the minimum # of data points in a node needed to consider a
split (minsplit), the minimum amount of data points that are allowed to sit in a
leaf (minbucket), or the maxdepth of the tree (maxdepth).
You may look up what exactly a 'complexity parameter' is, but all
you really need to know is that the lower your cp, the more your tree will grow (subject
to the minsplit, minbucket, maxdepth constraints). Setting cp = -1 (like in the
godTree example) will tell rpart to keep splitting until it cannot split anymore
(again, subject to the minsplit, minbucket, maxdepth constraints).

In general, finding optimal parameters is an optimization problem. Usually a numerical
optimization problem (i.e., there is no closed form optimal solution). More on this
in later lectures.

We will use an algorithm called 'grid search' to find an optimal parameter set.
Grid search is just a fancy name for trying-every-reasonable-combination-of-parameters. Since
cp, minsplit, minbucket, and maxdepth are each different ways of measuring the same thing,
we can effectively tell rpart to ignore the minsplit, minbucket, and maxdepth constraints and only
consider the cp for a 'good enough' optimization of our parameters.
"

# R is a functional language, so it can be frustratingly difficult to do something as
# simple as add an element to the end of an array (vector). We use the foreach library
# to streamline the process. We will also be using a new dataset from a new library
# ElemStatLearn, 'Spam', which is more difficult to classify and illustrates
# the concept better.
#install.packages(c("foreach", "ElemStatLearn"))
library(foreach)
library(ElemStatLearn)
data(spam)
#help(topic="spam", package="ElemStatLearn")

partition <- sample(nrow(spam), floor(0.7 * nrow(spam)))
trainData <- spam[partition,]
testData <- spam[-partition,]

cpValues <- c(0.5, 0.1, 0.05, 0.01, 0.005, 0.001, 0.0005, 0.0001)
treesLoss <- foreach(val = cpValues, .combine='c') %do% {
    ctrl <- rpart.control(cp=val, minsplit=2, minbucket=1) # maxdepth defaults to 30
    tree <- rpart(spam ~ ., trainData, method='class', control=ctrl)
    treePredictions <- predict(tree, testData, type='class')
    # proportion incorrect
    loss <- table(treePredictions == testData$spam)["FALSE"][[1]] / length(treePredictions)
    return(loss)
}
results <- data.frame(cp = cpValues, loss = treesLoss)
# x log scale and reversed
plot(results, log='x', xlim=c(max(results$cp), min(results$cp)), type='o')

"
Great. Around 1e-3 seems optimal. BUT, we have made yet another naive mistake.
Decision trees are *high variance* predictors. This means that the decision trees
we generate are highly dependent on the specific data points in our training dataset.
If we had sampled a different training set, it's possible we may have had a different
optimal value. To counterbalance this variability, we use k-fold cross-validation.
Wikipedia has a nice paragraph on k-fold CV:
https://en.wikipedia.org/wiki/Cross-validation_(statistics)#k-fold_cross-validation

In the above article 'validation set' is similar to a test set. We will discuss
validation sets and why we need them later. K-fold CV reduces variability (in
the traditional statistical sense of the word) by averaging our results.

This issue alludes to something you will need to know about (eventually), but probably
won't be covered this lecture. That is the Bias-Variance Tradeoff
https://en.wikipedia.org/wiki/Bias%E2%80%93variance_tradeoff
"

# do 10-fold CV
trainData <- trainData[sample(nrow(spam)),] # randomly permute the rows in our data frame
partitionSize <- floor(nrow(trainData) / 10)
treesLoss <- foreach(val = cpValues, .combine='c') %do% {
    ctrl <- rpart.control(cp=val, minsplit=2, minbucket=1)
    summedResults <- 0
    for (i in seq(1, nrow(trainData) - partitionSize, partitionSize)) {
        validationSetIndices <- i:(i + partitionSize - 1) # seq from i to (partitionSize-1)
        validationData <- trainData[validationSetIndices,]
        nonValidationData <- trainData[-validationSetIndices,]
        tree <- rpart(spam ~ ., nonValidationData, method='class', control=ctrl)
        treePredictions <- predict(tree, validationData, type='class')
        loss <- table(treePredictions == validationData$spam)["FALSE"][[1]] / length(treePredictions)
        summedResults <- summedResults + loss
    }
    averagedResults <- summedResults / 10
    return(averagedResults)
}
cvResults <- data.frame(cp = cpValues, loss = treesLoss)
plot(cvResults, log='x', xlim=c(max(results$cp), min(results$cp)))

# Now we have a nice, smooth curve, and the optimal cp value will either be 1e-3 or 5e-4 depending
# on how easy to classify your test set happens to be (Sometimes we repeat the k-fold CV process
# itself multiple times to eliminate this 'lucky draw' element). If you're bored you can modify
# the code and plot the standard error bars on top of each data point. Another way of choosing the
# optimal parameter is to choose the value that gives the loosest fit to the training data yet is
# still within one standard error of the "best" value.

# So how good is a decision tree with an optimal parameter value?
bestTree <- rpart(spam ~ ., trainData, method='class', control=c(cp=1e-3, minsplit=2, minbucket=1))
bestTreePredictions <- predict(bestTree, testData, type='class')
bestTreeResults <- table(bestTreePredictions == testData$spam) / length(bestTreePredictions)
bestTreeResults # (approx.) TRUE: 0.9225, FALSE: 0.07748

"
Now that we've made it this far, I can tell you a secret: Decision Trees are relatively crude
predictors. Yet we are still able to correctly identify 92% of emails as either spam or
not spam using a singe decision tree and the 'bag-of-words' model (this is how the variables
in our spam data were generated, see [ESL 9.2.5]). To create even more powerful tree-based
predictors, we must learn about ensembles... (see treeEnsembles.r)
"


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

getLikelihood <- function(point, expectation, covMatrix) {
  pointMinusMean <- t(as.matrix(point - expectation))

  covMatrixInverse <- solve(covMatrix)
  nom <- exp(-(pointMinusMean %*% covMatrixInverse %*% t(pointMinusMean)) / 2)
  denom <- sqrt((2 * pi) ^ nrow(covMatrix) * det(covMatrix))

  return(nom / denom)
}

getPlugInProbability <- function(point, lambda, prior, expectations, covMatrix) {
  likelihood <- getLikelihood(point, expectations, covMatrix)

  probability <- lambda * prior * likelihood;

  return (probability)
}

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

  output$p1 <- renderPlotly({
    lambdas <- c(input$la1, input$la2)
    prior <- c(input$ratio / 100, 1 - (input$ratio / 100))
    expectations <- list(
      c(input$mu11, input$mu12),
      c(input$mu21, input$mu22)
    )

    covMatrix <- list(
      matrix(c(input$E11, input$E12, input$E13, input$E14), nrow = 2, ncol = 2, byrow = TRUE),
      matrix(c(input$E21, input$E22, input$E23, input$E24), nrow = 2, ncol = 2, byrow = TRUE)
    )

    center <- c((input$mu11 + input$mu21) / 2, (input$mu12 + input$mu22) / 2)

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

    for (y in ys) {
      curr <- c()
      for (x in xs) {
        arg <- c(x, y)
        value <- (getPlugInProbability(c(x, y), lambdas[1], prior[1], expectations[[1]], covMatrix[[1]]) - getPlugInProbability(c(x, y), lambdas[2], prior[2], expectations[[2]], covMatrix[[2]]))

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

    fig <- plot_ly(
      type = 'contour',
      x = ~xs,
      y = ~ys,
      z = ~z)
    fig
  })

  output$p2 <- renderPlotly({
    lambdas <- c(input$la1, input$la2)
    prior <- c(input$ratio / 100, 1 - (input$ratio / 100))
    expectations <- list(
      c(input$mu11, input$mu12),
      c(input$mu21, input$mu22)
    )

    covMatrix <- list(
      matrix(c(input$E11, input$E12, input$E13, input$E14), nrow = 2, ncol = 2, byrow = TRUE),
      matrix(c(input$E21, input$E22, input$E23, input$E24), nrow = 2, ncol = 2, byrow = TRUE)
    )

    center <- c((input$mu11 + input$mu21) / 2, (input$mu12 + input$mu22) / 2)

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

    for (y in ys) {
      curr <- c()
      for (x in xs) {
        arg <- c(x, y)
        value <- (getPlugInProbability(c(x, y), lambdas[1], prior[1], expectations[[1]], covMatrix[[1]]) - getPlugInProbability(c(x, y), lambdas[2], prior[2], expectations[[2]], covMatrix[[2]]))

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

    fig <- plot_ly(
      type = 'surface',
      x = ~xs,
      y = ~ys,
      z = ~z)
    fig
  })
}


write(round(pnorm(40, 30, 4), 3), stdout())
write(round(1 - pnorm(21, 30, 4), 3), stdout())
write(round(pnorm(35, 30, 4) - pnorm(30, 30, 4), 3), stdout())


# x, y: the x and y coordinates of the hull points
# n: the number of points in the curve.
bezierCurve <- function(x, y, n=10)
	{
	outx <- NULL
	outy <- NULL

	i <- 1
	for (t in seq(0, 1, length.out=n))
		{
		b <- bez(x, y, t)
		outx[i] <- b$x
		outy[i] <- b$y

		i <- i+1
		}

	return (list(x=outx, y=outy))
	}

bez <- function(x, y, t)
	{
	outx <- 0
	outy <- 0
	n <- length(x)-1
	for (i in 0:n)
		{
		outx <- outx + choose(n, i)*((1-t)^(n-i))*t^i*x[i+1]
		outy <- outy + choose(n, i)*((1-t)^(n-i))*t^i*y[i+1]
		}

	return (list(x=outx, y=outy))
	}

# Example usage
x <- c(4,6,4,5,6,7)
y <- 1:6
plot(x, y, "o", pch=20)
points(bezierCurve(x,y,20), type="l", col="red")


#!/usr/bin/env Rscript

removeOutliers <- function(dataset) {
    datasetRemoved = list()

    lsrl = lm(dataset$y ~ dataset$x)
    cookd = cooks.distance(lsrl)

    datasetRemoved$x = dataset$x[cookd < (2/length(dataset$x))]
    datasetRemoved$y = dataset$y[cookd < (2/length(dataset$x))]
    return(datasetRemoved)
}

removeDuplicates <- function(dataset) {
    datasetRemoved = list()
    datasetRemoved$x = dataset$x[c(TRUE, diff(dataset$x) != 0)]
    datasetRemoved$y = dataset$y[c(TRUE, diff(dataset$x) != 0)]
    return(datasetRemoved)
}

# Datasets
dataA = list()
dataB = list()
dataAB = list()

# Read Files
# NOTE: we can't just readline() b/c running this script w/ Rscript is "non-interactive"...
cat("First File to Read: ")
fileA = readLines(file("stdin"), 1)
dataAfile = read.csv(paste("data/", fileA, ".csv", sep=""), header = TRUE)
cat("Second File to Read: ")
fileB = readLines(file("stdin"), 1)
dataBfile = read.csv(paste("data/", fileB, ".csv", sep=""), header = TRUE)
closeAllConnections()

# Assign to Datasets
dataA$x = dataAfile$TOTAL.AMP
dataA$y = dataAfile$VOLT
dataB$x = dataBfile$TOTAL.AMP
dataB$y = dataBfile$VOLT

# Filter Outliers (optional)
dataA = removeOutliers(dataA)
dataB = removeOutliers(dataB)

# Remove Duplicate Current Readings (optional)
dataA = removeDuplicates(dataA)
dataB = removeDuplicates(dataB)

# Find combined data set
dataAB$x = c(dataA$x, dataB$x)
dataAB$y = c(dataA$y, dataB$y)

# TODO correlation coefficient for each dataset?
# TODO display LSRL for each set?
# TODO keep original dataset, plot outliers

# Plot Datasets (optional)
x11()
plot(dataA$x, dataA$y, main="Motor Comparison, Amps vs. Volts", xlab="Amps", ylab="Volts", col="blue")
points(dataB$x, dataB$y, col="green")
abline(lm(dataA$y ~ dataA$x), col="blue")
abline(lm(dataB$y ~ dataB$x), col="green")
abline(lm(dataAB$y ~ dataAB$x), col="black")

# TODO avoid recomputing Linear Models, store in dataA$lm? Also store dataA$residuals? (Or just dataA$lm$residuals)

# Find SSRs
dataA$ssr = sum(resid(lm(dataA$y ~ dataA$x)) ^ 2)
dataB$ssr = sum(resid(lm(dataB$y ~ dataB$x)) ^ 2)
dataAB$ssr = sum(resid(lm(dataAB$y ~ dataAB$x)) ^ 2)

# Do Chow Test to find F statistic
k = 2
df = length(dataA$x) + length(dataB$x) - (2 * k)

fstat = ((dataAB$ssr - (dataA$ssr + dataB$ssr)) / k) / ((dataA$ssr + dataB$ssr) / (df))

# Print Info
cat("SSR A:\t", dataA$ssr, "\n")
cat("SSR B:\t", dataB$ssr, "\n")
cat("SSR AB:\t", dataAB$ssr, "\n")
cat("k:\t", k, "\n")
cat("df:\t", df, "\n")
cat("F Stat:\t", fstat, "\n")
cat("P-Val:\t", pf(fstat, k, df, lower.tail=FALSE), "\n")

# Basically a bunch of hacks
cat("Press [Enter] to Quit...")
enter = readLines(file("stdin"), 1)
closeAllConnections()


# Example 1 p. 389 Figure 10.3
library(rsm)
rotd <- ccd(3, n0 = c(4,2), alpha = "rotatable", randomize = FALSE)
rotdm <- rotd[ , 3:5]
library(Vdgraph)
Vdgraph(rotdm)

# Figure 10.5 p. 392
# create design with rsm
library(rsm)
bbd3 <- bbd(3,randomize=FALSE,n0=3)
library(Vdgraph)
Vdgraph(bbd3[ , 3:5])

# Figure 10.6 p. 392
library(Vdgraph)
FDSPlot(bbd3[ , 3:5], mod=2)

# Figure 10.8 p. 394
library(Vdgraph)
data(SCDH2)
Vdgraph(SCDH2)

# Figure 10.9 p. 395
# first get the ccd2
library(rsm)
ccd2<- ccd(2, n0 = c(3,2), alpha = "rotatable", randomize = FALSE)[ ,3:4]
Compare2FDS(SCDH2,ccd2,"SCD","CCD",mod=2)

# Figure 10.10 p. 396
library(Vdgraph)
data(D310)
Vdgraph(D310)

# Example 2 p. 396-397
library(rsm)
ccd.pick(k=3)

# Example 3 p. 397
library(rsm)
ccd.up<-ccd(y~x1+x2+x3,n0=c(4,2),alpha="rotatable",randomize=FALSE)
Vdgraph(ccd.up[ , 3:5])

# Example 4 p. 398
ccd.up<-ccd(y~x1+x2+x3,n0=c(4,2),alpha="rotatable",
            coding=list(x1~(Temp-150)/10,x2~(Press-50)/5, x3~(Rate-4/1)),randomize=FALSE)
head(ccd.up)

# Example 5 p. 398
library(rsm)
Treb<-bbd(y ~ x1 + x2 + x3, randomize = FALSE, n0 = 3,
          coding=list(x1~(A-6)/2, x2~(B-15)/5, x3~(C-2.5)/.5))
head(Treb)

# Example 6 p. 399
library(Vdgraph)
data(D310)
D310

# Example 7 p. 400
des <- transform(D310, Temp=10*x1+150, Press=5*x2+50, Rate = x3 + 4)
des[sample(1:10) ,4:6]

# Example 8 p. 401
library(daewr)
data(qsar)

# Example 9 p.403 and Figure 10.13 p. 404
library(AlgDesign)
desgn1<-optFederov(~quad(.),data=qsar,nTrials=15,center=TRUE,
                   criterion="D",nRepeats=40)
desgn2<-optFederov(~quad(.),data=qsar,nTrials=15,center=TRUE,
                   criterion="I",nRepeats=40)
Compare2FDS(desgn1$design, desgn2$design, "D-optimal", "I-optimal", mod=2)

# Example 10 p. 404
desgn2$design

# Example 11 p. 406
k1 <- .15; k2 <- .72; gamma0 <- 2.65; t0 <- 0.41
x <- c(seq(1:25))
dfdk1 <- c(rep(0, 25))
dfdk2 <- c(rep(0, 25))
dfdgamma0 <- c(rep(0, 25))
dfdt0 <- c(rep(0, 25))
for (i in 1:25) {
  dfdk1[i] <- -1 * gamma0 * exp(-k1 * (x[i] - t0)) *(x[i] - t0)
  dfdk2[i] <-gamma0 * exp(-k2 * (x[i] - t0)) * (x[i] - t0)
  dfdgamma0[i] <- exp(-k1 * (x[i] - t0)) - exp( -k2 *                                                  ( x[i] - t0))
  dfdt0[i] <- gamma0 * exp(-k1 * (x[i] - t0)) * k1 - gamma0 *
    exp(-k2 * (x[i] - t0)) * k2; }
grid <- data.frame(x, dfdk1, dfdk2, dfdgamma0, dfdt0)

# Example 12 p. 407
library(AlgDesign)
desgn2<-optFederov(~ +dfdk1+dfdk2+dfdgamma0+dfdt0,data=grid,nTrials=8,center=TRUE, criterion="D",nRepeats=20)
desgn2

# This additional code illustrates fitting a model to simulated data from the design
design<-desgn2$design
k1 <- .15; k2 <- .72; gamma0 <- 2.65; t0 <- 0.41
# this is the simulated response
design$y<-gamma0*(exp(-k1*(design$x-t0))-exp(-k2*(design$x-t0)))+rnorm(8,0,.05)
# this is the code to fit the model
mod.nls<-nls(y~gamma0*(exp(-k1*(x-t0))-exp(-k2*(x-t0))),data=design,
             start=list(gamma0=2.65,k1=.15,k2=.72,t0=0.41))
summary(mod.nls)

# Example 13 p. 408
library(daewr)
data(cement)
head(cement)

# Example 14 p. 408
library(rsm)
grout.lin <- rsm(y ~ SO(x1, x2, x3),data = cement, subset = (Block == 1))
anova(grout.lin)

# Example 15 p. 409
library(daewr)
data(Treb)
head(Treb)

# Example 16 p. 410
library(rsm)
treb.quad <- rsm(y ~ SO(x1, x2, x3), data = Treb)
summary(treb.quad)

# Example 17 p. 411
library(daewr)
data(cement)
grout.quad <- rsm(y ~ Block + SO(x1,x2,x3), data = cement)
summary(grout.quad)

# Example 18 p. 412 - 413
library(daewr)
data(Tet)
mod.nln1 <-nls(Conc ~ gamma0 * (exp( -k1 * (Time - t0)) - exp( -k2 * (Time - t0))),
               data = Tet, start = list(gamma0 = 10, k1 = .12, k2 = .5, t0 = .5))
summary(mod.nln1)

# Example 20 p. 413-414 Figure 10.15
library(daewr)
data(Treb)
library(rsm)
treb.quad <- rsm(y ~ SO(x1, x2, x3), data = Treb)
par (mfrow=c(2,2))
contour(treb.quad, ~ x1+x2+x3 )
par (mfrow=c(1,1))

# Example 21 p. 414-415 Figure 10.16
par (mfrow=c(2,2))
persp(treb.quad, ~ x1+x2+x3, zlab="Distance", contours=list(z="bottom") )
par (mfrow=c(1,1))

# Example 22 p. 415-416, Figure 10.17
par (mfrow=c(1,2))
contour(treb.quad, x1~x3, at=list(x2=1))
persp(treb.quad, x1~x3, at=list(x2=1),zlab="Distance", contours=list(z="bottom"))
par (mfrow=c(1,1))

# Example 23 p. 418
# slice at stationary point instead of coding value
par (mfrow=c(2,2))
contour(treb.quad, ~ x1+x2+x3, at = xs(treb.quad) )
par (mfrow=c(1,1))

# Example 24 p. 419
ridge<-steepest(treb.quad, dist=seq(0, 1.412, by=.1), descent=FALSE)
ridge

# Figure 10.20 p. 420
par (mfrow=c(2,1))
leg.txt<-c("A","B","C")
plot(ridge$dist,ridge$yhat, type="l",xlab="radius",ylab="Max. Predicted")
plot(ridge$dist,seq(1,22,by=1.5), type="n", xlab="radius", ylab="Factors")
lines(ridge$dist,ridge$A,lty=1)
lines(ridge$dist,ridge$B,lty=2)
lines(ridge$dist,ridge$C,lty=3)
legend(1.2,19,leg.txt,lty=c(1,2,3))
par (mfrow=c(1,1))

#Example 25 p. 421
start<-c(12.5,400)
prod <- function(x) {
  time <- x[1]
  Temp <- x[2]
  k1 <- .523 * exp(-9847 * ((1/Temp - 1/400 )))
  k2 <- .2 * exp(-12327 * ((1/Temp - 1/400 )))
  f <- 132 * (exp(-k1 * time) - exp( -k2 *time)) * k1/(k1-k2)
}
ui <- matrix(c(1, -1, 0, 0, 0, 0, 1, -1), 4, 2)
ci <- c(0, -25, 375, -425)
constrOptim(start, prod, NULL, ui, ci)

# Figure 10.21 p. 422
par (mfrow=c(1,1))
time<-seq(0,25,length=52)
Temp<-seq(375,425,length=52)
p<-matrix(rep(0,2704),nrow=52)
for (i in 1:52)    {
  for (j in 1:52) {
    k1<-.523*exp(-9847*((1/Temp[j]-1/400)))
    k2<-.2*exp(-12327*((1/Temp[j]-1/400)))
    p[i,j]<--132*(exp(-k1*time[i])-exp(-k2*time[i]))*k1/(k1-k2)
  }
}
contour(time,Temp,p,xlab="Time, hrs",ylab="Temp, Deg K")

# Example 26 p. 424
# maximize tsr for cost <=10 cents
# Note: since no R packages allow nonlinear equality constraints
# I included this constraint in the tsr function by adding the
# 100*maxumum of (cost -10) and zero
start<-c(100,.6,40)
tsrcost<-function(x) {
  Temp<-x[1]
  Ratio<-x[2]
  AOPPM<-x[3]
  tsrcost<- -(-226+3.375*Temp+86.5*Ratio+2.646*AOPPM-.0128*Temp*Temp-17.5*Ratio*Ratio-.0121*AOPPM*AOPPM
              +           -.3857*Ratio*Temp-.0126*AOPPM*Temp-.0333*AOPPM*Ratio)+
    +           100*max((.8313+1.27*Ratio+.37*Ratio*AOPPM-10),0)
}
ui<-matrix(c(1,-1,0,0,0,0,0,0,1,-1,0,0,0,0,0,0,1,-1),6,3)
ci<-c(70,-140,.5,-1.5,5,-65)
constrOptim(start,tsrcost,NULL,ui,ci)
# note this minimizes tsrcost, subject to ui%*%x-ci>=0

# Example 27 p. 426
x<-c(0,0,0)
saPred<-function(x) 125.4106 -8.1233*x[1]+17.0266*x[2]+.4277*x[3]+2.4184*x[1]*x[2]
-8.4376*x[1]*x[3]+9.0134*x[2]*x[3]+33.88054*x[1]^2+14.81976*x[2]^2+13.07001*x[3]^2

pvPred<-function(x) .661354-.1963*x[1]-.02016*x[2]-.00291*x[3]+.02399*x[1]*x[2]
+.010327*x[1]*x[3]-.0374*x[2]*x[3]+.15126*x[1]^2+.118423*x[2]^2+.0679*x[3]^2

dpPred<-function(x) 39.35608+3.19547*x[1]+.21729*x[2]-1.46979*x[3]+.58873*x[1]*x[2]
-.62136*x[1]*x[3]-1.53234*x[2]*x[3]+.41413*x[1]^2-2.39408*x[2]^2-2.36399*x[3]^2

library(desirability)
saD<-dMax(100, 217)
pvD<-dMax(0.6, 1.3)
dpD<-dTarget(38, 40, 42)
overallD<-dOverall(saD, pvD, dpD)

# Code on web page referred to on p. 426
rsmOpt <- function(x, dObject, space = "square")
{
  sa <- saPred(x)
  pv <- pvPred(x)
  dp <- dpPred(x)

  out <- predict(dObject, data.frame(sa = sa, pv = pv, dp = dp))

  if(space == "circular")
  {
    if(sqrt(sum(x^2)) > 1.0) out <- 0
  } else if(space == "square") if(any(abs(x) > 1.0)) out <- 0
  out
}

searchGrid <- expand.grid(Mixtime = seq(-1.0, 1.0, length = 5),
                          filTtime = seq(-1.0, 1.0, length = 5),
                          PackMth = seq(-1.0, 1.0, length = 5))
for(i in 1:dim(searchGrid)[1])
{
  tmp <- optim(as.vector(searchGrid[i,]),
               rsmOpt,
               dObject = overallD,
               space = "square",
               control = list(fnscale = -1))
  if(i == 1)
  {
    best <- tmp
  } else {
    if(tmp$value > best$value) best <- tmp
  }
}

predOutcomes <-c(saPred(c(-0.2924993,-1,-1)), pvPred(c(-0.2924993,-1,-1)), dpPred(c(-0.2924993,-1,-1)))
print(predOutcomes)

# Example 28  p. 427
#Create Blocked bbd
library(rsm)
# four-factor design
bbd(4,n0=1,randomize=FALSE)
# five-factor design
bbd(5,n0=3,randomize=FALSE)
#Create Blocked CCD designs
# two-factor design
ccd(2,n0=c(3,3),alpha="orthogonal",randomize=FALSE)
# three-factor design
ccd(3, n0=2,alpha="orthogonal",randomize=FALSE, blocks=Block~( x1*x2*x3))
# four-factor design
ccd(4, n0=2, alpha="orthogonal",randomize=FALSE, blocks=Block~(x1*x2*x3*x4))
# five-factor design
ccd(4, generators=(x5~x1*x2*x3*x4), n0=c(6,1),alpha="orthogonal",randomize=FALSE)

# Example 29 p. 428
library(AlgDesign)
fact<-gen.factorial(levels=2,nVars=3)
fact<-rbind(fact,fact)
center<-data.frame(matrix(rep(c(0,0,0),6),ncol=3))
star<-data.frame(rbind(diag(3),-diag(3)))
cand<-rbind(fact,center,star)
bdesign<-optBlock(~quad(),cand,blocksizes=c(4,4,4,4,4,4,4),criterion="Dpc",nRepeats=1000)
bdesign

# Example 30 p. 429
library(daewr)
data(qsar)
library(AlgDesign)
desgn1<-optBlock(~quad(.),qsar,blocksizes=c(4,4,4,4,4),criterion="Dpc",nRepeats=1000)
desgn1

# Example 31 p. 430
library(daewr)
data(pastry)
class(pastry$Block)
library(rsm)
blkrsm<-rsm(y~Block+SO(x1,x2,x3), data=pastry)
summary(blkrsm)

#Example 32 p. 432
# REML analysis using lmer
library(daewr)
data(cake)
library(lme4)
mmod<-lmer(y~x1+x2+x1:x2+x1sq+x2sq+(1|Ovenrun),data=cake)
summary(mmod)
# Least Squares Analysis using rsm
library(rsm)
mmodls<-rsm(y ~ SO(x1,x2), data=cake)
summary(mmodls)

# Example 33 EESPRS page 434
library("AlgDesign")
# uses gen.factorial function from AlgDesign to create Factorial portion of the design
sp<-gen.factorial(2,2,varNames=c("P","Q"))
Wp<-gen.factorial(2,2,varNames=c("A","B"))
A<-Wp$A
#stacks whole plots
wp<-c(rep((1:4),each=4))
A<-c(rep((Wp$A),each=4))
B<-c(rep((Wp$B),each=4))
Fac<-cbind(wp,A,B,rbind(sp,sp,sp,sp))
# Subplot Axial Portion
A<-c(rep(0,4))
B<-c(rep(0,4))
P<-c(-2,2,0,0)
Q<-c(0,0,-2,2)
wp<-c(rep(5,4))
spa<-cbind(wp,A,B,P,Q)
# Whole Plot Axial Portion
wp<-c(rep((6:9),each=4))
A<-c(rep(c(-2,2,0,0),each=4))
B<-c(rep(c(0,0,-2,2),each=4))
P<-c(rep(0,16))
Q<-c(rep(0,16))
wpa<-cbind(wp,A,B,P,Q)
# center points
wp<-c(rep((10:11),each=4))
A<-c(rep(0,8))
B<-c(rep(0,8))
C<-c(rep(0,8))
D<-c(rep(0,8))
wpc<-cbind(wp,A,B,P,Q)
SPDs<-rbind(Fac,spa,wpa,wpc)
############################################

# Example 34 p. 438
library(daewr)
EEw1s2( )
EE15R5WP<-EEw1s2('EE15R5WP')
EE15R5WP
# extra  example fitting model with this design
# sample data
y<-c(-0.714811191,-0.829505189,-0.848985975,-0.110751257,1.4710031138,-0.611644758,
     -1.087524003,0.8956219826,-0.130413701,-0.735548889,-0.129036864,-0.534510763,
     -0.004106583,0.204772326,-0.302557987)
EE15R5WP<-data.frame(EE15R5WP,y)
colnames(EE15R5WP)<-c('WP','A','P','Q','y')
# fit the model with \texttt{lmer} function in the \texttt{lme4} package
modre<-lmer(y~A+I(A^2)+(1|WP)+P+I(P^2)+Q+I(Q^2)+A:P+
              A:Q+P:Q,data=EE15R5WP)
summary(modre)
# fit the model with the \texttt{rsm} function in the \texttt{rsm} package
modls<-rsm(y~SO(A,P,Q),data=EE15R5WP)
summary(modls)


# From JoAnn Alvarez

require(rms)
set.seed(1)
age <- rnorm(200,40,12)
sex <- factor(sample(c('female','male'),200,TRUE))
logit <- (sex=='male') + (age-40)/5
y <- ifelse(runif(200) <= plogis(logit), 1, 0)
f <- lrm(y ~ pol(age,2)*sex)
anova(f)
# Compare a 30 year old female to a 40 year old male
# (with or without age x sex interaction in the model)
contrast(f, list(sex='female', age=30), list(sex='male', age=40))
# Test for interaction between age and sex, duplicating anova
contrast(f, list(sex='female', age=30),
            list(sex='male',   age=30),
            list(sex='female', age=c(40,50)),
            list(sex='male',   age=c(40,50)), type='joint')
# Duplicate overall sex effect in anova with 3 d.f.
contrast(f, list(sex='female', age=c(30,40,50)),
            list(sex='male',   age=c(30,40,50)), type='joint')

jim <- contrast(f, list(sex = "male", age=30),
                   list(sex = "male", age=40))
print(jim, fun = exp)
jane <- contrast(f, list(sex = c("male", "female"), age=30),
                    list(sex = c("male", "female"), age=40))
print(jane, fun = exp)

# From http://stats.stackexchange.com/questions/191063/lrm-and-orm-contrast-rms-package

require(rms)
set.seed(1)
x <- factor(rbinom(100,2,0.6), labels = c("a","b","c"), ordered = TRUE)
y <- factor(rbinom(100,1,0.5), labels=c("no","yes"))
f <- lrm(x ~ y)
g <- orm(x ~ y)
coef(f); coef(g)

print(contrast(f, list(y='no'), list(y='yes')), X=TRUE)
print(contrast(g, list(y='no'), list(y='yes')), X=TRUE)


=begin
  # sample-group01.rb

  require "algebra"
  e = Permutation[0, 1, 2, 3, 4]
  a = Permutation[1, 0, 3, 4, 2]
  b = Permutation[0, 2, 1, 3, 4]
  p a * b #=> [2, 0, 3, 4, 1]

  g = Group.new(e, a, b)
  g.complete!
  p g == PermutationGroup.symmetric(5) #=> true

((<_|CONTENTS>))
=end


A <- matrix(c(3,1,4,1),ncol = 2)
mat <- A
for(i in 1:99){
	mat <- (mat %*% A)
}
print(mat)

# inspired by:
# https://www.youtube.com/watch?v=PFDu9oVAE-g&list=PLZHQObOWTQDPD3MizzM2xVFitgF8hE_ab&index=13
# 14 min, 30 seconds

B <- matrix(c(3,0,0,2), ncol = 2)
mat2 <- B
for(i in 1:99){
	mat2 <- (mat2 %*% B)
}
print(mat2)

mat2[1,1] == 3^100 #true
mat2[2,2] == 2^100 #true


# Master Thesis Project - Extreme Value Theory
# Looking into the distribution of B^(n)[t]
# Killian Martin--Horgassan
# 23-04-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/randomWalk.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/Epsilon_is.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/brokenLine.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/brownianMotion.r")

# Let the user enter the time horizon of the brownian motion
cat("Time step ?")
t <- as.numeric(readline("t :\n"))

# Number of trials
cat("Sample size ?")
N <- as.numeric(readline("N :\n"))

# n must be large for B^(n)[t] to be a good approximation of B[t]
n <- 1000

# Generating the Brownian Motion
BM_vect <- rep(0,N)
for (i in 1:N) {
	BM_vect[i] <- (brownianMotion(t,1/n))[floor(n*t)]
}

# Plot the Brownian Motion
quartz()

title <- paste("Sample from a distribution", expression(B[t]^(n)), " with t = ", t)

hist(BM_vect, main = "Density plot", freq = FALSE, col = "lightgreen")
curve(dnorm(x, mean = mean(BM_vect), sd = sd(BM_vect)), add = TRUE, col = "darkblue", lwd = 4)
print(var(BM_vect))
curve(dnorm(x, mean = 0, sd = sqrt(t)), add = TRUE, col = "red", lwd = 4)


# Hankui in SDSU
# source("build_graph.r");

# build the CNN structure
## con_indicator (2 or 4) indicates the whether convolution is used or not
## is_shallow indicates the DNN structure
# input_dim_x=13; input_dim_y=3;

source("cnn.common.r");

#************************************************************************************************************************
## non-linear activation function
## type = 0: RELU
## type = 1: parametric RELU He et al. 2015
## type = 6: RELU6
non_linear <- function(x, ndim=shape(100), type=1) {
	alphas <- tf$Variable(tf$ones(1L)*0.25);
	if (type==1) {
		pos <- tf$nn$relu(x);
		# neg <- alphas * (x - abs(x)) * 0.5; ## not work
		# neg <- (x - abs(x)) * 0.5; ## work
		# neg <- tf$scalar_mul(alphas, (x - abs(x)) * 0.5 ); ## not work
		neg <- tf$multiply(alphas, (x - abs(x)) * 0.5 ); ## work
		result <- pos + neg;
	} else if (type==6) {
		result <- tf$nn$relu6(x);
	} else result <- tf$nn$relu(x);

	result
}

#************************************************************************************************************************
## a neural network unit including a linear transformation (convolution/fully connection) and a non-linear function
## leftwidth*leftlength*n1 representing the dimension of the convolution layer to be normalized if is_norm=TRUE and is_con=TRUE
##                      n1 representing the dimension of the fully connected layer to be normalized if is_norm=TRUE and is_con=FALSE
nn_unit <- function (x_image, W_conv1, b_conv1, leftwidth=1, leftlength=11, n1=100, is_norm=TRUE, is_training=TRUE, non.linear.type=0, is_con=TRUE, is_pad=FALSE, is_max_pool=FALSE) {

	# i=1
	# is_training = TRUE
	# x_image=h_convs[[i]]
	# W_conv1=weightlists[[i]]
	# b_conv1=baislists[[i]]
	# leftwidth=left_widths[i]
	# leftlength=left_lengths[i]
	# n1=n_nodes[i]
	# is_training=is_training;
	# non.linear.type=non.linear.type;
	# is_con=TRUE
	# is_pad=FALSE

	if (is_norm) {
		if (is_con) {
			h_cov_nopad_1 <- conv2d_no_pad(x_image, W_conv1, is_pad);
			h_batch_1 <- batch_norm_wrapper(h_cov_nopad_1, is_training, ndim=shape(leftwidth,leftlength,n1) );
			h_conv1 <- non_linear(h_batch_1, type=non.linear.type);
		} else {
			h_fc_last <- tf$matmul(x_image, W_conv1);
			h_batch_last <- batch_norm_wrapper(h_fc_last, is_training, ndim=shape(n1) );
			h_conv1 <- non_linear(h_batch_last, type=non.linear.type);
		}
		# h_conv1 <- tf$nn$relu6(h_batch_1);
	} else {
		if (is_con) {
			h_cov_nopad_1 <- conv2d_no_pad(x_image, W_conv1, is_pad) + b_conv1;
			h_conv1 <- non_linear(h_cov_nopad_1, type=non.linear.type);
		} else {
			h_cov_nopad_1 <- tf$matmul(x_image, W_conv1) + b_conv1;
			h_conv1 <- non_linear(h_cov_nopad_1, type=non.linear.type);
		}
	}
	if (is_max_pool==TRUE) {
		h_conv1_pull <- max_pool_2x2(h_conv1);
		h_conv1 <- h_conv1_pull;
	} else if (is_max_pool==2) {
		# print("Average pooling has been used \n");
		h_conv1_pull <- avg_pool_2x2(h_conv1);
		# h_conv1_pull <- max_pool_2x2(h_conv1);
		# h_conv1_pull <- max_pool_1x2(h_conv1);
		h_conv1 <- h_conv1_pull;
	}
	# h_pool1_in <- max_pool_1x2(h_conv1);
	h_conv1
}

#************************************************************************************************************************
## global variables for building graph
max_depth   <- 21;
weightlists <<- vector("list", max_depth);
baislists   <<- vector("list", max_depth);

#************************************************************************************************************************
## build the graph for training or testing
## con_indicator (2 or 4) indicates the whether convolution is used or not
## is_shallow indicates the DNN structure
# is_training=TRUE;
# input_dim_x=13; input_dim_y=3;
build_graph <- function (con_indicator, is_training=TRUE, x, input_dim_x, input_dim_y, input_dim_z=1L, is_norm=TRUE, is_shallow=TRUE) {

	input_dim_stacked <- input_dim_x*input_dim_y*input_dim_z;
	non.linear.type <- 6;
	non.linear.type <- 1;
	non.linear.type <- 0;
	cat("\tbuild_graph with non.linear.type", non.linear.type, "\n");
	## ***************************************
	## option 2: 2d filter followed by a fully connected layer
	isdim <- FALSE;
	# isdim <- TRUE;
	n_nodes <- vector(mode="integer",  length=max_depth);
	depth <<- 4;
	conv_depth <- depth-2;
	# n1 <- 0L; n2 <- 0L; n3 <- 0L; n4 <- 0L; n5 <- 0L;  n6 <- 0L;  n7 <- 0L;
	if (con_indicator==2) {
		# left_lengths <- vector(mode="integer",  length=max_depth);
		## dimension left after convolution
		left_lengths <- rep(1L, max_depth);
		left_widths <- left_lengths;

		con_dims  <- rep(1L, max_depth);
		con_dim2  <- rep(1L, max_depth);

		con_dims[1  ] <- 3;
		con_dim2[1:6] <- 3;

		n_nodes[1] <- 64L;
		n_nodes[2] <- 128L;
		n_nodes[3] <- 256L;
		# n_nodes[1] <- 128L;
		# n_nodes[2] <- 256L;
		# n_nodes[3] <- 1024L; ## tested on May 23 2018 for simplified VGG accuracy
		left_lengths[1] <- 11L;
		left_lengths[2] <- 9L;
		# left_lengths[3] <- 7L;

		if (is_shallow==FALSE) {
			depth <<- 8;
			conv_depth <- depth-2;

			left_lengths[1] <- 11L;
			left_lengths[2] <- 9L;
			left_lengths[3] <- 7L;
			left_lengths[4] <- 5L;
			left_lengths[5] <- 3L;
			left_lengths[6] <- 1L;

			n_nodes[1] <- 128L;
			n_nodes[1] <- 64L; ## revised on Nov 1 2018
			n_nodes[2] <- 128L;
			n_nodes[3] <- 256L;
			n_nodes[4] <- 256L;
			n_nodes[5] <- 512L;
			n_nodes[6] <- 512L;
			n_nodes[7] <- 1024L;
		} else if (is_shallow==5) {
			depth <<- 19;
			conv_depth <- depth-3;## note this has been changed from depth-2 to depth-3 on June 20, 2018
			left_widths[1:1 ] <- 3;

			con_dims[1:2 ] <- 3;
			con_dim2[1:17] <- 3;

			left_lengths[1 ] <- 13L;
			left_lengths[2 ] <- 11L;
			left_lengths[3 ] <- 11L;
			left_lengths[4 ] <- 9L;
			left_lengths[5 ] <- 9L;
			left_lengths[6 ] <- 9L;
			left_lengths[7 ] <- 9L;
			left_lengths[8 ] <- 7L;
			left_lengths[9 ] <- 7L;
			left_lengths[10] <- 7L;
			left_lengths[11] <- 5L;
			left_lengths[12] <- 5L;
			left_lengths[13] <- 5L;
			left_lengths[14] <- 3L;
			left_lengths[15] <- 3L;
			# left_lengths[16] <- 3L; ## NOTE THAT THIS HAS BEEN CHANGED FROM 1 to 3
			left_lengths[16] <- 1L; ## NOTE THAT THIS HAS BEEN CHANGED FROM 3 to 1 on June 20, 2018
			left_lengths[17] <- 1L;

			n0 <- 64  ; n_nodes[ 1] <- n0; n_nodes[ 2] <- n0;
			n0 <- 128 ; n_nodes[ 3] <- n0; n_nodes[ 4] <- n0;
			n0 <- 256 ; n_nodes[ 5] <- n0; n_nodes[ 6] <- n0; n_nodes[ 7] <- n0; n_nodes[ 8] <- n0;
			n0 <- 512 ; n_nodes[ 9] <- n0; n_nodes[10] <- n0; n_nodes[11] <- n0; n_nodes[12] <- n0; n_nodes[13] <- n0; n_nodes[14] <- n0; n_nodes[15] <- n0; n_nodes[16] <- n0;
			n0 <- 1024; n_nodes[17] <- n0; n_nodes[18] <- n0;
		}

		# is_use_pooling = 2;
		# is_use_pooling = TRUE;
		is_use_pooling = FALSE;
		if (is_use_pooling>=1) {
			con_dims[1:2] <- 3;
			con_dim2[1:6] <- 3;

			n_nodes[1] <- 64L;
			n_nodes[2] <- 128L;
			n_nodes[3] <- 256L;
			left_lengths[1] <- 13L;
			left_lengths[2] <- 7L;
			left_lengths[3] <- 4L;
			left_widths[1] <- 3L;
			left_widths[2] <- 2L;
			left_widths[3] <- 1L;

			if (is_shallow==FALSE) {
				depth <<- 7;
				conv_depth <- depth-2;
				con_dims[1:3] <- 3;
				con_dim2[1:5] <- 3;

				left_lengths[1] <- 13L;
				left_lengths[2] <- 7L;
				left_lengths[3] <- 4L;
				left_lengths[4] <- 2L;
				left_lengths[5] <- 1L;

				left_widths[1] <- 3L;
				left_widths[2] <- 2L;
				left_widths[3] <- 1L;

				n_nodes[1] <- 64L;
				n_nodes[2] <- 128L;
				n_nodes[3] <- 256L;
				n_nodes[4] <- 256L;
				n_nodes[5] <- 512L;
				n_nodes[6] <- 1024L;
			} else if (is_shallow==5) {
				depth <<- 16;
				conv_depth <- depth-3;## note this has been changed from depth-2 to depth-3 on June 20, 2018

				con_dims[1:7 ] <- 3;
				con_dim2[1:13] <- 3;

				left_lengths[1 ] <- 13L;
				left_lengths[2 ] <- 13L;
				left_lengths[3 ] <- 13L;
				left_lengths[4 ] <- 7L;
				left_lengths[5 ] <- 7L;
				left_lengths[6 ] <- 7L;
				left_lengths[7 ] <- 4L;
				left_lengths[8 ] <- 4L;
				left_lengths[9 ] <- 4L;
				left_lengths[10] <- 2L;
				left_lengths[11] <- 2L;
				left_lengths[12] <- 2L;
				left_lengths[13] <- 1L;

				left_widths[1 ] <- 3L;
				left_widths[2 ] <- 3L;
				left_widths[3 ] <- 3L;
				left_widths[4 ] <- 2L;
				left_widths[5 ] <- 2L;
				left_widths[6 ] <- 2L;
				left_widths[7 ] <- 1L;

				# left_lengt14hs[1 ] <- 13L;
				# left_lengths[2 ] <- 11L;
				# left_lengths[3 ] <- 11L;
				# left_lengths[4 ] <- 9L;
				# left_lengths[5 ] <- 9L;
				# left_lengths[6 ] <- 9L;
				# left_lengths[7 ] <- 9L;
				# left_lengths[8 ] <- 7L;
				# left_lengths[9 ] <- 7L;
				# left_lengths[10] <- 7L;
				# left_lengths[11] <- 5L;
				# left_lengths[12] <- 5L;
				# left_lengths[13] <- 5L;
				# left_lengths[14] <- 3L;
				# left_lengths[15] <- 3L;
				# left_lengths[16] <- 1L; ## NOTE THAT THIS HAS BEEN CHANGED FROM 3 to 1 on June 20, 2018
				# left_lengths[17] <- 1L;

				n0 <- 64  ; n_nodes[ 1] <- n0; n_nodes[ 2] <- n0;
				n0 <- 128 ; n_nodes[ 3] <- n0; n_nodes[ 4] <- n0;
				n0 <- 256 ; n_nodes[ 5] <- n0; n_nodes[ 6] <- n0; n_nodes[ 7] <- n0;
				n0 <- 512 ; n_nodes[ 8] <- n0; n_nodes[ 9] <- n0; n_nodes[10] <- n0; n_nodes[11] <- n0; n_nodes[12] <- n0; n_nodes[13] <- n0;
				n0 <- 1024; n_nodes[14] <- n0; n_nodes[15] <- n0;
			}
		} ## pooling is true

		## weights and bias
		for (i in 1:depth) {
			scale_factor <- 2;
			if (i==1) {
				# weightlists[[i]] <- weight_variable(shape(con_dims[i], con_dim2[i], 1, n_nodes[i]), stddev=sqrt(scale_factor/(con_dims[i]*con_dim2[i]*n_nodes[i])) );
				weightlists[[i]] <- weight_variable(shape(con_dims[i], con_dim2[i], 1, n_nodes[i]), stddev=sqrt(scale_factor/(con_dims[i]*con_dim2[i])) );
				baislists  [[i]] <- bias_variable(shape(1, left_lengths[i], n_nodes[i]) );
			} else if (i<=conv_depth) {
				weightlists[[i]] <- weight_variable(shape(con_dims[i], con_dim2[i], n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(con_dims[i]*con_dim2[i]*n_nodes[i])) );
				baislists  [[i]] <- bias_variable(shape(1, left_lengths[i], n_nodes[i]) );
			} else if (i==(conv_depth+1) ) { ## last convolution layer
				concatenation <- left_widths[i-1] * left_lengths[i-1];
				if (is_use_pooling>=1) concatenation <- ceiling(left_widths[i-1]/2) * ceiling(left_lengths[i-1]/2); ## max pool is used
				# weightlists[[i]] <- weight_variable(shape(1 * left_lengths[i-1] * n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				weightlists[[i]] <- weight_variable(shape(concatenation * n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				baislists  [[i]] <- bias_variable(shape(1, n_nodes[i]) );
			} else if (i<=(depth-1) ) { ## fully connected layers
				# concatenation <- left_widths[i-1] * left_lengths[i-1];
				# if (is_use_pooling) concatenation <- ceiling(left_widths[i-1]/2) * ceiling(left_lengths[i-1]/2); ## max pool is used
				# weightlists[[i]] <- weight_variable(shape(1 * left_lengths[i-1] * n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				weightlists[[i]] <- weight_variable(shape(n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				baislists  [[i]] <- bias_variable(shape(1, n_nodes[i]) );
			} else {
				W_fc_n  <- weight_variable(shape(n_nodes[i-1], classn), stddev=sqrt(scale_factor/(1*1*n_nodes[i-1])) );
				b_fc_n  <- bias_variable(shape(classn) );
				weightlists[[i]] <- W_fc_n;
				baislists  [[i]] <- b_fc_n;
			}
		}

		## convolution
		h_conv0 <- tf$reshape(x, shape(-1L, input_dim_y, input_dim_x, input_dim_z));

		h_convs <- list();
		h_convs[[1]] <- h_conv0;
		if (is_use_pooling==FALSE) { ## pooling is NOT used
			if (is_shallow<5) {
				for (i in 1:conv_depth)
					h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE);
			} else {
				for (i in 1 :1 )
					h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE);
				for (i in 2:conv_depth)
					h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=(left_lengths[i-1]==left_lengths[i])  );
			}
		} else { ## pooling is used is_max_pool = if (left_widths[i-1]>1 && left_lengths[i-1]>1) { TRUE } else if (left_widths[i-1]==1 && left_lengths[i-1]>1) {2} else {FALSE}
				## revised on Aug 10 2019 for pooling is true
			for (i in 1:conv_depth) {
				# is_max_pool = if (left_widths[i-1]>1 && left_lengths[i-1]>1) { TRUE } else if (left_widths[i-1]==1 && left_lengths[i-1]>1) {2} else {FALSE};
				# is_max_pool = if (left_lengths[i]==left_lengths[i+1]) {FALSE} else { if (left_widths[i]>1 && left_lengths[i]>1) { TRUE } else if (left_widths[i]==1 && left_lengths[i]>1) {2} else {FALSE} };
				is_max_pool <- (left_lengths[i]!=left_lengths[i+1]);
				if (is_max_pool && is_use_pooling==2) is_max_pool <- 2;
				h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE, is_max_pool=is_max_pool);
			}
		}
		## fully connected layer
		# h_pool2_flat <- tf$reshape(h_convs[[conv_depth+1]], shape(-1L, 1 * left_lengths[conv_depth] * n_nodes[conv_depth]));
		h_pool2_flat <- tf$reshape(h_convs[[conv_depth+1]], shape(-1L, concatenation*n_nodes[conv_depth]));
		h_convs[[conv_depth+1]] <- h_pool2_flat;

		for (i in (conv_depth+1):(depth-1) )
			h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftlength=left_lengths[i], n1=n_nodes[i], is_norm=is_norm, is_training=is_training, non.linear.type=non.linear.type, is_con=FALSE);

		if (isdim) {
			cat("W_fc_n: ") ; get_dim(W_fc_n);
			cat("b_fc_n: ") ; get_dim(b_fc_n);
			cat("y_conv: ") ; get_dim(y_conv);
			stop("Stop because of isdim CHECK");
		}

	}

	## ***************************************
	## option 4: only contain fully connected layers
	if (con_indicator==4) {
		conv_depth <- 0;
		## ***************************************
		## option 4: only one filter is applied
		if (is_shallow==TRUE) {
			n0 <- 256L;
			n1 <- 512L;
			nn <- 512L; ## S2: z=256; x=512; 39*z+ z* x + x* x + x* 15 (410880): ?
			n_nodes[1] <- n0;
			n_nodes[2] <- n1;
			n_nodes[3] <- n1;
		} else if (is_shallow==FALSE) {
			depth <<- 8;
			n0 <- 256L;
			n1 <- 512L;
			nn <- 1024L; ## S2: z=256; x=512; y=1024L; 39*x + x* x + x* x + x* x + x* x + x* y + y*y + y*15 (2656768): 84.5174%
			##S3: z=256L; x=512L; y=1024L; 39*z + z* z + z* z + z* x + x* x + x* y + y*y + y*15 (2122496)

			n_nodes[1] <- n0;
			n_nodes[2] <- n0;
			n_nodes[3] <- n0;
			n_nodes[4] <- n1;
			n_nodes[5] <- n1;
			n_nodes[6] <- nn;
			n_nodes[7] <- nn;
		} else {
			depth <<- 19;
			n0 <- 64  ; n_nodes[ 1] <- n0; n_nodes[ 2] <- n0;
			n0 <- 128 ; n_nodes[ 3] <- n0; n_nodes[ 4] <- n0;
			n0 <- 256 ; n_nodes[ 5] <- n0; n_nodes[ 6] <- n0; n_nodes[ 7] <- n0; n_nodes[ 8] <- n0;
			n0 <- 512 ; n_nodes[ 9] <- n0; n_nodes[10] <- n0; n_nodes[11] <- n0; n_nodes[12] <- n0; n_nodes[13] <- n0; n_nodes[14] <- n0; n_nodes[15] <- n0; n_nodes[16] <- n0;
			# n0 <- 4096; n_nodes[17] <- n0; n_nodes[18] <- n0;
			n0 <- 1024; n_nodes[17] <- n0; n_nodes[18] <- n0;
		}

		## weights and bias
		widths0 <- input_dim_stacked;
		# weightlists <- list();
		# baislists <- list();
		for (i in 1:depth) {
			scale_factor <- 2;
			if (i==1) {
				weightlists[[i]] <<- weight_variable(shape(widths0, n_nodes[i]), stddev=sqrt(scale_factor/n_nodes[i]) );
				baislists  [[i]] <<- bias_variable(shape(n_nodes[i]) );
			} else if (i<=depth-1) {
				weightlists[[i]] <<- weight_variable(shape(n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/n_nodes[i]) );
				baislists  [[i]] <<- bias_variable(shape(n_nodes[i]) );
			} else {
				W_fc_n  <- weight_variable(shape(n_nodes[i-1], classn), stddev=sqrt(scale_factor/n_nodes[i-1]) );
				b_fc_n  <- bias_variable(shape(classn) );
				weightlists[[i]] <<- W_fc_n;
				baislists  [[i]] <<- b_fc_n;
			}
		}

		## convolution / non-linear functions
		h_conv0 <- tf$cast(tf$reshape(x, shape(-1L, widths0)), tf$float32);

		h_convs <- list();
		h_convs[[1]] <- h_conv0;
		for (i in 1:(depth-1) )
			h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftlength=left_lengths[i], n1=n_nodes[i], is_norm=is_norm, is_training=is_training, non.linear.type=non.linear.type, is_con=FALSE);

		## softmax layer
		h_fc_n_drop <- h_convs[[depth]];

		## final layer
		# y_conv <- tf$nn$softmax(tf$matmul(h_fc_n_drop, W_fc_n) + b_fc_n);

		if (isdim) {
			cat("W_fc2 : ") ; get_dim(W_fc2 );
			cat("b_fc2 : ") ; get_dim(b_fc2 );
			cat("y_conv: ") ; get_dim(y_conv);
			stop("Stop because of isdim CHECK");
		}
	}

	# last_active <- tf$matmul(h_convs[[depth]], W_fc_n);
	last_active <- tf$matmul(h_convs[[depth]], W_fc_n) + b_fc_n;
	last_mean <- tf$reduce_mean(last_active, 1L);
	y_conv  <- tf$nn$softmax(last_active);

	## regularizer
	regularizer <- 0;
	# for (i in 1:(depth-1) )  {
		# if (i<=conv_depth) {
			# regularizer <- regularizer+tf$nn$l2_loss(weightlists[[i]]);
		# } else regularizer <- regularizer+10*tf$nn$l2_loss(weightlists[[i]]);
	# }
	# regularizer <- regularizer+10*tf$nn$l2_loss(W_fc_n);

	for (i in 1:(depth-1) )  {
		regularizer <- regularizer+tf$nn$l2_loss(weightlists[[i]]);
	}
	regularizer <- regularizer+tf$nn$l2_loss(W_fc_n);

	## print information
	cat("\tcon_indicator =", con_indicator, "depth =", depth, "conv_depth =", conv_depth, "is_use_pooling =", is_use_pooling, "\n\t");
	for (i in 1:(depth-1) ) cat("width[", i, "] = ", n_nodes[i], "  ", sep="");
	cat("\n");
	# if (con_indicator==2) cat("\t\tn3 = ", n3, "n4 = ", n4, "n5 = ", n5, "n6 = ", n6, "\n");

	list("y_conv"=y_conv, "regularizer"=regularizer, "last_active"=last_active, last_mean="last_mean")
}

			# if (is_shallow<6) {
				# i = 1;
				# is_max_pool = TRUE;
				# h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE, is_max_pool=is_max_pool);
			# } else {
				# for (i in 1 :1 )
					# h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE);
				# for (i in 2:conv_depth)
					# h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=(left_lengths[i-1]==left_lengths[i])  );
			# }