#######################  PCA   #################
setwd(.WD)
source("functions.r")
options(warn=-1)

.pca <- princomp(dat)  #default cor = F

n <- nrow(dat)
p <- ncol(dat)

sumpca <- matrix(rep(0,3*p), nrow = 3)
sumpca[1,] <- .pca$sdev^2
sumpca[2,] <- cumsum(.pca$sdev^2)
sumpca[3,] <- cumsum(.pca$sdev^2)/sum(.pca$sdev^2)
cat("Summary of Principle Component Analysis is stored in 'sumpca'\n")

dev.new()
par(las = 3, cex.axis=.8)
plot(.pca,main='Variance of Principle Components', ylim = c(0,.pca$sdev[1]^2*1.2))
with(.pca,
     text(x = (1:ncol(dat)*1.1),
          y = .pca$sdev^2,
          labels = paste(round(sumpca[3,]*100, 1),"%"),
          pos = 3, cex = .8))
.par0()
cat("\n Please press Enter key to continue...\n")
readline()

palette("default")
biplot(.pca,cex=.8)
cat("First two Principle Components Coordinates Plot:\n")
cat("\n Please press Enter key to continue...\n")
readline()
print(summary(.pca))
cat('\n\n')

## obtain the loadings
.loadpca <- .pca$loadings
cat("Sort the variables by its loading to which principle component? \n")
.pcNum <- .scanf(1,c(1:p))
.Ind <- order(abs(.loadpca[,.pcNum]),decreasing = T)
.pcMat <- matrix(c(.attri[.Ind],round(.loadpca[.Ind,1:4],3)),ncol=5)
.namMat <- c('variable', 'PC1', 'PC2', 'PC3', 'PC4')
print(rbind(as.character(.namMat), .pcMat), quote = F)
.loadMat4 = matrix(as.numeric(.pcMat[,2:5]),ncol=4)
cat("\n Please press Enter key to continue...\n")
readline()

.gnum <- 2
if(.colGrou) .gnum <- length(.ugrou)

.stay <- 1
while(.stay){
cat("***************  visualization with PCs  *****************\n")
cat("\n 1. scattermatrix plot\n")
cat("\n 2. detailed scatter plot with 2PCs\n")
cat("\n 3. 3D scatter plot\n")
cat("\n 4. exit\n")
.choi <- .scanf(1,c(1:4))

if(.choi == 1){
.pc4 <- predict(.pca)[,1:5]
.par0()
palette(rainbow(.gnum))
pairs(.pc4,
      diag.panel=.panelhist, cex.labels = 1.5, font.labels = 2,
      pch = 21, bg = c(1:(length(.ugrou)))[unclass(.ngrou)])
.tick <- 1/.gnum
if(.colGrou)
mtext(.ugrou, side = 3, at = c(0.5:(length(.ugrou)-.5))*.tick,
      line= 2.5, col = 1:length(.ugrou), font = rep(2,length(.ugrou)) )
palette("default")
cat("\n Please press Enter key to continue...\n")
readline()
}

if(.choi == 2){
cat("Choose the two Principle Components:\n")
.chosen <- .scanf(1,c(1:p))
while(length(.chosen) != 2){
  cat('Number of input PCs is not 2. Please type again:\n')
  .chosen <- .scanf(1,c(1:p))}
.pc1 <- as.character(.chosen[1]); .pc2 <- as.character(.chosen[2])
.xpc <- predict(.pca)[,.chosen]
par(las = 0, cex.axis=.8, font.lab=7, font.main=7, cex.main=1.5, font.sub=9)
eqscplot(.xpc,type="n",main='PCA plot for Clustering Analysis',
         xlab=paste('Principle Component ',.pc1),
         ylab=paste('Principle Component ',.pc2))
text(.xpc,labels=c(1:n), col=.ngrou+1, cex=.8, font=8)
if(.colGrou) {
         .Pmin <- min(.xpc[,1])
         .tick <- (max(.xpc[,1])-.Pmin)/length(.ugrou)
      mtext(.ugrou, side = 3, at = .Pmin + .tick/2 + (c(1:(length(.ugrou)))-1)*.tick,
      line= .2, col = 2:(length(.ugrou)+1), font = rep(2,length(.ugrou)))
      }
      .par0()
}

if(.choi == 3){
  cat("Choose the three Principle Components:\n")
  .chosen <- .scanf(1,c(1:p))
  while(length(.chosen) != 3){
  cat('Number of input PCs is not 3. Please type again:\n')
  .chosen <- .scanf(1,c(1:p))}
.pc1 <- as.character(.chosen[1])
.pc2 <- as.character(.chosen[2])
.pc3 <- as.character(.chosen[3]);
.xpc <- predict(.pca)[,.chosen]
palette(rainbow(.gnum))
plot3d(.xpc, col=.ngrou, size=10)
.rang <- range(.xpc[,3])[2]-range(.xpc[,3])[1]
if(.colGrou)
  text3d(rep(max(.xpc[,1]),.gnum),rep(max(.xpc[,2]),.gnum),
         rep(max(.xpc[,3]),.gnum)-c(1:.gnum)*.rang/20,
         text=paste(as.vector(.ugrou)),
                    adj=c(1,1), color=c(1:.gnum), cex = .8)
cat("Do you want to impose the names of sites? y/n\n")
ans <- .scanf(2)
if(ans == "y") text3d(.xpc,text = paste(.sites),col = .ngrou, cex = .7)
palette("default")
cat("\n Please press Enter key to continue...\n")
readline()
}

if(.choi == 4) .stay <- 0
}


R version 3.2.2 (2015-08-14) -- "Fire Safety"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]
 install.packages("RQuantLib", type="binary")
 install.packages("ESGtoolkit")
 library(RQuantLib)
 library(ESGtoolkit)

 freq <- "monthly"

 delta_t <- 1/12

 delta_t

 params <- list(tradeDate=as.Date('2002-2-15'),
                 settleDate=as.Date('2002-2-19'),
                 payFixed=TRUE,
                 dt=delta_t,
                 strike=.06,
                 method="HWAnalytic",
                 interpWhat="zero",
                 interpHow= "spline")

 TermQuotes  <- list(d1w =0.0382,
                      d1m =0.0372,
                      d3m = 0.0363,
                      d6m = 0.0353,
                      d9m = 0.0348,
                      d1y = 0.0345,
                      s2y = 0.037125,
                      s3y =0.0398,
                      s5y =0.0443,
                      s10y =0.05165,
                      s15y =0.055175)

 SwaptionMaturities <- c(1,2,3,4,5)

 SwaptionMaturities

 SwapTenors <- c(1,2,3,4,5)

 SwapTenors

 VolatilityMatrix <- matrix(
      c(0.1490, 0.1340, 0.1228, 0.1189, 0.1148,
        0.1290, 0.1201, 0.1146, 0.1108, 0.1040,
        0.1149, 0.1112, 0.1070, 0.1010, 0.0957,
        0.1047, 0.1021, 0.0980, 0.0951, 0.1270,
        0.1000, 0.0950, 0.0900, 0.1230, 0.1160),
      ncol=5, byrow=TRUE)

 BermudanSwaption <- RQuantLib::BermudanSwaption(params, TermQuotes, SwaptionMaturities, SwapTenors, VolatilityMatrix)

 summary(BermudanSwaption)

 BermudanSwaption

 times <- seq(from = delta_t, to = 5, by = delta_t)

 DiscountCurve <- RQuantLib::DiscountCurve(params, TermQuotes, times)

 str(DiscountCurve)

 maturities <- DiscountCurve$times

 maturities

 MarketZeroRates <- DiscountCurve$zerorates

 MarketZeroRates

 MarketPrices <- DiscountCurve$discounts

 MarketPrices

 horizon <- 5

 NoSimulations <- 10000

 a <- BermudanSwaption$a
 a

 sigma <- BermudanSwaption$sigma

 sigma

 GaussianShocks <- ESGtoolkit::simshocks(n = NoSimulations, horizon = horizon, frequency = freq)

 x <- ESGtoolkit::simdiff(n = NoSimulations, horizon = horizon, frequency = freq, model = "OU", x0 = 0, theta1 = 0, theta2 = a, theta3 = sigma, eps = GaussianShocks)

 ForwardRates <- ts(replicate(nb.sims, DiscountCurve$forwards), start = start(x), deltat = deltat(x))

 t.out <- seq(from = 0, to = horizon, by = delta_t)

 param.alpha <- ts(replicate(NoSimulations, 0.5*(sigma^2)*(1 - exp(-a*t.out))^2/(a^2)), start = start(x), deltat = deltat(x))

 alpha <- ForwardRates + param.alpha

 ShortRates <- x + alpha

 StochasticDiscount <- ESGtoolkit::esgdiscountfactor(r = ShortRates, X = 1)

 MonteCarloPrices <- rowMeans(StochasticDiscount)

 MonteCarloPrices

 MonteCarloZeroRates <- -log(MonteCarloPrices)/maturities

 MonteCarloZeroRates

 ConfidenceInterval <- t(apply((StochasticDiscount - MarketPrices)[-1, ], 1, function(x) t.test(x)$conf.int))

 head(ConfidenceInterval)

 par(mfrow = c(2, 2))

 ESGtoolkit::esgplotbands(ShortRates, xlab = "maturities", ylab = "short-rate quantiles", main = "Short Rate Quantiles")

 plot(maturities, MonteCarloZeroRates, type='l', col = 'blue', lwd = 1, main = "Monte Carlo v/s Market n Zero Rates")

 points(maturities, MonteCarloZeroRates, col = 'red')

 plot(maturities, MonteCarloPrices, type='l', col = 'blue', lwd = 1, main = "Monte Carlo v/s Market n Zero Rates")

 points(maturities, MonteCarloPrices, col = 'red')

 matplot(maturities[-1], conf.int, type = 'l', main = "Confidence Interval for the price difference")

Chapter 08/5Monte Carlo Simulations - Calibrated Hull and White short-rates.r


 E04GBJ Example Program Results

 On exit, the sum of squares is       0.0082
 at the point       0.0824      1.1330      2.3437
 The corresponding gradient is   1.199E-09  -1.865E-11   1.807E-11
                           (machine dependent)
 and the residuals are
  -5.9E-03
  -2.7E-04
   2.7E-04
   6.5E-03
  -8.2E-04
  -1.3E-03
  -4.5E-03
  -2.0E-02
   8.2E-02
  -1.8E-02
  -1.5E-02
  -1.5E-02
  -1.1E-02
  -4.2E-03
   6.8E-03


rm(list = ls())

library(EpiModel)

set.seed(12345)

nw <- network::network.initialize(n = 1e3, directed = FALSE)
nw <- network::set.vertex.attribute(nw, "risk", rep(0:1, each=500))

formation <- ~edges + nodefactor("risk") + nodematch("risk") + concurrent

target.stats <- c(250, 375, 225, 100)
coef.diss <- dissolution_coefs(dissolution = ~offset(edges), duration = 80)
coef.diss

# Step 1
est1 <- netest(nw, formation, target.stats, coef.diss)

# Step 2
dx <- netdx(est1, nsims=10, nsteps = 1000)
dx

# Step 3
init    <- init.net(i.num = 50)
param   <- param.net(inf.prob = 0.1, act.rate=5, rec.rate = .02)
control <- control.net(type = "SIS", nsteps=500, nsims = 10, epi.by = "risk")

sim1    <- netsim(est1, param, init, control)

plot(sim1)
summary(sim1, at = 500)

plot(sim1, y = c("i.num.risk0", "i.num.risk1"), legend=TRUE)

oldpar <- par(no.readonly = TRUE)
par(mfrow=c(1, 2))
plot(sim1, type="network", at=1, col.status = TRUE)
plot(sim1, type="network", at=500, col.status = TRUE)
par(oldpar)


# Benjamini-Hochberg with two-sided p-values
BenjaminiHochberg = function(zscores, fdr_level) {
# zscores is a vector of z scores
# fdr_level is the desired level (e.g. 0.1) of control over FDR
# returns a binary vector where 0=nofinding, 1=finding at given FDR level
    N = length(zscores)
    pval2 = 2*pmin(pnorm(zscores), 1- pnorm(zscores))
    cuts = (1:N)*fdr_level/N
    bhdiff = sort(pval2)-cuts
    bhcutind2 = max(which(bhdiff < 0))
    bhcut2 = sort(pval2)[bhcutind2]
    0+{pval2 <= bhcut2}
}

args <- commandArgs(trailingOnly = TRUE)
z = as.numeric(t(as.matrix(read.csv(args[1], header=FALSE))))#testing
discoveries = BenjaminiHochberg(z, 0.1)
write.table(discoveries, args[2], row.names=FALSE, col.names=FALSE, sep=",")


# 4. faza: Analiza podatkov

########## RAZVRŠČANJE V SKUPINE ##########

razvrscanje <- function(){
  evropa1 <- World %>% filter (continent == 'Europe')
  names(evropa1)[3] <- 'Drzava'
  delure <- A1 %>% filter(Leto == 2018, Spol == "Total") %>%
    select(Drzava, SteviloDelovnihUr)
  delure$Drzava[delure$Drzava == "Czech Rep."] <- "Czech Republic"
  bdp <- tabela2gdp %>% filter(Leto == 2018) %>%
    select(Drzava, BDP)
  glavni1 <- inner_join(evropa1, delure, by = 'Drzava')
  glavni2 <- inner_join(glavni1, bdp, by = 'Drzava')
  class(glavni2) <- "data.frame"
  podatki_cluster <- glavni2 %>% select('Drzava', 'SteviloDelovnihUr','BDP', 'pop_est','well_being')
  podatki.norm <- podatki_cluster %>% select(-Drzava) %>% scale()
  rownames(podatki.norm) <- podatki_cluster$Drzava
  k <- kmeans(podatki.norm, 5, nstart=1000)
  skupine <- data.frame(Drzava=podatki_cluster$Drzava, skupina=factor(k$cluster))
  #slika <- tm_shape(merge(evropa1, skupine, by="Drzava"), all.x=TRUE) + tm_polygons("skupina")
  slika <- tm_shape(merge(evropa1, skupine, by="Drzava") %>% set_projection("latlong"),
                    xlim=c(-25, 35), ylim=c(32, 72), all.x=TRUE) + tm_polygons("skupina")
  return(slika)
}
razvrscanje <- razvrscanje()

########## NAPOVEDOVANJE ##########
library(ggplot2)
library(GGally)
library(mgcv)

a_delovne_ure <- A2 %>% select(Leto, SteviloDelovnihUr)
prilagajanje <- lm(data = a_delovne_ure, SteviloDelovnihUr~I(Leto^2) +Leto + 0)
gg <- data.frame(Leto = seq(2019, 2021, 1))
napoved <- mutate(gg, NapovedanoSteviloDelovnihUr=predict(prilagajanje, gg))

graf_regresije <- ggplot(a_delovne_ure, aes(x=Leto, y=SteviloDelovnihUr))+
  geom_point() + geom_smooth(method = lm, formula =y~ x + I(x^2), fullrange = TRUE, color = 'green')+
  geom_point(data = napoved, aes(x= Leto, y=NapovedanoSteviloDelovnihUr), color='red', size = 2) +
  scale_x_continuous(breaks=seq(2009, 2021, 1)) +
  ggtitle('Napoved rasti stevila delovnih v Sloveniji')


library(rms)
n <- 1000 # define sample size
set.seed(17) # so can reproduce the results
age <- rnorm(n, 50, 10)
blood.pressure <- rnorm(n, 120, 15)
cholesterol <- rnorm(n, 200, 25)
sex <- factor(sample(c('female','male'), n,TRUE))
label(age) <- 'Age' # label is in Hmisc
label(cholesterol) <- 'Total Cholesterol'
label(blood.pressure) <- 'Systolic Blood Pressure'
label(sex) <- 'Sex'
units(cholesterol) <- 'mg/dl' # uses units.default in Hmisc
units(blood.pressure) <- 'mmHg'
L <- .4*(sex=='male') + .045*(age-50) +
  (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male'))
y <- ifelse(runif(n) < plogis(L), 1, 0)
cholesterol[1:3] <- NA # 3 missings, at random
ddist <- datadist(age, blood.pressure, cholesterol, sex)
options(datadist='ddist')
f <- lrm(y ~ blood.pressure + sex * (age + rcs(cholesterol,4)),
         x=TRUE, y=TRUE)

cal <- calibrate(f, B=80)
class(cal)

plot(cal,
     xlim=c(0,1.0),
     ylim=c(0,1.0),
     xlab="Predicted Probability of 1y Event-Free",
     ylab="Actual 1y",
     subtitles=TRUE,
     riskdist=FALSE,
     scat1d.opts=list(nhistSpike=200))


[[[[[
   Show that a real r is Solovay random
   iff it is Martin-Lof random.

   An effective covering A_k of k is a function
   of k that enumerates bit strings s,
   which are the initial bits of the covered
   reals.  We assume that no s in A_k is a
   proper prefix or extension of another.
   Thus the measure of the cover A_k of k is
   exactly Sum_{s in A_k} of 2^{-|s|},
   where |s| is the length of the bit string s.
]]]]]

[First part: not M-L random ===> not Solovay random]

[
This is immediate.  We are given coverings A_k such
that real r is in A_k for all k and the measure of A_k <= 2^{-k}.
It follows immediately that r is in infinitely many of the
A_k and the sum of the measure of A_k summed over all k converges.
Thus r is not Solovay random.
]

[Second part: not Solovay random ===> not M-L random]

[
Suppose that a real r is in infinitely many of the
coverings A_n and that Sum_k mu A_n <= 2^c.
Consider B_k defined as the set of all reals that are
in at least 2^{k+c} of the A_n.
Then r is in all of the B_k and the measure of
B_k is <= 2^{-k}, so r is not Martin-Lof random.

Now let's program this!

Instead, I'll program B_k which is the set of all reals
that are in at least k of the A_n.
The proof then results from considering B_{2^{k+c}} .

The main function has two parameters, the stage n, and
the number of times something has to be repeated to
be taken into account.  At stage n, with number
of repeats r, we look at A_0 through A_n for time n,
and put into our condensed result cover only subintervals
that are covered at least r times.

The key auxiliary function given n generates A_0 through A_n for time n,
then expands all intervals to the same max length and counts how
many times each is repeated.  Then it is easy to select those that
are covered the requisite number of times.

First step is to run A_0 through A_n for time n and append the results.
Then we get the max length and do a binary tree walk.  We start with
s and see if it's a prefix of at least r things.
If so, s will be in our result, and we backtrack.
If not, if s has max length, we stop recursion.
Otherwise, we look at s0 and at s1.
And we start with s = nil.
This gives our covering at stage n,
then we have to eliminate overlaps to
get our final result.
]

[
 Test case: A_n is defined to be the set of
 all natural numbers greater than n,
 where k is represented as k 1's followed by a 0.
 Then measure of A_n is 2^{-n-1}, and
 1=10 is in one of the A_n, 2=110 is in two of them,
 3=1110 is in three of them, etc.

 I.e., 1=10 is only in A_0,
       2=110 is only in A_0 & A_1,
       3=1110 is only in A_0 A_1 & A_2, etc.

 In this case the total measure of the A_n is
 1/2 + 1/4 + 1/8 + ... = 1.
 For the proof in general, all we know is that
 this total measure converges to a finite sum, not 1.
]
define (A n) [displays infinite set 1^k 0, k > n]
  let (loop k)
      cons display
         append base10-to-2 - ^ 2 k 1 [2^k - 1 = k 1's]
            cons 0 nil [followed by a 0 bit]
      (loop + k 1)
  (loop + n 1)

define      A
value       (lambda (n) ((' (lambda (loop) (loop (+ n 1)))) ('
             (lambda (k) (cons (display (append (base10-to-2 (
            - (^ 2 k) 1)) (cons 0 nil))) (loop (+ k 1)))))))

[now put together in one list stage n of A_0 through A_n]
define (sum n)
   let (loop k sum)
      if > k n sum
      (loop + k 1
            append caddr try n cons cons "' cons A nil cons k nil nil
                   sum)
   (loop 0 nil)

define      sum
value       (lambda (n) ((' (lambda (loop) (loop 0 nil))) (' (
            lambda (k sum) (if (> k n) sum (loop (+ k 1) (appe
            nd (car (cdr (cdr (try n (cons (cons ' (cons A nil
            )) (cons k nil)) nil)))) sum)))))))

[
 (count x y)
 Now count how many times something x is contained in /
 is an extension of an element of y
]
define (count x y)
   if atom y 0
   if (is-prefix-of? car y x) + 1 (count x cdr y)
   (count x cdr y)

define      count
value       (lambda (x y) (if (atom y) 0 (if (is-prefix-of? (c
            ar y) x) (+ 1 (count x (cdr y))) (count x (cdr y))
            )))

define (is-prefix-of? x y) [is bit string x a prefix of bit string y?]
   if atom x  true
   if atom y  false
   if = car x car y (is-prefix-of? cdr x cdr y)
   false

define      is-prefix-of?
value       (lambda (x y) (if (atom x) true (if (atom y) false
             (if (= (car x) (car y)) (is-prefix-of? (cdr x) (c
            dr y)) false))))

[get maximum length of a list of bit strings]
define (max-length list)
   if atom list   0
   let len1 length car list
   let len2 (max-length cdr list)
   if > len1 len2
      [then] len1
      [else] len2

define      max-length
value       (lambda (list) (if (atom list) 0 ((' (lambda (len1
            ) ((' (lambda (len2) (if (> len1 len2) len1 len2))
            ) (max-length (cdr list))))) (length (car list))))
            )

[
 Now we get what (sum n) covers with multiplicity >= k.
 The measure of the multiplicity k covering will
 be bounded by the finite total measure (here 1) divided by k.
]

define (exceeds-count n k)
   let sum-n (sum n)
   let max-length-sum-n (max-length sum-n)
   (look-at nil)

define      exceeds-count
value       (lambda (n k) ((' (lambda (sum-n) ((' (lambda (max
            -length-sum-n) (look-at nil))) (max-length sum-n))
            )) (sum n)))

[
 This routine has free parameters sum-n, max-length-sum-n, k.
 It gets us the MINIMAL multiplicity >= k covering for (sum n)!
]
define (look-at x) [produces strings x covered with multiplicity >= k in (sum n)]
   if = length x max-length-sum-n
      let n (count x sum-n)
      if >= n k cons x nil [found an interval x that is covered >= k times]
                nil  [didn't find an interval x that is covered >= k times]
   [otherwise break x into subintervals]
   let x0 append x cons 0 nil
   let x1 append x cons 1 nil
   let v  append (look-at x0)
                 (look-at x1)
   [consolidate subintervals?]
   if = v cons x0 cons x1 nil [yes!] cons x nil
          [no, leave covering as is] v

define      look-at
value       (lambda (x) (if (= (length x) max-length-sum-n) ((
            ' (lambda (n) (if (>= n k) (cons x nil) nil))) (co
            unt x sum-n)) ((' (lambda (x0) ((' (lambda (x1) ((
            ' (lambda (v) (if (= v (cons x0 (cons x1 nil))) (c
            ons x nil) v))) (append (look-at x0) (look-at x1))
            ))) (append x (cons 1 nil))))) (append x (cons 0 n
            il)))))

[
 Now we put this all together into B_k, which is
 the limit as n goes to infinity of (exceeds-count n k),
 k fixed, n --> infinity.

 I.e., B_k is what A_0, A_1, A_2, ... covers with
 multiplicity >= k.

 Thus the measure of B_k will be bounded by the
 total measure of the A_n (if it exists) divided by k.

 The main problem is to avoid overlaps in B_k,
 which we do using a completely general algorithm.
]

[list of intervals in covering so far]
[used to avoid overlapping intervals in covering]
define intervals ()

define      intervals
value       ()

define (process-all x) [process list of intervals x]
   if atom x  intervals
   let intervals append (process car x) intervals
   (process-all cdr x)

define      process-all
value       (lambda (x) (if (atom x) intervals ((' (lambda (in
            tervals) (process-all (cdr x)))) (append (process
            (car x)) intervals))))

define (process interval) [process individual interval]
   if (new-interval-covered-by-previous-one? interval intervals)
      [then don't need to repeat it]
      nil
   let holes (new-interval-covers-previous-ones interval intervals)
   if atom holes
      [then interval is fine as is]
      [output it with display!]
      cons display interval nil
   [get max granularity needed]
   let max (max-length holes)
   [convert everything to same granularity]
   let holes (extend-all holes max)
   [and remove overlap]
   [subtract will output residue with display]
   (subtract (extend interval max) holes)

define      process
value       (lambda (interval) (if (new-interval-covered-by-pr
            evious-one? interval intervals) nil ((' (lambda (h
            oles) (if (atom holes) (cons (display interval) ni
            l) ((' (lambda (max) ((' (lambda (holes) (subtract
             (extend interval max) holes))) (extend-all holes
            max)))) (max-length holes))))) (new-interval-cover
            s-previous-ones interval intervals))))

[returns true/false]
define (new-interval-covered-by-previous-one? interval intervals)
   if atom intervals  false
   if (is-prefix-of? car intervals interval)  true
   (new-interval-covered-by-previous-one? interval cdr intervals)

define      new-interval-covered-by-previous-one?
value       (lambda (interval intervals) (if (atom intervals)
            false (if (is-prefix-of? (car intervals) interval)
             true (new-interval-covered-by-previous-one? inter
            val (cdr intervals)))))

[returns set of previous intervals covered by this one]
define (new-interval-covers-previous-ones interval intervals)
   if atom intervals  nil
   if (is-prefix-of? interval car intervals)
      [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals)
      [else]                    (new-interval-covers-previous-ones interval cdr intervals)

define      new-interval-covers-previous-ones
value       (lambda (interval intervals) (if (atom intervals)
            nil (if (is-prefix-of? interval (car intervals)) (
            cons (car intervals) (new-interval-covers-previous
            -ones interval (cdr intervals))) (new-interval-cov
            ers-previous-ones interval (cdr intervals)))))

[produce set of all extensions of a given bit string to a given length]
[(assumed >= to its current length)]
define (extend bit-string len)
   if = len length bit-string
      [has correct length; return singleton set]
      cons bit-string nil
   append (extend append bit-string cons 0 nil len)
          (extend append bit-string cons 1 nil len)

define      extend
value       (lambda (bit-string len) (if (= len (length bit-st
            ring)) (cons bit-string nil) (append (extend (appe
            nd bit-string (cons 0 nil)) len) (extend (append b
            it-string (cons 1 nil)) len))))

[extend all the bit strings in a given list to the same length]
define (extend-all list len)
   if atom list   nil
   append (extend     car list len)
          (extend-all cdr list len)

define      extend-all
value       (lambda (list len) (if (atom list) nil (append (ex
            tend (car list) len) (extend-all (cdr list) len)))
            )

[subtract set of intervals y from set of intervals x]
[output residue with display!]
define (subtract x y)
   if atom x   nil
   if (is-in? car x y)
   [then]                    (subtract cdr x y)
   [else] cons display car x (subtract cdr x y)

define      subtract
value       (lambda (x y) (if (atom x) nil (if (is-in? (car x)
             y) (subtract (cdr x) y) (cons (display (car x)) (
            subtract (cdr x) y)))))

define (is-in? x l) [is x an element of list l?]
   if atom l     false
   if = x car l  true
   (is-in? x cdr l)

define      is-in?
value       (lambda (x l) (if (atom l) false (if (= x (car l))
             true (is-in? x (cdr l)))))

[
 Put it all together---Here is cover B_k,
 which is what is covered by A_0, A_1, A_2, ...
 with multiplicity >= k, and therefore has
 measure bounded by the total measure of the A_n
 divided by k.
 Supposing that this total measure is <= 2^c
 and considering B_{2^{k+c}},
 we see that if a real r is in infinitely many of
 the A_n, then it will be in all of the
 B_{2^{k+c}}, each of which has measure <= 1/2^k.
 Hence if a real r is not Solovay random,
 it follows that it will not be M-L random.
 Here we write the code for B_k, not for
 B_{2^{k+c}}.
]
define (B k)
   let intervals nil
   let (stage n)
      if = n 6 stop! [to stop test run---remove if real thing]
      let exceed-count (exceeds-count n k)
      let intervals (process-all exceed-count)
      (stage + 1 n)
   [go!!!!!]
   (stage 0)

define      B
value       (lambda (k) ((' (lambda (intervals) ((' (lambda (s
            tage) (stage 0))) (' (lambda (n) (if (= n 6) stop!
             ((' (lambda (exceed-count) ((' (lambda (intervals
            ) (stage (+ 1 n)))) (process-all exceed-count))))
            (exceeds-count n k)))))))) nil))

[k = multiplicity = repeated/covered 2 or more times in the A_n]
(B 2)

expression  (B 2)
display     (1 1 0)
display     (1 1 1 0)
display     (1 1 1 1 0)
display     (1 1 1 1 1 0)
display     (1 1 1 1 1 1 0)
display     (1 1 1 1 1 1 1 0)
value       stop!


# Kvantitativni podaci

trajanje.posmatranja <- sum(faithful$eruptions) + sum(faithful$waiting)
trajanje.posmatranja
trajanje.posmatranja <- trajanje.posmatranja / c(60, 60*24, 60*24*7)
trajanje.posmatranja

trajanja <- faithful$eruptions
trajanja
opseg <- range(trajanja)
opseg
# alternativni nacin
opseg <- c( min(trajanja), max(trajanja))
opseg
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 25
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
granice
izrezano <- cut(trajanja, granice, right=FALSE)
izrezano
frekfencija.trajanja <- table(izrezano)
barplot(frekfencija.trajanja)

cekanja <- faithful$waiting
opseg <- c( min(cekanja), max(cekanja))
donja.granica <- 45
gornja.granica <- 100
broj.podintervala <- 125
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(cekanja, granice, right=FALSE)
barplot(table(izrezano))

trajanja <- faithful$eruptions
hist(trajanja, right = FALSE)
hist(trajanja, breaks = 20, right = FALSE)
hist(trajanja,
     breaks = c(1.5, 2, 2.5, 3, 4.7, 5, 5.5),
     right = FALSE)
hist(trajanja,
     breaks = c(1.5, 2, 2.5, 3, 4.7, 5, 5.5),
     main = "Histogram za trajanje",
     xlab = "trajanje erupcije",
     col = c( "purple", "red", "blue"),
     right = FALSE)

cekanja <- faithful$waiting
hist(cekanja,
     breaks = 5,
     col = c( "purple", "red", "blue"),
     right = FALSE)

trajanja <- faithful$eruptions
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 10
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(trajanja, granice, right=FALSE)
frekfencija.trajanja <- table(izrezano)
frekfencija.trajanja
relativna.frekfencija.trajanja <- frekfencija.trajanja / nrow(faithful)
relativna.frekfencija.trajanja
relativna.frekfencija.trajanja <- frekfencija.trajanja / length(trajanja)
relativna.frekfencija.trajanja
relativna.frekfencija.trajanja <- frekfencija.trajanja / sum(frekfencija.trajanja)
relativna.frekfencija.trajanja

trajanja <- faithful$eruptions
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 10
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(trajanja, granice, right=FALSE)
frekfencija.trajanja <- table(izrezano)
frekfencija.trajanja
kumulativna.frekfencija.trajanja <- cumsum(frekfencija.trajanja)
kumulativna.frekfencija.trajanja

cekanja <- faithful$waiting
donja.granica <- 45
gornja.granica <- 100
broj.podintervala <- 15
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
frekfencija.cekanja <- table(cut(cekanja, granice, right=FALSE))
frekfencija.cekanja
kumulativna.frekfencija.cekanja <- cumsum(frekfencija.cekanja)
kumulativna.frekfencija.cekanja

trajanja <- faithful$eruptions
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 10
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(trajanja, granice, right=FALSE)
frekfencija.trajanja <- table(izrezano)
kumulativna.frekfencija.trajanja <- cumsum(frekfencija.trajanja)
kumulativna.frekfencija.trajanja
plot(granice,c(0, kumulativna.frekfencija.trajanja) )
lines(granice,c(0, kumulativna.frekfencija.trajanja) )

cekanja <- faithful$waiting
donja.granica <- 40
gornja.granica <- 110
broj.podintervala <- 45
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
relativna.frekfencija.cekanja <-
  table(cut(cekanja, granice, right=FALSE))/ length(cekanja)
kumulativna.relativna.frekfencija.cekanja <- cumsum(relativna.frekfencija.cekanja)
kumulativna.relativna.frekfencija.cekanja
plot(granice,c(0, kumulativna.relativna.frekfencija.cekanja),
     xlab="cekanje(u minutama)",
     ylab="deo populacije")
lines(granice,c(0, kumulativna.relativna.frekfencija.cekanja) )

donja.granica <- -4
gornja.granica <- 4
broj.tacaka <- 40
x <- seq(donja.granica, gornja.granica,
         by = (gornja.granica-donja.granica)/broj.tacaka )
y <- sin (x)
plot(x,y)
lines(x,y)

trajanja <- faithful$eruptions
cekanja <- faithful$waiting
plot( trajanja, cekanja, xlab="trajanje", ylab= "cekanje")
model <- lm(cekanja ~ trajanja )
abline(model)

trajanja <- faithful$eruptions
cekanja <- faithful$waiting
plot(  cekanja, trajanja, xlab="cekanje", ylab= "trajanje")
model <- lm( trajanja ~ cekanja )
abline(model)


#' Lattice style plot of cohorts by age
#'
#' Each point shows age x vs age y of a cohort. Correlation values also shown. Assumes matrix has ages as columns and that cohorts are in rows.
#' @param matcoh matrix of values with ages as columns and cohorts as rows
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param mytitle title for plot (defaults to blank)
#' @param mylabels optional labels to write in boxes on diagonal (defaults to showing "age-X")
#' @return correlation matrix
#' @export

PlotCoh <- function(matcoh,save.plots,od,plotf,mytitle="",mylabels=NA){
  age <- colnames(matcoh)
  nc <- length(matcoh[1,])
  my.cor <- cor(matcoh,use="pairwise.complete.obs")
  my.cor.round <- round(my.cor,2)
  usr <- par("usr"); on.exit(par(usr))
  par(mfcol=c(nc,nc))
  par(oma=c(0,0,3,1),mar=c(1,1,0,0))
  for (i in 1:nc){
    for (j in nc:1){
      if (i == j){
        plot(1:10,1:10,type='n',axes=F)
        if (is.na(mylabels[1])) text(5,5,paste0("age-",age[i]),cex=1.4)
        if (is.na(mylabels[1])==F) text(5,5,mylabels[i],cex=1.4)
      }
      if (i < j){
        if (!is.na(my.cor[i,j])){
          plot(matcoh[,i],matcoh[,j],axes=F) # make sure have some data to plot
          xx <- matcoh[,i]
          yy <- matcoh[,j]
          my.fit <- lm(yy~xx)
          if (!is.na(my.fit$coefficients[2])) abline(my.fit,col="red")
          xrng <- data.frame(xx = seq(min(xx,na.rm=T),max(xx,na.rm=T),length.out=100))
          ##New  (fix for NaN)
          ss<- summary(my.fit)
          if (is.finite(ss$sigma) ) {
            zz <- predict(my.fit,xrng,interval="confidence")
            lines(xrng[,1],zz[,2],col="blue")
            lines(xrng[,1],zz[,3],col="blue")
          }  #end fix for NaN

          box()
        }
        if (is.na(my.cor[i,j])){  # if not data, just make empty box
          plot(1:10,1:10,type='n',axes=F)
          box()
        }
      }
      if (i > j){
        plot(1:10,1:10,type='n',axes=F)
        txt <- format(my.cor.round[i,j], nsmall=2)
        text(5,5,txt)
        box()
      }
    }
  }
  title(mytitle, outer=T)
  if (save.plots) savePlot(paste0(od,"cohort_age_matrix_",mytitle,".",plotf), type=plotf)
  return(my.cor)
}


# Naive Bayes
library(e1071)
model = m.nb = naiveBayes(form, ds[train, vars])
cl.nb = predict(model, ds[test, vars], type="class")
pr.nb = predict(model, ds[test, vars], type="raw")[,2]

# Decision tree
library(rpart)
model = m.rp = rpart(form, ds[train, vars])
cl.rp = predict(model, ds[test, vars], type="class")
pr.rp = predict(model, ds[test, vars], type="prob")[,2]
train(Species ~., data=dat, method="rpart",trControl=tc,tuneGrid=rpart.grid)

# Regression tree
library(tree)
model = m.rt = rpart(form, ds[train, vars])
cl.rt = predict(model, ds[test, vars], type="class")
pr.rt = predict(model, ds[test, vars], type="prob")[,2]

# Random forest
library(randomForest)
model = m.rf = randomForest(form, ds[train, vars], ntree=100)
cl.rf = predict(model, ds[test, vars], type="class")
pr.rf = predict(model, ds[test, vars], type="prob")[,2]
library(party)
model = m.rf = cforest(form, ds[train, vars], ntree=100)
cl.rf = predict(model, ds[test, vars], type="class")
pr.rf = predict(model, ds[test, vars], type="prob")[,2]

# Weighted subspace rpart
library(wsrpart)
model = m.wsrp = wsrpart(form, ds[train, vars], ntree=10)
cl.wsrp = predict(model, ds[test, vars], type="class")
pr.wsrp = predict(model, ds[test, vars], type="prob")[,2]

# Weighted subspace random forest
library(wsrf)
model = m.wsrf = wsrf(form, ds[train, vars], ntree=10)
cl.wsrf = predict(model, ds[test, vars], type="class")
pr.wsrf = predict(model, ds[test, vars], type="prob")[,2]

# Linear Regression
model = lm(Predictor ~ ., data=dat)
summary(model)
pred = predict(model, dat)
require(caret)
defaultSummary(data.frame(obs=dat, pred=pred))

# Robust linear model
model = rlm(Predictor ~ ., data=dat)
ctrl = trainControl(method="cv", number=10)
trained = train(x=predictor, y=outcome, method="lm", trControl=ctrl)
trained = train(x=predictor, y=outcome, method="rlm", preProcess="pca", trControl=ctrl)
weights = model$w

# Partial least squares
require(pls)
model = pslr(Predictor ~ ., data=dat)
ctrl = trainControl(method="cv", number=10)
trained = train(x=predictor, y=outcome, method="pls", preProcess=c("center", "scale"), trControl=ctrl)

# Ridge regression
model = lm.ridge(x=predictor, y=outcome, data=dat, lambda=0.001)
penalties = data.frame(.lambda = seq(0, .1, length = 15))
model = train(x=predictor, y=outcome, method="ridge", tuneGrid=penalties,
  trControl=ctrl, preProc=c("center", "scale"))

# Multivariate Adaptive Regression Splines
require(earth)
model = earth(x=predictor, y=outcome)
plotmo(model)
trained = train(x=predictor, y=outcome, method="earth",
  tuneGrid=expand.grid(.degree=1:2, .nprune=2:38),
  trControl=trainControl(method="cv"))
varImp(trained)

# Logistic
model = glm(formula, data=dat, family="binomial")

# Generalized linear models
model = glm(formula, data=dat, family="poisson")
plot(model)
require(nlme)
# gls - account for temporal autocorrelation
model = gls(formula, data=dat, family="poisson")
plot(model)

# Time series
decomposed = decompose(dat)
plot(decomposed)

# ARIMA
acf(dat)
pacf(dat)
model = arima(dat, order=c(1,0,0))
predicted = predict(model, n.ahead=100)
plot(dat)
lines(predicted$pred, col="blue")
lines(predicted$pred-predicted$se, col="red")
lines(predicted$pred+predicted$se, col="red")

# Survival
# Kaplan-Meier
model = survfit(Surv(dat$time, dat$event) ~ group)
# Nelson-Aalen
model = survfit(coxph(dat$time, dat$event) ~ group, type="aalen")
# Cox
model = coxph(Surv(time, event) ~ groups, method="breslow")
# Parametric models
model = survreg(Surv(time, event) ~ groups, dist="exponential")
model = survreg(Surv(time, event) ~ groups, dist="weibull")
model = survreg(Surv(time, event) ~ groups, dist="loglogistic")

hazard = -log(model$surv)
plot(model)
summary(model)


#testing a zero one inflated beta regression for relative abundance data from NEON.
rm(list=ls())
library(runjags)

d <- readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/fungal_prior_data.rds')

 y <- d$relEM
x1 <- d$horizon
x2 <- d$doy
x3 <- d$mat30
x4 <- d$map30

# split the data into discrete and continuous components
y.d <- ifelse(y == 1 | y == 0, y, NA)
y.discrete <- ifelse(is.na(y.d), 0, 1)
y.d <- y.d[!is.na(y.d)]
x1.d <- x1[y.discrete == 1]
x2.d <- x2[y.discrete == 1]
n.discrete <- length(y.d)

which.cont <- which(y < 1 & y > 0)
y.c <- ifelse(y < 1 & y > 0, y, NA)
y.c <- y.c[!is.na(y.c)]
n.cont <- length(y.c)
x1.c <- x1[which.cont]
x2.c <- x2[which.cont]
n <- length(y)

jags.model = "
model{
# priors
a0 ~ dnorm(0, .001)
a1 ~ dnorm(0, .001)
b0 ~ dnorm(0, .001)
b1 ~ dnorm(0, .001)
c0 ~ dnorm(0, .001)
c1 ~ dnorm(0, .001)
t0 ~ dnorm(0, .01)
tau <- exp(t0)

# likelihood for alpha - whether the pdf is dominated by discrete or continuous component.
for (i in 1:n){
logit(alpha[i]) <- a0 + a1 * x2[i]
y.discrete[i] ~ dbern(alpha[i])
}

# likelihood for gamma - probability a discrete value is zero or one.
for (i in 1:n.discrete){
y.d[i] ~ dbern(mu1[i])
logit(mu1[i]) <- b0 + b1 * x2.d[i]
}

# likelihood for continuous component - predicted value on interval (0,1)
for (i in 1:n.cont){
y.c[i] ~ dbeta(p[i], q[i])
p[i] <- mu2[i] * tau
q[i] <- (1 - mu2[i]) * tau
logit(mu2[i]) <- c0 + c1 * x2.c[i]
}

for ( i in 1:n){
#get predictions sending all observations of x through both models.
logit(mu1.all[i]) <- b0 + b1 * x2[i]
logit(mu2.all[i]) <- c0 + c1 * x2[i]
p.all[i] <- mu2.all[i] * tau
q.all[i] <- (1 - mu2.all[i]) * tau

#get a predicted y value - use alpha to blend bernoulli and beta models
bern.weight[i] ~ dbern(alpha[i])
beta.weight[i] ~ dbern(1 - alpha[i])
  bern.comp[i] ~ dbern(mu1.all[i])
  beta.comp[i] ~ dbeta(p.all[i], q.all[i])
     pred.y[i] <- bern.weight[i] * bern.comp[i] + beta.weight[i] * beta.comp[i]
}
}
"

jd <- list(x2=x2, y.d=y.d, y.c=y.c, y.discrete = y.discrete,
           n.discrete=n.discrete, n.cont = n.cont,
           x2.d = x2.d, x2.c=x2.c, n=n)

jags.out <- run.jags(jags.model,
                     data=jd,
                     adapt = 1000,
                     burnin = 1000,
                     sample = 2000,
                     n.chains=3,
                     #inits=inits,
                     monitor=c('a0', 'a1','b0','b1','c0','c1','tau','pred.y'))

output <- summary(jags.out)

#grab predicted y values
preds <-    data.frame(output[grep('pred.y', rownames(output)),])
pred.y <- preds$Mean

par(mfrow = c(1,3))
plot(y ~ pred.y)
plot(y ~ x2)
plot(pred.y ~ x2)


x = 3
while(x != 1) {
  cat(x, ",")
  if(x%%2 == 0) {
    x = x/2
  } else {
    x = x*3+1
  }
}
cat(1)


#####################################################################
# Fitting generalized additive models to fraction feeding data
#####################################################################
rm(list=ls())
library(mgcv)

#~~~~~~~~~~
# Load data
#~~~~~~~~~~
load('../Data/FracFeed_Data_TaxonClean.Rdata')
nrow(pfdat)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Summary of variable abbreviations:
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# FSc - Non-empty stomach count
# TSc - Total stomach count
# tWS - Days since winter solstice
# Lat - Latitude
# DR - Diet richness minimum
# TG - Taxon group
# EE - Endo vs. ectotherm
# TA - Time averaging (categorical)
# TAlog - Time averaging (numeric, log10 transformed)
# SA - Space averaging (categorical)
# SAlog - Space averaging - (numeric, log10 transformed)
# BM - Body mass (g)
# BMlog - body mass (log-10 transformed)
# Eco - Ecosystem

#~~~~~~~~~~~~~~~~~~~~~~~
# Transform DietRichness
#~~~~~~~~~~~~~~~~~~~~~~~
pfdat$DRlog <- log10(pfdat$DR)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# General model specifications
# (justified in GAM_robustness)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fam <- quasibinomial(link = 'logit')

# To get actual used sample size (after dropped rows)
# (needed for determining BIC-like gamma penalty)
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Yr) +
    TAlog + SAlog + Eco + EE + TG,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = pfdat,
  na.action = 'na.omit',
  method='REML'
)
gamma <- log(nrow(fit$model)) / 2

#####################################################################
# Main GAM model(s)
#####################################################################
# Fit GAM with TA and SA as factors
fit1.fact<-gam(
  (FSc/TSc) ~
    s(tWS,bs='cc')+
    s(Lat)+
    s(DRlog)+
    s(Yr)+
    TA+SA+
    Eco+EE+TG,
  family=fam,
  weights=TSc,
  knots=list(tWS=c(0,365)),
  data=pfdat,
  na.action='na.omit',
  method='REML',
  gamma = gamma)

summary(fit1.fact)
plot(fit1.fact,
     residuals=F,
     seWithMean=TRUE,
     shade=TRUE,
     rug=TRUE,
     all.terms=TRUE,
     pch='.',
     pages=1)

# Fit GAM with TA and SA as continuous variables
fit1.cont<-gam(
  (FSc/TSc) ~
    s(tWS,bs='cc')+
    s(Lat)+
    s(DRlog)+
    s(Yr)+
    TAlog+SAlog+
    Eco+EE+TG,
  family=fam,
  weights=TSc,
  knots=list(tWS=c(0,365)),
  data=pfdat,
  na.action='na.omit',
  method='REML',
  gamma = gamma)

summary(fit1.cont)
plot(fit1.cont,
     residuals=F,
     seWithMean=TRUE,
     shade=TRUE,
     rug=TRUE,
     all.terms=TRUE,
     pch='.',
     pages=1)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Example odds ratio calculation
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fit<-fit1.cont
exp(cbind("Odds ratio" = coef(fit)[c('TAlog','SAlog')],
          confint.default(fit, c('TAlog','SAlog'), level = 0.95)))
1/exp(cbind("Odds ratio" = coef(fit)[c('SAlog')],
            confint.default(fit, c('SAlog'), level = 0.95)))

#####################################################################
# Secondary model using predator body mass
#####################################################################
# Get sample size first
fit<-gam(
  (FSc/TSc) ~
    s(tWS,bs='cc')+
    s(Lat)+
    s(DRlog)+
    s(Yr)+
    Eco+EE+
    TAlog*SAlog*BMlog,
  family=fam,
  weights=TSc,
  knots=list(tWS=c(0,365)),
  data=pfdat,
  na.action='na.omit',
  method='REML')
gamma <- log(nrow(fit$model)) / 2

fit.BM<-gam(
  (FSc/TSc) ~
    s(tWS,bs='cc')+
    s(Lat)+
    s(DRlog)+
    s(Yr)+
    Eco+EE+
    TAlog*SAlog*BMlog,
  family=fam,
  weights=TSc,
  knots=list(tWS=c(0,365)),
  data=pfdat,
  na.action='na.omit',
  method='REML',
  gamma = gamma)

summary(fit.BM)
plot(fit.BM,
     residuals=F,
     seWithMean=TRUE,
     shade=TRUE,
     rug=TRUE,
     all.terms=TRUE,
     pch='.',
     pages=1)

#####################################################################
# Secondary model model replacing Year for Global Temperature Anomaly
#####################################################################
# Load HadCRUT data
gdat<-read.table('../Data/HadCRUT4_Annual_medians.txt',skip=20)
gdat<-gdat[c(1,2,11,12)]
colnames(gdat)<-c('Year','Anom','l95','u95')

# Merge 'Year' with climate anomaly 'Anom'
pfdat<-merge(pfdat,gdat,by.x='Yr',by.y='Year',all.x=TRUE)

# Get sample size first
fit<-gam(
  (FSc/TSc) ~
    s(tWS,bs='cc')+
    s(Lat)+
    s(DRlog)+
    EE+TA+SA+
    Eco+TG+
    s(Anom),
  family=fam,
  weights=TSc,
  knots=list(tWS=c(0,365)),
  data=pfdat,
  na.action='na.omit',
  method='REML')
gamma <- log(nrow(fit$model)) / 2

fit.TAnom<-gam(
  (FSc/TSc) ~
    s(tWS,bs='cc')+
    s(Lat)+
    s(DRlog)+
    EE+TA+SA+
    Eco+TG+
    s(Anom),
  family=fam,
  weights=TSc,
  knots=list(tWS=c(0,365)),
  data=pfdat,
  na.action='na.omit',
  method='REML',
  gamma = gamma)

summary(fit.TAnom)
plot(fit.TAnom,
     residuals=F,
     seWithMean=TRUE,
     shade=TRUE,
     rug=TRUE,
     all.terms=TRUE,
     pch='.',
     pages=1)

# Residuals of Temp Anomaly model as a function of Year
rfit<-gam(fit.TAnom$residuals~
            s(pfdat[rownames(fit.TAnom$model),'Yr']))

summary(rfit)
plot(rfit,
     residuals=T,
     seWithMean=TRUE,
     shade=TRUE,
     ylab='Residual',
     xlab='Survey year',
     ylim=c(-5,5))
abline(h=0,
       col='grey',
       lty=3)

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


library("mclust")

# path = '/code/scripts/subset_experiments/'

#Synthetic
X <- read.csv(file='../../../data/synthetic.csv',header=FALSE,sep = ',')[,-1]
idx_mat <- read.csv(file='/code/scripts/subset_experiments/idxs_synthetic.csv',header=TRUE, sep=',')
idx_mat <- idx_mat[,2:ncol(idx_mat)]
c <- read.csv(file='../../../data/synthetic.csv',header=FALSE, sep = ',')[,1]+1
modelNames=mclust.options("emModelNames")
ks <- 1:20

run_nums = 10
results <- data.frame(matrix(ncol = 2, nrow = run_nums))
x <- c("ARI","Time")
colnames(results) <- x
n_full <- nrow(X)
n <-  floor(0.8*n_full)
X_full <- X
c_full <- c

for(r in 1:run_nums) {
  print(paste('Run number: ', toString(r)))
  idxs <- idx_mat[,r]
  X <- X_full[idxs[1:n],]
  c <- c_full[idxs[1:n]]

  start_time <- Sys.time()
  plots <- data.frame('x1'=unlist(X[1]),"x2"=unlist(X[2]),"c_true"=c)

  #best bic***************************************
  model <- Mclust(X,ks,verbose=FALSE,modelNames=modelNames)
  best_combo_bic <- model$modelName
  best_g_bic <- model$G
  best_bic <- max(model$BIC,na.rm=T)
  c_hat_bic <- factor(model$classification)

  plots$c_hat_bic = c_hat_bic
  best_ari_bic = adjustedRandIndex(plots$c_true,plots$c_hat_bic)

  results$ARI[r] = best_ari_bic

  end_time <- Sys.time()
  results$Time[r] = end_time-start_time

}
write.csv(results, "/results/mclust_synthetic.csv")

#Breast Cancer
#read mean texture, extreme area, and extreme smoothness
X <- read.csv(file='../../../data/wdbc.data',header=FALSE,sep=',')[,c(4,26,27)]
idx_mat <- read.csv(file='/code/scripts/subset_experiments/idxs_bc.csv', header=TRUE, sep=',')
idx_mat <- idx_mat[,2:ncol(idx_mat)]
c <- read.csv(file='../../../data/wdbc.data',header=FALSE,sep=',')[,2]
modelNames=mclust.options("emModelNames")
ks <- 1:20

run_nums = 10
results <- data.frame(matrix(ncol = 2, nrow = run_nums))
x <- c("ARI","Time")
colnames(results) <- x
n_full <- nrow(X)
n <-  floor(0.8*n_full)
X_full <- X
c_full <- c

for(r in 1:run_nums) {
  print(paste('Run number: ', toString(r)))
  idxs <- idx_mat[,r]
  X <- X_full[idxs[1:n],]
  c <- c_full[idxs[1:n]]

  start_time <- Sys.time()
  plots <- data.frame('x1'=unlist(X[1]),"x2"=unlist(X[2]),"c_true"=c)

  #best bic***************************************
  model <- Mclust(X,ks,verbose=FALSE,modelNames=modelNames)
  best_combo_bic <- model$modelName
  best_g_bic <- model$G
  best_bic <- max(model$BIC,na.rm=T)
  c_hat_bic <- factor(model$classification)

  plots$c_hat_bic = c_hat_bic
  best_ari_bic = adjustedRandIndex(plots$c_true,plots$c_hat_bic)

  results$ARI[r] = best_ari_bic

  end_time <- Sys.time()
  results$Time[r] = end_time-start_time

}
write.csv(results, "/results/mclust_bc.csv")

#Drosophila
X <- read.csv(file='../../../data/embedded_right.csv',header=TRUE,sep=',')
c_file <- read.csv(file='../../../data/classes.csv',header=TRUE,sep=',')
idx_mat <- read.csv(file='/code/scripts/subset_experiments/idxs_drosophila.csv', header=TRUE, sep=',')
idx_mat <- idx_mat[,2:ncol(idx_mat)]
c <- factor(c_file$x)
modelNames=mclust.options("emModelNames")
ks <- 1:20

run_nums = 10
results <- data.frame(matrix(ncol = 2, nrow = run_nums))
x <- c("ARI","Time")
colnames(results) <- x
n_full <- nrow(X)
n <-  floor(0.8*n_full)
X_full <- X
c_full <- c

for(r in 1:run_nums) {
  print(paste('Run number: ', toString(r)))
  idxs = idx_mat[,r]
  X <- X_full[idxs[1:n],]
  c <- c_full[idxs[1:n]]

  start_time <- Sys.time()
  plots <- data.frame('x1'=unlist(X[1]),"x2"=unlist(X[2]),"c_true"=c)

  #best bic***************************************
  model <- Mclust(X,ks,verbose=FALSE,modelNames=modelNames)
  best_combo_bic <- model$modelName
  best_g_bic <- model$G
  best_bic <- max(model$BIC,na.rm=T)
  c_hat_bic <- factor(model$classification)

  plots$c_hat_bic = c_hat_bic
  best_ari_bic = adjustedRandIndex(plots$c_true,plots$c_hat_bic)

  results$ARI[r] = best_ari_bic

  end_time <- Sys.time()
  results$Time[r] = end_time-start_time

}
write.csv(results, "/results/mclust_drosophila.csv")


# this script takes a set of points, in this case bus stops
# and does a centroidal voronoi tesselation weighted by
# those points from an initial uniform random seeding. The effect
# is an even-ish distribution of sample points accross the space.
# My goal is to use these as representative ODs for a travel time
# matrix that effectively samples a whole transit network.

library('deldir')	# voronoi stuff
library('rgdal')	# projections
library('sp') # spatial data types

# SET SOME GLOBAL VARIABLES
STOPS_FILE = '~/buildings.csv'
OUTPUT_FILE = '~/centers.csv'
FROM_EPSG = CRS('+init=epsg:4326')
TO_EPSG = CRS('+init=epsg:32616')
MAX_ITER = 75
NUM_SEED_POINTS = 700

# function copied from http://carsonfarmer.com/2009/09/voronoi-polygons-with-r/
voronoipolygons = function(layer,bounding_box) {
    crds = layer@coords
    z = deldir(crds[,1], crds[,2],rw=bounding_box)
    w = tile.list(z)
    polys = vector(mode='list', length=length(w))
    for (i in seq(along=polys)) {
        pcrds = cbind(w[[i]]$x, w[[i]]$y)
        pcrds = rbind(pcrds, pcrds[1,])
        polys[[i]] = Polygons(list(Polygon(pcrds)), ID=as.character(i))
    }
    SP = SpatialPolygons(polys,proj4string=TO_EPSG)
    voronoi = SpatialPolygonsDataFrame(SP, data=data.frame(x=crds[,1],
        y=crds[,2], row.names=sapply(slot(SP, 'polygons'),
        function(x) slot(x, 'ID'))))
}

# get bus stops from the GTFS stops.txt CSV file
bus_stops = read.csv(STOPS_FILE)
# reinterpret as spatial data
coordinates(bus_stops) <- c('lon','lat')
proj4string(bus_stops) <- FROM_EPSG
# reproject to local UTM
bus_stops <- spTransform(bus_stops,TO_EPSG)
bus_stops$x = coordinates(bus_stops)[,1]
bus_stops$y = coordinates(bus_stops)[,2]

# define a reasonable, simple, bounding box for the polygon to be tesselated
xmin = min(bus_stops$x) - 1000 # meters
xmax = max(bus_stops$x) + 1000
ymin = min(bus_stops$y) - 1000
ymax = max(bus_stops$y) + 1000
boundingBox = c(xmin,xmax,ymin,ymax)

# randomly select seed points from bus stops
# (bus stop density is a good initial guide)
seed_points = bus_stops[sample(nrow(bus_stops),NUM_SEED_POINTS),c('x','y')]
# do the initial tesselation
tiles = voronoipolygons(seed_points,boundingBox)
# iterate voronoi calculation with new centroids
for(i in 1:MAX_ITER){
	# if past the first iteration,
	prev_points = seed_points
	# calculate new centroids weighted by the bus stop locations
	meanxy = over(tiles,bus_stops[,c('x','y')],fn=mean) # unweighted centroid of points in tile
	# eliminate zones/points with no stops (zero weight)
	meanxy = meanxy[!is.na(meanxy$x),]
	# spatialize the points
	seed_points = SpatialPoints(meanxy)
	# check for convergence
	if ( length(prev_points) == length(seed_points) ) {
		if ( all(prev_points$x==seed_points$x) & all(prev_points$y==seed_points$y) ) {
			print('convergence achieved')
			break
		}
	}
	# not converged so print status
	print(paste(length(seed_points),'points on iter',i))
	# calculate new tiles
	tiles = voronoipolygons(seed_points,boundingBox)
	# plot iterations?
	png(paste0('~/temp/',i,'.png'),width=1000,height=800)
		par(mar=rep(1, 4))
		# plot tiles
		plot(tiles, axes=FALSE, ann=FALSE,border=rgb(0,0,0,0.5))
		# plot bus stops
		points(bus_stops,pch=20,col=rgb(1,0,0,0.3),cex=0.5)
		# plot points
		points(seed_points,pch=20,col='black')
	dev.off()
}
# get lat,lons along with projected x,y
proj4string(seed_points) <- TO_EPSG
unprojected <- spTransform(seed_points,FROM_EPSG)
seed_points$lon = coordinates(unprojected)[,1]
seed_points$lat = coordinates(unprojected)[,2]
#output to CSV
write.csv(seed_points,OUTPUT_FILE)


choicesGlob = c("p")
choicesNamesGlob = c("\\\\p")
choicesGlob <- setNames(choicesGlob, choicesNamesGlob)

choicesIS = c("alpha","iy","ir","id","cpi","bari","g","t")
choicesNamesIS = c("\\\\\\alpha",
                   "\\\\I_y",
                   "\\\\I_r",
                   "\\\\I_d",
                   "\\\\C_{\\pi}",
                   "\\\\\\bar{I}",
                   "\\\\g",
                   "\\\\t")
choicesIS <- setNames(choicesIS, choicesNamesIS)

choicesLM = c("ly","lr","ystar","Ms")
choicesNamesLM = c("\\\\L_y",
                   "\\\\L_r",
                   "\\\\y*",
                   "\\\\M^s")
choicesLM <- setNames(choicesLM, choicesNamesLM)

shock_params <- function(vars,i){
  shock <- fluidRow(
              column(5,
                     selectizeInput(paste0("shocked_var_",i),"Var. choquée:",
                          vars,
                          options = list(render = I("
                                          {
                                            item: function(item, escape) {
                                                    var html = katex.renderToString(item.label);
                                                    return '
' + html + '
';
                                                  },
                                            option: function(item, escape) {
                                                      var html = katex.renderToString(item.label);
                                                      return '
' + html + '
';
                                                    }
                                          }"))
                          )
                  ),
                  column(5,
                         numericInput(paste0("new_value_",i),"Nouvelle Valeur", value = NULL)
                  )
                )

  return(shock)
}

IS_shock <- selectizeInput("shocked_var_IS","Variable choquée (IS):",
                           choicesIS,
                           options = list(render = I("
                                          {
                                            item: function(item, escape) {
                                                    var html = katex.renderToString(item.label);
                                                    return '
' + html + '
';
                                                  },
                                            option: function(item, escape) {
                                                      var html = katex.renderToString(item.label);
                                                      return '
' + html + '
';
                                                    }
                                          }"))
                          )

LM_shock <- selectizeInput("shocked_var_LM","Variable choquée (LM):",
                           choicesLM,
                           options = list(render = I("
                                          {
                                            item: function(item, escape) {
                                                    var html = katex.renderToString(item.label);
                                                    return '
' + html + '
';
                                                  },
                                            option: function(item, escape) {
                                                      var html = katex.renderToString(item.label);
                                                      return '
' + html + '
';
                                                    }
                                          }"))
)

glob_params <- fluidRow(
  column(3,
         numericInput("p","\\(p\\)",0,1000,value = 100,step=1)
  ),
  column(3),
  column(6,
          sliderInput("ymax","y max", 100,10000,2500,step = 100)
  )
)

ui_LM_params1 <- fluidRow(
  column(3,
         numericInput("ly","\\(L_y\\)",0,1,value = 0.5,step=0.05)
  ),
  column(3,
         numericInput("lr","\\(L_r\\)",-1000,0,value = -100,step=10)
  ),
  column(3,
         numericInput("Ms","\\(M^s\\)", 0,4000,value=300,step = 100)
  ),
  column(3,
         numericInput("rmin", "\\(r_{min}\\)", -10,10,value=1,step=0.5)
  )
)

ui_IS_params1 <- fluidRow(
  column(3,
         numericInput("alpha","\\(\\alpha\\)",0,1,value = 0.6,step=0.05)
  ),
  column(3,
         numericInput("iy","\\(I_y\\)",0,1,value = 0.05,step=0.05)
  ),
  column(3,
         numericInput("ir","\\(I_r\\)",-1000,1000,value = -100,step=10)
  ),
  column(3,
         numericInput("id","\\(I_D\\)",-1000,1000,value = -0.1,step=0.01)
  )
)

ui_IS_params2 <- fluidRow(
  column(3,
         numericInput("cpi","\\(C_{\\pi}\\)",0,1000,value = 500,step=10)
  ),
  column(3,
         numericInput("bari","\\(\\bar{I}\\)",0,1000,value = 400,step=10)
  ),
  column(3,
         numericInput("g","\\(g\\)",0,1000,value = 350,step=10)
  ),
  column(3,
         numericInput("t","\\(t\\)",0,1000,value = 0,step=10)
  ),
  column(3, class = "collapse",
         numericInput("D","\\(D\\)",0,1000,value = 2000,step=10)
  )
)

ui_BB_params <- fluidRow(
  column(4,
         numericInput("by","\\(B_y\\)",0,1,value = 0.05,step = 0.05)
  ),
  column(4,
         numericInput("br","\\(B_r\\)",0,10,value = 1)
  ),
  column(4,
         numericInput("max_price","Val. Faciale",0,1,value = 100)
  )
)

ui_LabM_params <- fluidRow(
  column(4,
        numericInput("W","\\(\\bar{W}\\)",0,100,value = 40,step=0.5)
  ),
  column(4,
         numericInput("sal_res","Sal. réserve",0,100,value = 6)
  )
)


 ZPTSVX Example Program Results

 Solution(s)
                    1                 2
 1  ( 2.0000, 1.0000) (-3.0000,-2.0000)
 2  ( 1.0000, 1.0000) ( 1.0000, 1.0000)
 3  ( 1.0000,-2.0000) ( 1.0000,-2.0000)
 4  ( 1.0000,-1.0000) ( 2.0000, 1.0000)

 Backward errors (machine-dependent)
     0.0E+00    0.0E+00

 Estimated forward error bounds (machine-dependent)
     9.0E-12    6.1E-12

 Estimate of reciprocal condition number
     1.1E-04


(Intercept)           x      I(x^2)
          1           2           3


#kvalitativni podaci
painters

prosecna.ocena.kompozicija <-  mean(painters$Composition)
prosecna.ocena.kompozicija

prosecna.ocena.crtanje <-  mean(painters$Drawing)
prosecna.ocena.crtanje

prosecna.ocena.boja <-  mean(painters$Colour)
prosecna.ocena.boja

prosecna.ocena.izrazajnost <-  mean(painters$Expression)
prosecna.ocena.izrazajnost

izrazajnosti <- painters$Expression
izrazajnosti
izrazajnosti.frekfencija <- table(izrazajnosti)
izrazajnosti.frekfencija

skole <- painters$School
skole
skole.frekfencija <- table(skole)
skole.frekfencija

skole <- painters$School
skole
skole.relativna.frekfencija <- table(skole) / length(skole)
skole.relativna.frekfencija

skole <- painters$School
skole
skole.frekfencija.procenat <- table(skole) / length(skole) * 100
skole.frekfencija.procenat

skole <- painters$School
skole
skole.frekfencija.procenat <- table(skole) / length(skole) * 100
cbind(skole.frekfencija.procenat)

skole <- painters$School
skole
skole.frekfencija.procenat <- table(skole) / length(skole) * 100
skole.frekfencija.procenat
staro.podesavanje <- options(digits=3)
skole.frekfencija.procenat
options(staro.podesavanje)

skole <- painters$School
skole
skole.frekfencija <- table(skole)
barplot( skole.frekfencija)

skole <- painters$School
skole
skole.frekfencija <- table(skole)
boje <- c("red","green", "yellow", "purple", "violet")
barplot( skole.frekfencija,
         col = boje)

ocene.kompozicija <- painters$Composition
ocene.kompozicija.frekfencija <- table (ocene.kompozicija)
boje <- c("red","green", "yellow", "purple", "violet")
barplot(ocene.kompozicija.frekfencija, col = boje)

barplot( table(painters$Composition),
        col = c("red","green", "yellow", "purple", "violet")
        )

skole <- painters$School
skole
skole.frekfencija <- table(skole)
pie( skole.frekfencija)

pie( table(painters$School))

pie( table(painters$School),
     col = c("red","green", "yellow", "purple", "violet"))

prosecna.ocena.kompozicija.svi <-  mean(painters$Composition)
prosecna.ocena.kompozicija.svi

# prosecna.ocena.kompozicija.skola.A ???
filter.skola.A <- painters$School == "A"
slikari.skola.A <- painters[filter.skola.A,]
ocena.kompozicija.skola.A <- slikari.skola.A$Composition
prosecna.ocena.kompozicija.skola.A <- mean(ocena.kompozicija.skola.A)
prosecna.ocena.kompozicija.skola.A

prosecna.ocena.kompozicija.skola.A <-
  mean(painters[painters$School == "A",]$Composition)
prosecna.ocena.kompozicija.skola.A

prosecna.ocena.kompozicija.skola.B <-
  mean(painters[painters$School == "B",]$Composition)
prosecna.ocena.kompozicija.skola.B

sve.prosecne.ocene.kompozicija <-
  tapply(painters$Composition, painters$School, mean)
sve.prosecne.ocene.kompozicija

sve.prosecne.ocene.boja <-
  tapply(painters$Colour, painters$School, mean)
sve.prosecne.ocene.boja


# portfolio.r
#
# Functions for portfolio analysis
# to be used in Introduction to Computational Finance & Financial Econometrics
# last updated: November 7, 2000 by Eric Zivot
#               Oct 15, 2003 by Tim Hesterberg
#               November 18, 2003 by Eric Zivot
#               November 9, 2004 by Eric Zivot
#		            November 9, 2008 by Eric Zivot
#               August 11, 2011 by Eric Zivot
#
# Functions:
#	1. efficient.portfolio			compute minimum variance portfolio
#							                subject to target return
#	2. globalMin.portfolio			compute global minimum variance portfolio
#	3. tangency.portfolio			  compute tangency portfolio
#	4. efficient.frontier			  compute Markowitz bullet
#	5. getPortfolio					    create portfolio object
#

getPortfolio <-
function(er, cov.mat, weights)
{
	# contruct portfolio object
	#
	# inputs:
	# er				   N x 1 vector of expected returns
	# cov.mat  		 N x N covariance matrix of returns
	# weights			 N x 1 vector of portfolio weights
	#
	# output is portfolio object with the following elements
	# call				original function call
	# er				  portfolio expected return
	# sd				  portfolio standard deviation
	# weights			N x 1 vector of portfolio weights
	#
	call <- match.call()

	#
	# check for valid inputs
	#
	asset.names <- names(er)
	weights <- as.vector(weights)
	names(weights) = names(er)
  	er <- as.vector(er)					# assign names if none exist
	if(length(er) != length(weights))
		stop("dimensions of er and weights do not match")
 	cov.mat <- as.matrix(cov.mat)
	if(length(er) != nrow(cov.mat))
		stop("dimensions of er and cov.mat do not match")
	if(any(diag(chol(cov.mat)) <= 0))
		stop("Covariance matrix not positive definite")

	#
	# create portfolio
	#
	er.port <- crossprod(er,weights)
	sd.port <- sqrt(weights %*% cov.mat %*% weights)
	ans <- list("call" = call,
	      "er" = as.vector(er.port),
	      "sd" = as.vector(sd.port),
	      "weights" = weights)
	class(ans) <- "portfolio"
	ans
}

efficient.portfolio <-
function(er, cov.mat, target.return)
{
  # compute minimum variance portfolio subject to target return
  #
  # inputs:
  # er					    N x 1 vector of expected returns
  # cov.mat  			  N x N covariance matrix of returns
  # target.return	  scalar, target expected return
  #
  # output is portfolio object with the following elements
  # call				    original function call
  # er					    portfolio expected return
  # sd					    portfolio standard deviation
  # weights			    N x 1 vector of portfolio weights
  #
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  er <- as.vector(er)					# assign names if none exist
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")
  # remark: could use generalized inverse if cov.mat is positive semidefinite

  #
  # compute efficient portfolio
  #
  ones <- rep(1, length(er))
  top <- cbind(2*cov.mat, er, ones)
  bot <- cbind(rbind(er, ones), matrix(0,2,2))
  A <- rbind(top, bot)
  b.target <- as.matrix(c(rep(0, length(er)), target.return, 1))
  x <- solve(A, b.target)
  w <- x[1:length(er)]
  names(w) <- asset.names

  #
  # compute portfolio expected returns and variance
  #
  er.port <- crossprod(er,w)
  sd.port <- sqrt(w %*% cov.mat %*% w)
  ans <- list("call" = call,
	      "er" = as.vector(er.port),
	      "sd" = as.vector(sd.port),
	      "weights" = w)
  class(ans) <- "portfolio"
  ans
}

globalMin.portfolio <-
function(er, cov.mat)
{
  # Compute global minimum variance portfolio
  #
  # inputs:
  # er				N x 1 vector of expected returns
  # cov.mat		N x N return covariance matrix
  #
  # output is portfolio object with the following elements
  # call			original function call
  # er				portfolio expected return
  # sd				portfolio standard deviation
  # weights		N x 1 vector of portfolio weights
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  er <- as.vector(er)					# assign names if none exist
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")
  # remark: could use generalized inverse if cov.mat is positive semi-definite

  #
  # compute global minimum portfolio
  #
  cov.mat.inv <- solve(cov.mat)
  one.vec <- rep(1,length(er))
#  w.gmin <- cov.mat.inv %*% one.vec/as.vector(one.vec %*% cov.mat.inv %*% one.vec)
  w.gmin <- rowSums(cov.mat.inv) / sum(cov.mat.inv)
  w.gmin <- as.vector(w.gmin)
  names(w.gmin) <- asset.names
  er.gmin <- crossprod(w.gmin,er)
  sd.gmin <- sqrt(t(w.gmin) %*% cov.mat %*% w.gmin)
  gmin.port <- list("call" = call,
		    "er" = as.vector(er.gmin),
		    "sd" = as.vector(sd.gmin),
		    "weights" = w.gmin)
  class(gmin.port) <- "portfolio"
  gmin.port
}

tangency.portfolio <-
function(er,cov.mat,risk.free)
{
  # compute tangency portfolio
  #
  # inputs:
  # er				   N x 1 vector of expected returns
  # cov.mat		   N x N return covariance matrix
  # risk.free		 scalar, risk-free rate
  #
  # output is portfolio object with the following elements
  # call			  captures function call
  # er				  portfolio expected return
  # sd				  portfolio standard deviation
  # weights		 N x 1 vector of portfolio weights
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  if(risk.free < 0)
    stop("Risk-free rate must be positive")
  er <- as.vector(er)
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")
  # remark: could use generalized inverse if cov.mat is positive semi-definite

  #
  # compute global minimum variance portfolio
  #
  gmin.port <- globalMin.portfolio(er,cov.mat)
  if(gmin.port$er < risk.free)
    stop("Risk-free rate greater than avg return on global minimum variance portfolio")

  #
  # compute tangency portfolio
  #
  cov.mat.inv <- solve(cov.mat)
  w.t <- cov.mat.inv %*% (er - risk.free) # tangency portfolio
  w.t <- as.vector(w.t/sum(w.t))	# normalize weights
  names(w.t) <- asset.names
  er.t <- crossprod(w.t,er)
  sd.t <- sqrt(t(w.t) %*% cov.mat %*% w.t)
  tan.port <- list("call" = call,
		   "er" = as.vector(er.t),
		   "sd" = as.vector(sd.t),
		   "weights" = w.t)
  class(tan.port) <- "portfolio"
  tan.port
}

efficient.frontier <-
function(er, cov.mat, nport=20, alpha.min=-0.5, alpha.max=1.5)
{
  # Compute efficient frontier with no short-sales constraints
  #
  # inputs:
  # er			  N x 1 vector of expected returns
  # cov.mat	  N x N return covariance matrix
  # nport		  scalar, number of efficient portfolios to compute
  #
  # output is a Markowitz object with the following elements
  # call		  captures function call
  # er			  nport x 1 vector of expected returns on efficient porfolios
  # sd			  nport x 1 vector of std deviations on efficient portfolios
  # weights 	nport x N matrix of weights on efficient portfolios
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  er <- as.vector(er)
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")

  #
  # create portfolio names
  #
  port.names <- rep("port",nport)
  ns <- seq(1,nport)
  port.names <- paste(port.names,ns)

  #
  # compute global minimum variance portfolio
  #
  cov.mat.inv <- solve(cov.mat)
  one.vec <- rep(1,length(er))
  port.gmin <- globalMin.portfolio(er,cov.mat)
  w.gmin <- port.gmin$weights

  #
  # compute efficient frontier as convex combinations of two efficient portfolios
  # 1st efficient port: global min var portfolio
  # 2nd efficient port: min var port with ER = max of ER for all assets
  #
  er.max <- max(er)
  port.max <- efficient.portfolio(er,cov.mat,er.max)
  w.max <- port.max$weights
  a <- seq(from=alpha.min,to=alpha.max,length=nport)			# convex combinations
  we.mat <- a %o% w.gmin + (1-a) %o% w.max	# rows are efficient portfolios
  er.e <- we.mat %*% er							# expected returns of efficient portfolios
  er.e <- as.vector(er.e)
  names(er.e) <- port.names
  cov.e <- we.mat %*% cov.mat %*% t(we.mat) # cov mat of efficient portfolios
  sd.e <- sqrt(diag(cov.e))					# std devs of efficient portfolios
  sd.e <- as.vector(sd.e)
  names(sd.e) <- port.names
  dimnames(we.mat) <- list(port.names,asset.names)

  #
  # summarize results
  #
  ans <- list("call" = call,
	      "er" = er.e,
	      "sd" = sd.e,
	      "weights" = we.mat)
  class(ans) <- "Markowitz"
  ans
}

#
# print method for portfolio object
print.portfolio <- function(x, ...)
{
  cat("Call:\n")
  print(x$call, ...)
  cat("\nPortfolio expected return:    ", format(x$er, ...), "\n")
  cat("Portfolio standard deviation: ", format(x$sd, ...), "\n")
  cat("Portfolio weights:\n")
  print(round(x$weights,4), ...)
  invisible(x)
}

#
# summary method for portfolio object
summary.portfolio <- function(object, risk.free=NULL, ...)
# risk.free			risk-free rate. If not null then
#				compute and print Sharpe ratio
#
{
  cat("Call:\n")
  print(object$call)
  cat("\nPortfolio expected return:    ", format(object$er, ...), "\n")
  cat(  "Portfolio standard deviation: ", format(object$sd, ...), "\n")
  if(!is.null(risk.free)) {
    SharpeRatio <- (object$er - risk.free)/object$sd
    cat("Portfolio Sharpe Ratio:       ", format(SharpeRatio), "\n")
  }
  cat("Portfolio weights:\n")
  print(round(object$weights,4), ...)
  invisible(object)
}
# hard-coded 4 digits; prefer to let user control, via ... or other argument

#
# plot method for portfolio object
plot.portfolio <- function(object, ...)
{
  asset.names <- names(object$weights)
  barplot(object$weights, names=asset.names,
	  xlab="Assets", ylab="Weight", main="Portfolio Weights", ...)
  invisible()
}

#
# print method for Markowitz object
print.Markowitz <- function(x, ...)
{
  cat("Call:\n")
  print(x$call)
  xx <- rbind(x$er,x$sd)
  dimnames(xx)[[1]] <- c("ER","SD")
  cat("\nFrontier portfolios' expected returns and standard deviations\n")
  print(round(xx,4), ...)
  invisible(x)
}
# hard-coded 4, should let user control

#
# summary method for Markowitz object
summary.Markowitz <- function(object, risk.free=NULL)
{
  call <- object$call
  asset.names <- colnames(object$weights)
  port.names <- rownames(object$weights)
  if(!is.null(risk.free)) {
    # compute efficient portfolios with a risk-free asset
    nport <- length(object$er)
    sd.max <- object$sd[1]
    sd.e <- seq(from=0,to=sd.max,length=nport)
    names(sd.e) <- port.names

    #
    # get original er and cov.mat data from call
    er <- eval(object$call$er)
    cov.mat <- eval(object$call$cov.mat)

    #
    # compute tangency portfolio
    tan.port <- tangency.portfolio(er,cov.mat,risk.free)
    x.t <- sd.e/tan.port$sd		# weights in tangency port
    rf <- 1 - x.t			# weights in t-bills
    er.e <- risk.free + x.t*(tan.port$er - risk.free)
    names(er.e) <- port.names
    we.mat <- x.t %o% tan.port$weights	# rows are efficient portfolios
    dimnames(we.mat) <- list(port.names, asset.names)
    we.mat <- cbind(rf,we.mat)
  }
  else {
    er.e <- object$er
    sd.e <- object$sd
    we.mat <- object$weights
  }
  ans <- list("call" = call,
	      "er"=er.e,
	      "sd"=sd.e,
	      "weights"=we.mat)
  class(ans) <- "summary.Markowitz"
  ans
}

print.summary.Markowitz <- function(x, ...)
{
	xx <- rbind(x$er,x$sd)
	port.names <- names(x$er)
	asset.names <- colnames(x$weights)
	dimnames(xx)[[1]] <- c("ER","SD")
	cat("Frontier portfolios' expected returns and standard deviations\n")
	print(round(xx,4), ...)
	cat("\nPortfolio weights:\n")
	print(round(x$weights,4), ...)
	invisible(x)
}
# hard-coded 4, should let user control

#
# plot efficient frontier
#
# things to add: plot original assets with names
# tangency portfolio
# global min portfolio
# risk free asset and line connecting rf to tangency portfolio
#
plot.Markowitz <- function(object, plot.assets=FALSE, ...)
# plot.assets		logical. If true then plot asset sd and er
{
  if (!plot.assets) {
     y.lim=c(0,max(object$er))
     x.lim=c(0,max(object$sd))
     plot(object$sd,object$er,type="b",xlim=x.lim, ylim=y.lim,
          xlab="Portfolio SD", ylab="Portfolio ER",
          main="Efficient Frontier", ...)
     }
  else {
	  call = object$call
	  mu.vals = eval(call$er)
	  sd.vals = sqrt( diag( eval(call$cov.mat) ) )
	  y.lim = range(c(0,mu.vals,object$er))
	  x.lim = range(c(0,sd.vals,object$sd))
	  plot(object$sd,object$er,type="b", xlim=x.lim, ylim=y.lim,
          xlab="Portfolio SD", ylab="Portfolio ER",
          main="Efficient Frontier", ...)
        text(sd.vals, mu.vals, labels=names(mu.vals))
  }
  invisible()
}


#' @title Compute turnover components.
#'
#' @description Compute the a, b, c turnover components. Given two vectors, v1
#'   and v2, of species names or interactions, component "a" is the number of
#'   elements (species or interactions) present in both vectors v1 and v2, "b"
#'   is the number of elements present only in v1 and "c" only in v2. See the
#'   section "Beta diversity estimates" in  Novotny, V. (2009). Beta diversity
#'   of plant–insect food webs in tropical forests: a conceptual framework.
#'   Insect Conservation and Diversity, 2(1), 5-9.
#'
#' @param vect A list of two vectors with species names or interactions.
#'
#' @return A list with the 3 components a, b, c. The elements of the list are
#'   numeric vectors of length 1.
#'
#' @examples
#'
#' library(bootdissim)
#' library(bipartite)
#'
#' net1 <- reshape_net(vazarr, seed = 1)
#' net2 <- reshape_net(vazcer, seed = 1)
#' vect <- get_interactions(net1, net2)
#' abc <- get_abc(vect)
#'
#' @export
#'
#' @md
get_abc <- function(vect){
  v1 <- vect[[1]]
  v2 <- vect[[2]]

  # Fast testing if elements of a vector are present in a second vector. The
  # index position doesn't matter. What matters is if for a given element from
  # the first vector, the match() function returns a value of zero or above
  # zero. A zero indicates that the respective element from the first vector
  # doesn't exist in the second vector. A positive value indicates that the
  # respective element from the first vector exists in the second vector. The
  # value itself indicates the first position where that element is encountered
  # in the second vector, but this information is not important for our
  # purposes. We used match() function because is fast.
  match_v1_in_v2 <- match(v1, v2, nomatch = 0)
  match_v2_in_v1 <- match(v2, v1, nomatch = 0)

  # Get the a, b and c components.

  # "a" is the number of elements present in both vectors v1 and v2
  a <- sum(match_v2_in_v1 > 0) # same as sum(match_v1_in_v2 > 0)
  # "b" is the number of elements present only in v1
  b <- sum(!(match_v1_in_v2 > 0))
  # "c" is the number of elements present only in v2
  c <- sum(!(match_v2_in_v1 > 0))

  return(list(a = a, b = b, c = c))
}

#' @title Compute dissimilarity index.
#'
#' @description Compute various dissimilarity indices.
#'
#' @param abc A list with the turnover components a, b and c.
#'
#' @param index The name of the desired index, e.g.: "whittaker", "jaccard",
#'   "sorensen". Character type.
#'
#' @return A dissimilarity index. Numeric vector of length one.
#'
#' @examples
#'
#' library(bootdissim)
#' library(bipartite)
#'
#' net1 <- reshape_net(vazarr, seed = 1)
#' net2 <- reshape_net(vazcer, seed = 1)
#' vect <- get_interactions(net1, net2)
#' abc <- get_abc(vect)
#' get_beta(abc, index = "whittaker")
#' get_beta(abc, index = "jaccard")
#' get_beta(abc, index = "sorensen")
#'
#' @export
#'
#' @md

get_beta <- function(abc, index){
  a <- abc[["a"]]
  b <- abc[["b"]]
  c <- abc[["c"]]

  switch(index,
         whittaker = 2*(a+b+c)/(2*a+b+c) - 1, # sometimes written as ( (a + b + c) / ((2*a + b + c)/2) ) - 1
         jaccard = a/(a+b+c),
         sorensen = (2*a)/(2*a+b+c),
         stop("Your index is not recognised or available. Typo? Check help for options.",
              call. = FALSE))
  # Switch is generally faster than if statements.
  # https://stackoverflow.com/a/7826352/5193830
}


suppressMessages(library(stats))
suppressMessages(library(craze))

if (fml_mpi()){
  comm.set.seed(1234)
} else {
  set.seed(1234)
}

n = 5
x = crossprod(matrix(runif(n*n), n))
y = matrix(1.0:5.0, n, 1)
x_fml = fmlmat(x)

test = as.matrix(chol(x_fml))
truth = chol(x)
stopifnot(all.equal(test, truth))


# Implementation of the Douglas-Peucker algorithm for line thinning
# http://en.wikipedia.org/wiki/Ramer-Douglas-Peucker_algorithm
simplify_rec <- function(points, tol = 0.01) {
  n <- nrow(points)
  if (n <= 2) return() # c(1, n))
  dist <- with(points, point_line_dist(x, y, x[1], y[1], x[n], y[n]))

  if (max(dist, na.rm = T) > tol) {
    furthest <- which.max(dist)
    c(
      simplify_rec(points[1:(furthest - 1), ], tol),
      furthest,
      simplify_rec(points[(furthest + 1):n, ], tol) + furthest
    )
  } else {
    c()
  }
}

# From http://mathworld.wolfram.com/Point-LineDistance2-Dimensional.html
point_line_dist <- function(px, py, lx_1, ly_1, lx_2, ly_2) {
  abs((lx_2 - lx_1) * (ly_1 - py) - (lx_1 - px) * (ly_2 - ly_1)) /
    sqrt((lx_2 - lx_1) ^ 2 + (ly_2 - ly_1) ^ 2)
}

# Precompute all tolerances so that we can post-select quickly
compute_tol <- function(points, offset = 0) {
  n <- nrow(points)
  if (n <= 2) {
    c()
  } else if (n == 3) {
    with(points,
      point_line_dist(long[2], lat[2], long[1], lat[1], long[3], lat[3]))
  } else {
    dist <- with(points,
      point_line_dist(long[2:(n-1)], lat[2:(n-1)], long[1], lat[1], long[n], lat[n])
    )

    furthest <- which.max(dist)
    if (length(furthest) == 0) browser()
    c(
      compute_tol(points[1:(furthest + 1), ], offset),
      dist[furthest],
      compute_tol(points[(furthest + 1):n, ], furthest + offset)
    )
  }
}


x <- c(1.2,1.3,1.4,4,10,14.2,14.3,15)
cluster.count <- function(x, threshold){

  x1 = c(x,10^10) # adding 10 to the end of x, so that x2 can be subtracted from it
  x2 = c(0,x) # adding 0 to the beginning of x, so that x1 can be subtracted from x1

  x1 = as.numeric(as.character(unlist(x1))) #converting x1 into a vector
  x2 = as.numeric(as.character(unlist(x2))) #converting x2 into a vector

  result1 = (x1-x2)
  result1 = as.numeric(result1 < threshold)  #check values that are less than the threshold

  result2 = c(result1[-1], 10)

  result3 = result1 - result2

  result3 = c(result3[-(length(result3))])
  print(result3)

  result3 = replace(result3,result3 == -1, 2)
  result3 = replace(result3,result3 ==1, -1)
  idx=result3==-1
  cs=cumsum(result1)
  print(result3)
  print(cs[idx]+1)

  number_of_clusters = sum(result3)

  print('number_of_clusters:')
  return( number_of_clusters)
}

cluster.count(x, threshold = 0.5)


##### Chapter 9: Clustering with k-means -------------------

# 군집화는 데이터를 cluster로 자동 분리하는 머신 러닝 작업이다.
# 찾고 있는 것이 무엇인지 모르기 때문에, 군집화는 예측보다는 지식의 발견에 사용된다.

# 모델은 데이터 내에 존재하는 패턴을 설명한다.
# 이와 대조적으로 군집화는 새로운 데이터를 생성한다.

# 주목할 점은 자율 분류기(=군집기)에서 얻은 클래스 레이블은 본질적인 의미가 없다는 것이다.
  # 군집화는 어떤 예시 그룹이 긴밀하게 연관되어 있는지는 말해 주지만,
  # 실행 가능하고 의미 있는 레이블을 적용하는 것은 사람의 책임이다.

# k- 평균 알고리즘은 n개의 예시를 k개의 클러스터 중 하나에 할당하는데, 이 때 k는 사전에 결정됨
  # 이 알고리즘의 목표는 클러스터 내의 차이를 최소화하고, 클러스터 간의 차이를 최대화하는 것이다.

# k-평균 알고리즘은 클러스터 중심의 출발 위치에 매우 민감하다.
  # k-평균의 초기 중심을 선택하는 방법을 다르게 할 수 있다. 거리는 보통 유클리드 거리를 사용한다.

# k를 크게 설정하면 클러스터의 동질성이 향상 but overfitting 위험 커진다.
  # 이상적으로는 실제 그룹에 대한 선험적(a priori)지식이 있을 것이며, 이 정보를 클러스터 개수를 선택하는데 적용가능
  # 사전 지식이 없다면 k를 n/2의 제곱근과 동일하도록 설정해보자.
  # 엘보법
    # 다양한 k값에 대해 클러스터 내의 동질성과 이질성이 어떠헥 변하는지를 측정한다.
## Example: Finding Teen Market Segments ----
## Step 2: Exploring and preparing the data ----
setwd("D:/R_LAB/MlwR/Chapter 09")
teens <- read.csv("snsdata.csv")
str(teens)

# look at missing data for female variable
table(teens$gender)
table(teens$gender, useNA = "ifany")

# look at missing data for age variable
summary(teens$age)

# eliminate age outliers
teens$age <- ifelse(teens$age >= 13 & teens$age < 20,
                     teens$age, NA)

summary(teens$age)

# reassign missing gender values to "unknown"
teens$female <- ifelse(teens$gender == "F" &
                         !is.na(teens$gender), 1, 0)
teens$no_gender <- ifelse(is.na(teens$gender), 1, 0)

# check our recoding work
table(teens$gender, useNA = "ifany")
table(teens$female, useNA = "ifany")
table(teens$no_gender, useNA = "ifany")

# finding the mean age by cohort
mean(teens$age) # doesn't work
mean(teens$age, na.rm = TRUE) # works

# age by cohort
# aggregate() 함수는 데이터의 하위 그룹에 대한 통계를 계산한다.
aggregate(data = teens, age ~ gradyear, mean, na.rm = TRUE)

# create a vector with the average age for each gradyear, repeated by person
# ave() 함수는 결과가 원 벡터의 길이와 같아지게 그룹의 평균이 반복되는 벡터를 반환한다.
ave_age <- ave(teens$age, teens$gradyear,
                 FUN = function(x) mean(x, na.rm = TRUE))

teens$age <- ifelse(is.na(teens$age), ave_age, teens$age) # 결측치에 ave_age 넣

# check the summary results to ensure missing values are eliminated
summary(teens$age)

## Step 3: Training a model on the data ----
interests <- teens[5:40]
interests_z <- as.data.frame(lapply(interests, scale))

set.seed(13123313)
teen_clusters <- kmeans(interests_z, 5)

## Step 4: Evaluating model performance ----
# look at the size of the clusters
teen_clusters$size

# look at the cluster centers :각 클러스터의 동질성을 살펴보자. 중심점의 좦를 알아보자.
teen_clusters$centers
# 양수는 모든 십대에 대한 전체 평균 이상, 음수는 전체 평균 이하.
# 클러스터가 각 관심 범주에 대해 평균 이상인지 이앟인지 검토 > 클러스터는 서로 구별하는 패턴 인식.

## Step 5: Improving model performance ----
# apply the cluster IDs to the original data frame

# 이 클러스터를 전체 데이터셋에 역을 ㅗ적용하자.
# kmeans() 함수에 의해 생성된 teen_cluster객체는 cluster라는 이름의 component를 포함한다.
# cluster component에는 전체 30000명 개인에 대한 클러스터 할당이 포함되어 있다.
# 다음 명령으로 cluster component를 teens 데이터 프레임의 열로 추가할 수 있다.
teens$cluster <- teen_clusters$cluster

# look at the first five records
teens[1:5, c("cluster", "gender", "age", "friends")]

# mean age by cluster # aggregate()로 인구통계학적 특성 살펴보
aggregate(data = teens, age ~ cluster, mean)

# proportion of females by cluster
aggregate(data = teens, female ~ cluster, mean) # 여성 비율은 상당한 차이가 있다(성별 데이터 사용 않았음에도)

# mean number of friends by cluster
aggregate(data = teens, friends ~ cluster, mean) # 공주, 범죄자, 그리고 무력한 사람

# k-평균 알고리즘 뿐만 아니라, 작업에 고유한 편향과 휴리스틱을 제공하는 다른 여러 군집 알고리즘 변형이 있다.


###############################################
## Extraction of correlation and mean via FACE
## Author: Luo Xiao
## Email: lxiao5@ncsu.edu
## Date: Sep 1, 2015
#############################################

cor.face <- function(object,argvals.new,option="raw"){

  ## arguments
  #  "object": fitted object from function ''face.sparse''
  #  "argvals.new": at which time points to evaluate correlations,
  ##  a correlation matrix evaulated at these time points will be the output
  ##

  ## check inputs
  if(class(object)!="face.sparse") stop("'fit' has to be a face_sparse object")
  if(is.null(argvals.new)) stop("'argvals.new' needs to be specified")
  if(length(argvals.new)<2) stop("'argvals.new' needs to contain at least two time points")
  if(!is.numeric(argvals.new[1])) stop("'argvals.new' need to be numeric")

  ## create a hypothetical data at time points 'argvals.new'
  ## and then make prediction and estimation
  k <- length(argvals.new)

  newdata_pred <- data.frame(
    subj=rep(1,k),
    argvals = argvals.new,
    y = rep(1,k)
  )

  yhat <- predict.face.sparse(object,newdata_pred)

  ## extract correlation and mean
  Chat <- yhat$Chat.pred
  if(option=="raw") Chat <- Chat + diag(yhat$var.error.pred)
  Cov_diag <- diag(Chat)
  Cor <- diag(sqrt(1/Cov_diag))%*%Chat%*%diag(sqrt(1/Cov_diag))

  mu <- yhat$mu.pred
 ## ouptut

  res <- list("argvals.new" = argvals.new,
              "option" = option,
              "Cor" = Cor, #estimated correlation matrix at argvals.new
              "mu" = mu #estimated group/population mean at argvals.new
  )
  return(res)
}


si <- file("stdin")
lines <- readLines(si)
close(si)

max <- 256

I <- function(x) {
	x %% max + 1
}

reverse <- function(v, i, n) {
	while (n > 1) {
		x <- c(I(i), I(i+n-1))
		v[x[1:2]] <- v[x[2:1]]
		i <- i+1
		n <- n-2
	}
	v
}

rounds <- function(input, n) {
	v <- 0:(max-1)
	s <- 0
	i <- 0
	while (n > 0) {
		n <- n - 1
		for (x in input) {
			v <- reverse(v, i, x)
			i <- i + x + s
			s <- s + 1
		}
	}
	v
}

xor <- function(a) {
	x = 0
	for (e in a) x = bitwXor(x, e)
	x
}

condence <- function(v) {
	x <- c()
	i <- 1
	while (length(v) > i) {
		x <- c(x, xor(v[i:(i+15)]))
		i <- i + 16
	}
	x
}

for (input in lines) {
	numbers <- suppressWarnings(as.numeric(strsplit(input, ",")[[1]]))
	if (!any(is.na(numbers))) {
		v <- rounds(numbers, 1)
		write(prod(v[1:2]), "")
	}

	bytes <- c(charToRaw(input), 17, 31, 73, 47, 23)
	hash <- condence(rounds(bytes, 64))
	write(cat(format(as.hexmode(hash), width=2), sep=""), "")
}


library(shiny)
library(fPortfolio)

use_original_frontierPlot = TRUE  # source file my-fpoints.R is NOT needed
## use_original_frontierPlot = FALSE # source file my-fpoints.R is needed

if (use_original_frontierPlot){
  ## Set myfrontierPlot to the original frontierPlot in fPortfolio
  myfrontierPlot = frontierPlot
}else{
  ## Use a more robust version of frontierPlot defined in my-fpoints.R
  ## This version handles degenerate efficient frontiers without errors
  source('my-fpoints.R')
}

shinyServer(
  function(input, output, session) {

    mu <- reactive(scan(text=input$mean, quiet = TRUE) / 100)
    sigmas <- reactive(scan(text=input$sigmas, quiet = TRUE) / 100)
    correl.vector <- reactive(scan(text=input$correl, quiet = TRUE))
    correl <- reactive({
      k <- input$k
      m <- matrix(0, k, k)
      j1 <- 1
      cv <- correl.vector()
      for (i in 1:(k-1)){
        j2 <- j1 + (k - i - 1)
        m[(i+1):k, i] <- cv[j1:j2]
        j1 <- j2 + 1
      }
      m <-  m + t(m)
      diag(m) <- 1
      m
    })
    names <- reactive(scan(text=input$names, what = character(),
                           quiet = TRUE))

    ## generate iid sample

    iid.sample <- reactive({
      k <- input$k
      N <- k + 30 # ensure adequate degrees of freedom
      x <- rnorm(N*k) # iid standard normals (in population)
      ## Sample moments of x can differ from population moments.
      ## We now force sample mean = 0 and sample std deviation =
      ## 1 by simple centering and rescaling
      x <- scale(matrix(x, N, k))
      ## To remove sample correlations, we multiply by the
      ## inverse of the cholesky factor of the sample
      ## covariance. The cholesky factor is like the square root
      ## of the matrix
      x %*% solve(chol(cov(x)))
    })

    ## Generate sample with desired sample moments
    my.sample <- reactive({
      k <- input$k
      validate(
        need(length(mu()) == k,
             'Wrong number of elements for Expected Returns'),
        need(length(sigmas()) == k,
             'Wrong number of elements for Standard Deviations'),
        need(length(correl.vector()) == k * (k - 1) / 2,
             'Wrong number of elements for Correlation Matrix'),
        need(length(names()) == k,
             'Wrong number of elements for Security Names')
      )
      ## print(eigen(correl())$values)
      validate(
        need(all(eigen(correl())$values > 0),
             'Correlation matrix not positive definite'),
        need(all(sigmas() > 0),
             'Standard deviation not positive')
      )
      ## To replicate the required correlation matrix we
      ## multiply the iid sample by the cholesky factor of the
      ## sample covariance. The cholesky factor is like the
      ## square root of the matrix
      y <- iid.sample()  %*% chol(correl())
      ## We then rescale the variables to achieve the required
      ## standard deviations
      y <- scale(y, center = FALSE, scale = 1/sigmas())
      ## Finally, we then re-center the variables to achieve the
      ## required means
      y <- scale(y, center = - mu(), scale = FALSE)
      dimnames(y)[[2]] <- names()
      y
    })

    output$mu.sd <- renderTable({
      data.frame(Mean = mu(),
                 StdDev = sigmas(),
                 row.names = names())
    })
    output$rho <- renderTable({
      correl()
    })
    output$plot <- renderPlot({
      fp <- portfolioFrontier(as.timeSeries(my.sample()))
      if(input$type == 'Portfolio Composition'){
        weightsPlot(fp)
      }else{
        myfrontierPlot(fp, col = c('blue', 'red'), pch = 20)
        if(input$frontier.twoasset)
          twoAssetsLines(fp, col = 'green')
        if(input$montecarlo)
          monteCarloPoints(fp, input$npoints,
                           col = 'grey', pch = 20, cex=0.3)
      }
    })
  })


m <- c(50, 25, 10, 5, 1)
alter <- function(n, p) {
  if (n == 0) {
    return(1)
  }
  while (m[p] > n) {
    p <- p + 1
  }
  if (m[p] == 1) {
    return(1)
  }
  alter(n - m[p], p) + alter(n, p + 1)
}

cat(sapply(as.integer(readLines(tail(commandArgs(), n=1))), function(s) alter(s, 1)), sep="\n")


useLog<-0  # 0= log N only
           # 1= log N  and log exploitation patter

a<-Read.SMS.std()

aa<-subset(a,name=='log_exploi_pattern')
aa$exp=exp(aa$value)
aa

# extract covariance or correlation matrix

fit<-read.fit()
#str(fit)

getCorCov<-function(vname,fit){
    idx<-which(fit$names %in% vname)
    COR<-fit$cor[idx,idx]
    COV<-fit$cov[idx,idx]
    loc.names<-sub('log_exploi_pattern','Expl',fit$names[idx])
    loc.names<-sub('term_logN_next','N',loc.names)
    labels<-paste(loc.names,paste("Q",fit$quarter[idx],sep=''),paste("A",fit$age[idx],sep=''),sep='.')

    dimnames(COR)<-list(labels,labels)
    dimnames(COV)<-list(labels,labels)
    val<-fit$est[idx]
    return(list(cov=COV,cor=COR,val=val,species=fit$species[idx],age=fit$age[idx],vari=fit$names[idx]))
}

if (useLog==0) a<-getCorCov(vname=c("term_logN_next"),fit=fit)
if (useLog==1) a<-getCorCov(vname=c("term_logN_next","log_exploi_pattern"),fit=fit)

COV<-a$cov
est<-a$val  # estimate used to for COV

COV<-as.matrix(COV)
diag(COV)

cleanup()
levelplot(a$cor,xlab='',ylab='',main='Correlation Before',at=seq(-1,1,0.05))

# get the values of F at age in the terminal year, and N  at age in the Terminal Year+1
# mvrnom is doing the matrix decomposition via eigen; although a Choleski decomposition might be faster, the eigendecomposition is stabler.
n<-10000
x<-mvrnorm(n=n, mu=est, Sigma=COV,tol=1e-5)  # I had to change the tolerance from the default value

cleanup()
X11()
levelplot(a$cor,xlab='',ylab='',main='Correlation Before',at=seq(-1,1,0.05))
X11()
levelplot(cor(x),xlab='',ylab='',main='Correlation After',at=seq(-1,1,0.05))

X11()
par(mfcol=c(4,5),mar=c(3,1,1,1))     #c(bottom, left, top, right)
for (i in (1:dim(x)[[2]])) {
  hist(x[,i],main=dimnames(x)[[2]][[i]])
}

X11()
par(mfcol=c(4,5),mar=c(3,1,1,1))     #c(bottom, left, top, right)
for (i in (1:dim(x)[[2]])) {
  hist(exp(x[,i]),main=dimnames(x)[[2]][[i]])
}

qr(crossprod(COV))$rank
cat('Should be:',dim(COV)[[1]])

aa<-try(chol(COV))
#library(mvtnorm)

#  modified from rmvnorm in library(mvtnorm)
arrange<- function (sigma,   method = c("eigen", "svd", "chol","cholP"), pre0.9_9994 = FALSE)
{
  method <- match.arg(method)
  R <- if (method == "eigen") {
    ev <- eigen(sigma, symmetric = TRUE)
    if (!all(ev$values >= -sqrt(.Machine$double.eps) * abs(ev$values[1]))) {
      warning("sigma is numerically not positive semidefinite")
    }
    t(ev$vectors %*% (t(ev$vectors) * sqrt(pmax(ev$values,
                                                0))))
  }
  else if (method == "svd") {
    s. <- svd(sigma)
    if (!all(s.$d >= -sqrt(.Machine$double.eps) * abs(s.$d[1]))) {
      warning("sigma is numerically not positive semidefinite")
    }
    t(s.$v %*% (t(s.$u) * sqrt(pmax(s.$d, 0))))
  }
  else if (method == "cholP") {
    R <- chol(sigma, pivot = TRUE)
    R[, order(attr(R, "pivot"))]
  }
  else if (method == "chol") {
      R <- chol(sigma, pivot = FALSE)
   }
  return(R)
}

qr(crossprod(COV))$rank

use<-dim(COV)[[1]]  # the full Sigma is not positive-definite
a1<-arrange(sigma=COV[1:use,1:use],method="eigen")
a2<-arrange(sigma=COV[1:use,1:use],method="svd")
a3<-arrange(sigma=COV[1:use,1:use],method="chol")
a4<-arrange(sigma=COV[1:use,1:use],method="cholP")

a1
a2  # same as a1
a3  #  sometimes fails
a4

n=100000
noise<-matrix(rnorm(n * use), n, use)

a11<-noise %*% a1
a21<-noise %*% a2
a31<-noise %*% a3
a41<-noise %*% a4

round(cov(a11),5)
round(cov(a21),5)
round(cov(a31),5)
round(cov(a41),5)
round(cov(a11)/cov(a21),5) # no diffrence
round(cov(a11)/cov(a41),5) # small difference
round(cov(a41)/cov(a31),5) # small difference

wr_cov<-function(COV,m=NULL,type=c("cov","decomposed"),var=c('n','nf')) {
  if (type=="cov" & var=="n") out<-file.path(data.path,'covariance_n.in')
  if (type=="cov" & var=="nf") out<-file.path(data.path,'covariance_nf.in')
  if (type=="decomposed" & var=="n") out<-file.path(data.path,'decomposition_n.in')
  if (type=="decomposed" & var=="nf") out<-file.path(data.path,'decomposition_nf.in')

  cat(1, "  # number of blocks\n",file=out)
  cat(dim(COV)[[1]], "  # dimension of matrix\n ",file=out,append=TRUE)
  cat("# variables:\n",paste("# ",colnames(COV),"\n") ,file=out,append=TRUE)
  if (type=="cov") write.table(COV,file=out,append=TRUE,col.names=FALSE,row.names=FALSE)
  if (type=="decomposed") write.table(m,file=out,append=TRUE,col.names=FALSE,row.names=FALSE)
}

if (useLog==0) wr_cov(COV,m=NULL,type="cov",var='n')
if (useLog==0) wr_cov(COV,m=a2,type="decomposed",var='n')

if (useLog==1) wr_cov(COV,m=NULL,type="cov",var='nf')
if (useLog==1) wr_cov(COV,m=a1,type="decomposed",var='nf')


#!/usr/bin/Rscript

########################################################################################
# script name: calculate_probabilities.r
# developed by: Haris Zafeiropoulos, Savvas Paragkamian
# framework: PREGO - WP4
########################################################################################
# GOAL:
# this script aims to calculate PREGO association scores
########################################################################################
#
# usage: Rscript calculate_probabilities.r
#
########################################################################################

# Dependencies
library(Rfast)

######################################################
### Regarding the NCBI IDs and their probabilities
######################################################

# read the background file
x<- read.csv("/data/databases/scripts/gathering_data/mgnify/ncbi_background.tsv", header = FALSE, sep = "\t")

# keep the values of each id occurence
mydata_x <- x$V2

# build a model using the negative binomial distribution
mod_x <- negbin.mle(mydata_x)

# calculate the probability of each ncbi id to come with respect to the non binomial distribution we built
x$new_x <- dnbinom(x = mydata_x, size = mod_x$param[2], prob = mod_x$param[1])

# write an output file with the probabilities of each NCBI ID to come
write.table(x, file='/data/databases/scripts/gathering_data/mgnify/probabilities_ncbi.tsv', quote=FALSE, sep='\t', row.names = FALSE, col.names = FALSE)

########################################################
### Regarding the metadata terms and their probabilities
########################################################

# read the background file
y <- read.csv("/data/databases/scripts/gathering_data/mgnify/metadata_background.tsv", header = FALSE, sep = "\t")

# keep the values of each id occurence
mydata_y <- y$V2

# build a model using the negative binomial distribution
mod_y <- negbin.mle(mydata_y)

# calculate the probability of each ncbi id to come with respect to the non binomial distribution we built
y$new_y <- dnbinom(x = mydata_y, size = mod_y$param[2], prob = mod_y$param[1])

# write an output file with the probabilities of each metadata ter to come
write.table(y, file='/data/databases/scripts/gathering_data/mgnify/probabilities_metadata.tsv', quote=FALSE, sep='\t', row.names = FALSE, col.names = FALSE)


# A general Brownian motion with mean non necessarily 0
# and non-necessarily unit variance.
# 23-04-2015
# Killian Martin--Horgassan

generalBM = function(mu, sigma,h) {

	# Number of time steps
	t <- ceiling(1/h)

	# Generating a t-uplet Gaussian vector and taking the sum
	vect <- cumsum(rnorm(t, mu*h, sigma*h))

	return(vect)
}


###############################################################################
# Discriminant Analysis
#------------------------------------------------------------------------------
# based on http://rpubs.com/sinhrks/plot_pca
###############################################################################
# install.packages("lfda")
# install.packages("ggplot2")

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(lfda)
library(ggplot2)

#==============================================================================
# Let's rock'n'roll!
#==============================================================================
# Local Fisher Discriminant Analysis (LFDA)
model <- lfda(iris[-5], iris[, 5], 4, metric="plain")
autoplot(model, data = iris, frame = TRUE, frame.colour = 'Species')

# Kernel Local Fisher Discriminant Analysis (KLFDA)
model <- klfda(kmatrixGauss(iris[-5]), iris[, 5], 4, metric="plain")
windows()
autoplot(model, data = iris, frame = TRUE, frame.colour = 'Species')

# Semi-supervised Local Fisher Discriminant Analysis (SELF)
model <- self(iris[-5], iris[, 5], beta = 0.1, r = 3, metric="plain")
windows()
autoplot(model, data = iris, frame = TRUE, frame.colour = 'Species')