library(Rcpp)

source(paste(getwd(), "../../sir-functions", "StocSSIR.r", sep = "/"))

T 		<- 60
N 		<- 500
i_infec <- 5
nloc  	<- 5
steps   <- 7
sigma   <- 10

pars <- c(	R0 	 = 3.0, # new infected people per infected person
          	r 	 = 0.1, # recovery rate
          	N 	 = 500, # population size
          	eta  = 0.5, # geometric random walk
          	berr = 0.5, # Beta geometric walk noise
          	phi  = 0.1) # degree of interconnectivity

initcond <- matrix(NA, nloc, 3)
colnames(initcond) <- c("S","I","R")

## default (everyone susceptible)
initcond[,"S"] <- N
initcond[,"I"] <- 0
initcond[,"R"] <- 0

## one region infected
initcond[2,] <- c(N - i_infec, i_infec, 0);

## set up number of neighbors vector and neighbor index matrix

## ring topology:
neinum <- rep(2,nloc)
neibmat <- matrix(NA, nloc, 3)
neibmat[,1] <- c( ((0:(nloc-1)-1)%%nloc)+1 )
neibmat[,2] <- c( ((0:(nloc-1)+1)%%nloc)+1 )

ssdeout <- StocSSIR(initcond, pars, T, steps, neinum, neibmat)

infec_counts <- ssdeout[,'I',] + matrix(rnorm(nloc*(T+1), 0, sigma), nloc, T+1)
infec_counts <- ifelse(infec_counts < 0, 0, infec_counts)

NP <- 2500*2
nPasses <- 50
coolrate <- 0.975

if2_spa_file <- paste(getwd(), "if2-spa.cpp", sep = "/")
sourceCpp(if2_spa_file)
if2data <- if2_spa(infec_counts, T, N, NP, nPasses, coolrate, neinum, neibmat, nloc)

paramdata <- data.frame(if2data$paramdata)
names(paramdata) <- c('R0','r','sigma','eta','berr','phi')
parmeans <- colMeans(paramdata)
print(parmeans)


# MULTIPLY transaction rates in a given cycle to obtain possible profit
bf.mult <- function(edges, rates, cycle) {

    profit = 1

    # find and multiply by pairs
    for (i in 1:(NROW(cycle)-1)) {
        next_value = rates[which(edges[,1]==cycle[i] & edges[,2]==cycle[i+1])]
        profit = profit * as.numeric(next_value)
    }

    # as number
    return(profit)
}

# RETRIEVE a path given a predecessor array and a source/target pair of nodes
bf.path <- function(nodes, prevs, terminal) {

    path = as.matrix(c(terminal))
    prev = nodes[prevs[which(nodes==terminal)]]

    # track util repeated element
    while (sum(path==prev) == 0) {
        path = rbind(path, prev)
        prev = nodes[prevs[which(nodes==prev)]]
    }

    # add repeated element
    path = rbind(path, prev)

    # trim the fat
    trim.bound = which(path==prev)[1]
    path = path[trim.bound:NROW(path)]
    path = as.matrix(rev(path))

    # as matrix
    return(path)
}

# APPLY classic Bellman-Ford Algorithm
bf.find <- function(graph, summary, debug=T) {

    # receive an EDGE LIST with the following format:
    #
    #        [,1]    [,2]    [,3]
    # [1,]  node 1  node 2  weight
    # [1,]  node 1  node 3  weight
    # [1,]  node 2  node 1  weight
    #   .     .       .       .
    #   .     .       .       .
    #   .     .       .       .

    # ready data
    edges = as.matrix(graph)
    nodes = unique(matrix(edges[,1:2], ncol=1))
    weights = as.numeric(as.character(edges[,3]))

    # ready state
    dists = rep(Inf, NROW(nodes))
    prevs = rep(NULL, NROW(nodes))

    # distance from source is zero
    # source is always the artificial node
    dists[1] = 0

    if (debug) {
        cat("Applying Bellman-Ford algorithm\n")
    }

    for (i in 1:(NROW(nodes)-1)) { # this can STILL stop earlier

        if (debug) {
            cat("  exploring paths with", i, "steps away from source\n")
        }

        for (j in 1:NROW(edges)) {
            if (dists[which(nodes==edges[j,1])] + weights[j] < dists[which(nodes==edges[j,2])]) {
                dists[which(nodes==edges[j,2])] = dists[which(nodes==edges[j,1])] + weights[j]
                prevs[which(nodes==edges[j,2])] = which(nodes==edges[j,1])
            }
        }
    }

    # test for negative cycles
    cycle = NULL
    for (i in 1:NROW(edges)) {

        # a path with NROW(nodes) steps can only occur via a negative cycle
        if (dists[which(nodes==edges[i,1])] + weights[i] < dists[which(nodes==edges[i,2])]) {
            cycle = bf.path(nodes, prevs, edges[i,1])

            if (debug) {
                cat("Arbitrage cycle found!\n")
                print(cycle)
            }

            break
        }
    }

    # then find possible profit
    profit = NULL
    if (NROW(cycle) > 0) {
        rates = as.numeric(as.character(summary[,3]))
        profit = bf.mult(edges, rates, cycle)

        if (debug) {
            cat("Possible profit:", profit, "\n")
        }
    } else {

        if (debug) {
            cat("No negative cycles found :(\n")
        }
    }

    ret = list()
    ret$nodes = nodes
    ret$cycle = cycle
    ret$profit = profit

    return(ret)
}

# APPLY Bellman-Ford SPFA variation algorithm
bf.spfa <- function(graph, summary, SLF=F, debug=T) {

    # This implementation improves upon the traditional Bellman-Ford algorithm:
    #  - Nodes are only explored if edges connecting to it could be relaxed in
    #    the previous step, severely improving average case runs
    #  - Small Label First induces exploration of closer nodes first, improving
    #    further even the average case performance

    # ready data
    edges = as.matrix(graph)
    nodes = unique(matrix(edges[,1:2], ncol=1))
    weights = as.numeric(as.character(edges[,3]))

    # ready state
    dists = rep(Inf, NROW(nodes))
    prevs = rep(NULL, NROW(nodes))

    # worst case iter count
    max_iters = NROW(nodes) - 1

    # distance from source is zero
    # source is always the artificial node
    dists[1] = 0

    # Q behaves as a FIFO queue
    # ...also, add source to it
    Q = c(1)

    if (debug) {
        cat("Applying Bellman-Ford SPFA variation\n")
    }

    while (NROW(Q) > 0) {
        # get front
        node = Q[1]
        Q = Q[-which(Q==node)]

        if (debug) {
            cat("  currently exploring node", node, "\n")
        }

        # neighbor node edge ids
        edge.ids = which(edges[,1]==nodes[node])

        for (i in 1:NROW(edge.ids)) {

            # distance inbetween
            distance = weights[edge.ids[i]]

            # neighbor node number
            neighbor = which(nodes==edges[edge.ids[i], 2])

            if (dists[node] + distance < dists[neighbor]) {
                dists[neighbor] = dists[node] + distance
                prevs[neighbor] = node

                # add to queue (only once)
                if (sum(Q==neighbor) == 0) {
                    Q = c(Q, neighbor)

                    # >>> Optimization: SLF <<<
                    if ((SLF) & (dists[neighbor] < dists[Q[1]])) {
                        Q = c(neighbor, Q[1:(NROW(Q)-1)])
                    }
                }
            }
        }

        # necessary for worst case
        max_iters = max_iters - 1
        if (max_iters == 0) {
            break
        }
    }

    # find negative cycle
    cycle = NULL
    profit = NULL
    for (i in 1:NROW(edges)) {

        u = which(nodes==edges[i, 1]) # node
        v = which(nodes==edges[i, 2]) # neighbor

        # only possible in the presence of negatie cycles
        if (dists[u] + weights[i] < dists[v]) {

            # cycle path
            cycle = bf.path(nodes, prevs, edges[i,1])

            # cycle mult
            rates = as.numeric(as.character(summary[,3]))
            profit = bf.mult(edges, rates, cycle)

            if (debug) {
                cat("Arbitrage cycle found!\n")
                print(cycle)
                cat("Possible profit:", profit, "\n")
            }

            break
        }
    }

    # case of "failure"
    if (NROW(cycle) == 0) {
        if (debug) {
            cat("No negative cycles found :(\n")
        }
    }

    ret = list()
    ret$nodes = nodes
    ret$cycle = cycle
    ret$profit = profit

    return(ret)
}


# vector c attached to each node in the modwpt transform (Percival and Walden, page 215)
# vector c will be used to align LA wavelet coefficients
getC=function(j,n)
{
  vectorC=c();
  if (j==1)
  {
    if (n==0) vectorC=0
    else vectorC=1
    return(vectorC)

  }
  else
  {
    if (((n%%4)==0)||((n%%4)==3))
      return(c(getC(j-1,floor(n/2)),0))
    else
      return(c(getC(j-1,floor(n/2)),1))
  }

}

# Auxiliary function used to calculate time shifts for wavelets(Percival and walden,229-230)
# This function will return c(Sjn0,Sjn1)
getSc=function(j,n)
{
  vectorC=getC(j,n)
  Sjn1=(sum(vectorC*2^(0:(j-1))))
  Sjn0=2^j-1-Sjn1
  return (c(Sjn0,Sjn1))

}
# Auxiliary function used to calculate time shifts for LA wavelets(Percival and walden,229-230)
getLj=function(j,wf)
{
  #length of the wave filter
  L=length(wave.filter(wf)$lpf)
  Lj=(2^j-1)*(L-1)+1
  return(Lj)
}

#getVjnLA returns time shifts for la8,la16 and la20 wavelets in modwpt
getVjnLA=function(j,n,wf)
{
  aux=getSc(j,n);
  Sjn1=aux[2];
  return(abs(-getLj(j,wf)/2+(2^(j-1)-Sjn1)))
}

#performs left circular shift
circularShift=function(x,n)
{
  l=length(x)
  if ((n==0)||(n==l)) return(x)
  if ((n<0)||(n>l)) {n=n%%l}
  return(c(x[(n+1):l],x[1:n]))
}
# aligns <<x>> wavelet coefficients from modwpt using <<wf>> wavelet. <<x>> are the
# (j.n) node wavelet coefficients. <<wf>> should be "l8","l16" or "l20". If not, not
# alignment is perform
align=function(x,j,n,wf)
{
  #return(x)
  if ((wf!="la8")&&(wf!="la16")&&(wf!="la20"))
  {
    #general method
    return(circularShift(x,CenterOfEnergyAdvances(j,n,wf)))
  }
  else
  { #specific method for LA wavelets
    return(circularShift(x,getVjnLA(j,n,wf)))
  }
}

#shift applicable to (almost) every filter using the notion of the 'center of
#energy' by Hess-Nielsen and Wickerhauser.
# Walden page 231

# gets the appropiate advance for the (j.n) node of the <<wf>> wavelet.
CenterOfEnergyAdvances=function(j,n,wf)
{
  #variables for the computation
  S=getSc(j,n)
  E=CenterEnergies(wf)
  advance=round(  S[1]*E[1]+S[2]*E[2]  )

  return (advance)
}

# gets the center of energy for both wf filters
CenterEnergies=function(wf)
{
  waveletFilter=wave.filter(wf)
  #Center ofEnergy of the scaling filter
  cesf=computeCenterEnergy(waveletFilter$length,waveletFilter$lpf);
  #Center ofEnergy of the wavelet filter
  cewf=computeCenterEnergy(waveletFilter$length,waveletFilter$hpf);
  return (c(cesf,cewf))

}

#auxiliar function: gets the center of energy of coefs. length(coefs)=l
computeCenterEnergy=function(l,coefs){
  auxVector=0:(l-1)
  coefs2=(coefs)^2
  a=coefs2%*%auxVector
  b=sum(coefs2)
  return (a/b)
}


# Experiments with t-digest in R

standard.size.bound = function(n, q) {
    4 * n * q * (1-q)
}

constant.size.bound = function(n, q) {
    n
}

root.size.bound = function(n, q) {
    n * sqrt(4 * q * (1-q))
}

abs.size.bound = function(n, q) {
    2 * n * min(q, 1-q)
}

sorted.t.digest = function (points, compression=50, size.bound = standard.size.bound) {
    points = sort(points)
    n = length(points)

    total = 0
    i = 1
    r = data.frame()
    while (i <= n) {
        # accumulate a centroid of max size
        mean = 0
        count = 0
        qx = total/n
        while (count + 1 <= max(1, do.call(size.bound,list(n=n, q=qx)) / compression)) {
            count = count+1
            mean = mean + (points[i]-mean)/count
            qx = (total + count/2) / n
            i = i+1
        }
        total = total + count
        r = rbind(r, data.frame(center=c(mean), count=c(count)))
    }
    r
}

size.growth = data.frame()
sample.size = c(100, 200, 500, 1000, 2000, 5000, 10000, 20000, 50000, 100000, 200000, 500000, 1000000)
bounds = c("standard.size.bound", "abs.size.bound", "root.size.bound", "constant.size.bound")
for (j in 1:length(bounds)) {
    bound = bounds[j]
    print(bound)
    for (i in 1:length(sample.size)) {
        n = sample.size[i]
        x = rnorm(n)
        cx = sorted.t.digest(x, size.bound=bound)
        size.growth = rbind(size.growth, data.frame(f=bound, n=n, c=dim(cx)[1]))
        print(c(n, dim(cx)[1]))
    }
}

colors = rainbow(3)
colors = c(colors[1],colors[1],colors[2], colors[3])
plot(x=c(), y=c(), xlim=c(1e2,1e6), ylim=c(0,350), log="x", ylab="Centroids", xlab="Points")
for (i in c(1,3,4)) {
  lines(c~n, size.growth[unclass(size.growth$f)==i,], col=colors[i], lwd=2, type='b', cex=0.6)
}
legend(1e2, y=350, legend=c("Standard", "Root", "Constant"), fill=rainbow(3))

direct.t.digest = function (points, compression=50) {
    n = length(points)

    total = 0
    i = 1
    r = data.frame()
    while (i <= n) {
        # accumulate a centroid of max size
        mean = 0
        count = 0
        qx = total
        while (count + 1 <= max(1, 4 * n * (qx * (1-qx) / compression))) {
            count = count+1
            mean = mean + (points[i]-mean)/count
            qx = (total + count/2) / n
            i = i+1
        }
        total = total + count
        r = rbind(r, data.frame(center=c(mean), count=c(count)))
    }
    r
}


#Load positions
pos <- read.table("optimaltransport.ascii",header=F)
p = nrow(pos)
par(mfrow=c(1,1))
plot(pos)

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

#Random order of visits as initialization
#We implement the fact that the distribution must start and finish at home town
theta = c(1, sample(2:p,p-1), 1)
#Convert sequential pairs into index of the d-vector
ind = (theta[-p]-1)*p+theta[-1]
#Calculate total distance of order
V = sum(d[ind])
Vopt = V
Vseq = V

#Make table of neighbor search
#first two columns are indices to be swapped
#We exclude the hometown from it, starting from 2 instead of 1
num = (p-1)*(p-2)/2
searchtab = matrix(0,nrow=num,ncol=2)
ind = 1
for(i1 in 2:(p-1))
for(i2 in (i1+1):p)
{
  searchtab[ind,1:2] = c(i1,i2)
  ind = ind+1
}
searchtab
#Perform neighbor search, changing best two components
more = TRUE
tabu = NULL
H = NULL
tau = 5
#while(more)
for(it in 1:10000)
{
  V2opt = V+1000  #Just to get some initial value to beat
  i1opt = NA
  for(i in 1:num)
  {
    if(is.na(pmatch(i,H)))
    {
      #Find indices to swap
     i1 = searchtab[i,1]
     i2 = searchtab[i,2]
     #Swap components, put into theta2
     theta2 = theta
     theta2[i1] = theta[i2]
     theta2[i2] = theta[i1]
     #Calculate value for new configuration
     ind2 = (theta2[-p]-1)*p+theta2[-1]
     V2 = sum(d[ind2])
     #If best so far, store it
     if(V2<V2opt)
     {
       V2opt = V2
       iopt = i
       i1opt = i1
       i2opt = i2
     }
    }
  }
  #Change to best configuration found
  theta2 = theta
  theta2[i1opt] = theta[i2opt]
  theta2[i2opt] = theta[i1opt]
  theta = theta2
  V = V2opt
  Vseq = c(Vseq,V)
  #Include the swap in TABU table
  H = c(H,iopt)
  #If table is too large, remove first element (oldest swap)
  if(length(H)>tau)
    H = H[-1]
  #Check if better than best so far
  if(V < Vopt)
  {
    theta.opt = theta
    Vopt = V
  }
}
#par(mfrow=c(2,1),mar=c(0.5,1,0.5,1))
plot(pos)
lines(pos[theta.opt,1],pos[theta.opt,2])
points(pos[1,1],pos[1,2], type = 'o', col = 'red')
dev.copy2pdf(file="../doc/travel_sale_opt1.pdf")
plot.ts(Vseq)
show(min(Vseq))


## VEP amplitudes (N125 peak)

raw <- read.table(file = "data/vep_amp_uncorrected.csv",header = FALSE, dec = ".", col.names = "amp", sep=",")
raw$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
raw$subj      <- c(c(1:27), c(1:27))
raw$method    <- c(rep("uncorrected", 27*2))

asr <- read.table(file = "data/vep_amp_asr.csv",header = FALSE, dec = ".", col.names = "amp", sep=",")
asr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
asr$subj      <- c(c(1:27), c(1:27))
asr$method    <- c(rep("asr", 27*2))

rasr <- read.table(file = "data/vep_amp_rasr.csv",header = FALSE, dec = ".", col.names = "amp", sep=",")
rasr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
rasr$subj      <- c(c(1:27), c(1:27))
rasr$method    <- c(rep("rasr", 27*2))

### testing time
library(ez)
library(effsize)

# combine all for ANOVA
all <- rbind( raw, asr, rasr)
aov_group <- ezANOVA(data=all, dv = amp, within = .(condition, method), wid=subj)
print(aov_group)

source("pairwise.t.test.with.t.and.df.R")
result <- pairwise.t.test.with.t.and.df(all$amp, all$condition, adjust.method="bonf", paired=TRUE)
# Print t-values
print(c("t-value: ", result[[5]]))

# Print dfs
print(c("Df: ", result[[6]]))

# Cohen's D for t-test
cohen.d(all$amp, as.factor(all$condition), paired = TRUE)
a <- mean(all$amp[all$condition== "inside" & all$method == "rasr"])
b <- mean(all$amp[all$condition== "inside" & all$method == "asr"])
c <- mean(all$amp[all$condition== "outside" & all$method == "rasr"])
d <- mean(all$amp[all$condition== "outside" & all$method == "asr"])
e <- mean(all$amp[all$condition== "inside" & all$method == "uncorrected"])
f <- mean(all$amp[all$condition== "outside" & all$method == "uncorrected"])
plot(c(a,b,c,d,e,f), xlab = "methods", ylab = "mean vep amplitudes", xaxt = "n")
# Changing x axis
axis(1, at=1:6, labels=c("in rASR","in ASR", "out rASR","out ASR", "in raw", "out raw"))
legend("topright", legend=c(mean(c(a,b,e)),mean(c(c,d,f))))

print(c(a, "rasr in"))
print(c(b, "asr in"))
print(c(c, "rasr out"))
print(c(d, "asr out"))
print(c(e, "uncorr in"))
print(c(f, "uncorr out"))


########################################################################
#                                                                      #
#   lib/permutation-group.rb                                           #
#                                                                      #
########################################################################
=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::PermutationGroup>))
/
((<Algebra::Permutation>))

= Algebra::PermutationGroup
置換群のクラスです。要素として ((<Permutation>)) のインスタンス
が指定されているとします。

== ファイル名:
* ((|permutation-group.rb|))

== スーパークラス:
* ((|Group|))

== クラスメソッド:

--- ::new(u, [g0, [g1, ...]])
    ((|u|)) を単位元とし、((|g0|)), ((|g1|)), ... で構成される群を
    返します。

--- ::unit_group(d)
    次数が ((|d|)) の単位群を返します。

--- ::unity(n)
    次数が ((|n|)) の単位元を返します。

--- ::perm(a)
    配列 ((|a|)) で表される置換を返します。

--- ::symmetric(n)
    ((|n|)) 次の対称群を返します。

--- ::alternate(n)
    ((|n|)) 次の交代群を返します。

= Algebra::Permutation
置換を表現するクラスです。

== ファイル名:
* ((|permutation-group.rb|))

== スーパークラス:
* ((|Object|))

== インクルードしているモジュール:

* ((|Enumerable|))
* ((|Powers|))

== クラスメソッド:

--- ::new(x)
    ((|x|)) という配列で表現される置換を生成します。

--- ::[]([n0, [n1, [n2, ..., ]]])
    (({[n0, n1, n2, ..., ]})) という置換を生成します。
    例
      a = Permutation[1, 2, 0]
      p a**2 #=> [2, 0, 1]
      p a**3 #=> [0, 1, 2]

--- ::unity(d)
    ((|d|)) 次の単位元を返します。

--- ::cyclic2perm(c, n)
    ((|c|)) という巡回置換を表す配列の配列から、((<Permutation>))
    オブジェクトを生成します。((|n|)) は次数です。
    ((<decompose_cyclic>)) の逆です。

    例:
      Permutation.cyclic2perm([[1,6,5,4], [2,3]], 7) #=> [0, 6, 3, 2, 1, 4, 5]
      Permutation[0, 6, 3, 2, 1, 4, 5].decompose_cyclic #=> [[1,6,5,4], [2,3]]

== メソッド:
--- unity
    単位元を返します。

--- perm
    配列表現を返します。

--- degree
    次数を返します。

--- size
    ((<degree>)) のエイリアスです。

--- each
    置換の各元について繰り返します。

--- eql?(other)
    ((|other|)) と等しいとき真を返します。

--- ==
    ((|eql?|)) のエイリアスです。

--- hash
    ハッシュ値を返します。

--- [](i)
    ((|i|)) の置換先を返します。

--- call
    ((<[]>)) のエイリアスです。

--- index(i)
    ((|i|)) の置換元を返します。

--- right_act(other)
    ((|other|)) に右からかけます。すなわち
    (({(g.right_act(h))[x] == h[g[x]]})) が成立します。

--- *
    ((<right_act>)) のエイリアスです。

--- left_act(other)
    ((|other|)) に左からからかけます。すなわち
    (({(g.left_act(h))[x] == g[h[x]]})) が成立します。

--- inverse
    逆元を返します。

--- inv
    ((|inverse|)) のエイリアスです。

--- sign
    符号を返します。

--- conjugate(g)
    ((|g|)) による共役 (({g * self * g.inv})) を返します。

--- decompose_cyclic
    配列による巡回表現の配列を返します。
    ((<::cyclic2perm(c, n)>)) の逆です。

--- to_map
    ((<Map|URL:finite-map-ja.html>)) オブジェクト化します。

--- decompose_transposition
    互換の配列に分解したものを返します。

=end


BBym2w <- function(ym,...){
  # length(ym) = 2*K
  y <- ym[1:K]
  m <- ym[(K+1):(2*K)]
  a0 <- 1
  b0 <- 1
  psamp <- matrix( rbeta(nsamp*K, a0+y, b0+m-y) , ncol=K, byrow=T)
  kstar <- factor( apply(psamp,1,which.max), levels=1:K )
  w <- as.numeric( table(kstar)/nsamp )
}

policy.RPM.BB4 <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  ysum <-  apply(ybyK, 2, sum)
  msum <- apply(mbyK, 2, sum)
  # update beliefs
  a0 <- 1
  b0 <- 1
  psamp <- matrix( rbeta(nsamp*K, a0+ysum, b0+msum-ysum) , ncol=K, byrow=T)
  # prob win
  kstar <- factor( apply(psamp,1,which.max), levels=1:K )
  w <- c( as.numeric( table(kstar)/nsamp ) )
  return(list(w=w))
}

policy.RPM.BB12 <- function(m,y,...){
# d$adsize  (3 unique sizes)
  sz <- d$adsize
  J <- nrow(d)/K
  w <- rep(0,nrow(d))
  s1 <- (sz==levels(sz)[1])
  w[s1] <- policy.RPM.BB4(m=m[s1],y=y[s1],...)$w
  s2 <- (sz==levels(sz)[2])
  w[s2] <- policy.RPM.BB4(m=m[s2],y=y[s2],...)$w
  s3 <- (sz==levels(sz)[3])
  w[s3] <- policy.RPM.BB4(m=m[s3],y=y[s3],...)$w
  return(list(w=w))
}

policy.RPM.BB4.unpooled <- function(m,y,...){
  #m,y are ordered by j=1:J and within each j ordered by k=1:K
  J <- nrow(d)/K
  w <- rep(0,J*K)
  mJbyK <- matrix(m, nrow=J, ncol=K, byrow=T)
  yJbyK <- matrix(y, nrow=J, ncol=K, byrow=T)
  wKbyJ <- apply(cbind(yJbyK,mJbyK), 1, BBym2w)  # value is K by J matrix
  w <- c(wKbyJ) # converts matrix to vector by stacking columns j=1,...,J of length K
  return(list(w=w))
}

#


library(ggplot2)
source("date.r")
source("explore-data.r")

# Check difference between date and date sold
both <- subset(geo, !is.na(date) & !is.na(datesold))
diff <- as.numeric(both$date) - as.numeric(both$datesold)
qplot(diff, binwidth = 1)
qplot(diff, geom="histogram", binwidth = 1) + scale_x_continuous("day after sale", breaks = seq(7, 70, by = 7), limits = c(7, 63))
qplot(factor(wday(both$datesold)))

# Want to figure out if sales in different price ranges have been affected
# differently.  Need to be careful to distinguish between houses changing
# price and decreasing sales

# Distribution of prices -----------------------------------------------------

# Distribution of price is highly skew-right
qplot(priceadj, data = geo, geom="histogram", binwidth = 1e5)
# and many prices are rounded to nice numbers:
qplot(priceadj, data = geo, geom="histogram", binwidth = 1e4, xlim = c(0, 2e6))

# On the log scale, distribution looks much nicer
qplot(log10(priceadj), data = geo, geom="histogram", binwidth = .1)
qplot(log10(priceadj), data = geo, geom="histogram", xlim=c(5, 6.5), binwidth = .02)

# Does this pattern change over time?
fp <- geom_freqpoly(aes(y = ..density..), binwidth = .05)
mid <- subset(geo, priceadj > 10^5 & priceadj < 10^6.5)

# 2008 looks like a particularly bad year
ggplot(mid, aes(log10(priceadj))) + fp + aes(colour = factor(year))
# No difference across months
ggplot(mid, aes(log10(priceadj))) + fp + aes(colour = factor(month))

# Pronounced flattening of distribution around Oct 07
ggplot(mid, aes(log10(priceadj))) + fp + facet_grid(year ~ month)

# Bin prices and look at number of sales -------------------------------------

day_sales <- ddply(mid, .(year, month), nrow)
qplot(year + (month - 1) / 12, V1, data = day_sales, geom = "line")
qplot(month, V1, data = day_sales, geom = "line", group = year)

breaks <- quantile(mid$priceadj, seq(0, 1, length = 11))
labels <- unname(breaks[-11] + breaks[-1]) / 2
mid$pricebin <- labels[as.numeric(cut(mid$priceadj, breaks = breaks))]

sales <- ddply(mid, .(year, month, pricebin), function(df) {
  data.frame(n = nrow(df), avg = mean(df$priceadj))
})
sales <- sales[!is.na(sales$price), ]

# Really interesting patterns:
#  * Two inflection points Jan-Feb 2005 and Jan 2008 where total sales drop
#    and stabilise across price bins
#  * Before 2005 cheap houses high selling, afterwards more expensive
#  * After 2008, sales of cheap houses skyrocket
qplot(year + (month - 1) / 12, n, data = sales, geom = "line", group = pricebin, colour = pricebin, xlab = "year") + scale_colour_gradient(low = "red", high = "blue", trans = "log10")

# Patterns of average sale price are harder to interpret because of the
# binning, but suggestive: most expensive houses have dropped in price,
# while cheaper house show increase.
qplot(year + (month - 1) / 12, avg, data = sales, geom = "line", group=pricebin) + facet_grid(pricebin ~ ., scales = "free_y") + geom_smooth(se = F)

deciles <- ddply(mid, .(year, month), function(df) {
  data.frame(
    decile = seq_len(9),
    value = quantile(df$price, seq(0, 1, length = 11)[-c(1, 11)])
  )
})
qplot(year + (month - 1) / 12, value, data = deciles, geom = "line", group=decile)  + geom_hline(yintercept = breaks[-c(1, 11)], colour="grey50")

# But most of the original pattern is a result of houses getting cheaper
# so more houses fall into the cheap bracket.

med <- rename(subset(deciles, decile == 5), c("value" = "median"))
med$decile <- NULL

# Relative to median house price, expensive houses have become more expensive
# and cheaper houses cheaper:  the variation in prices has increased as a
# result of the housing crisis
deciles <- merge(deciles, med)
qplot(year + (month - 1) / 12, log10(value), data = deciles, geom = "line", group=decile)
qplot(year + (month - 1) / 12, log10(value / median), data = deciles, geom = "line", group=decile)

deciles <- deciles[order(deciles$year, deciles$month), ]
deciles <- ddply(deciles, .(decile), transform, index = value / value[1])
qplot(year + (month - 1) / 12, index, data = deciles, geom = "line", group=decile) + geom_hline(yintercept = 1, colour="grey50")
# It looks like the most expensive houses have been least affect.  The
# cheapest houses have been most affected.

last_plot() + scale_y_log10()

# Bin prices into chunks of $100,000 -----------------------------------------

mid$pricebin <- round_any(mid$priceadj, 1e5, floor)
sales <- ddply(subset(mid, priceadj < 1e6), .(year, month, pricebin),
  function(df) { data.frame(n = nrow(df), avg = mean(df$priceadj)) })
qplot(year + (month - 1) / 12, n, data = sales, geom = "line", xlab = "year") + facet_wrap(~ pricebin)

qplot(year + (month - 1) / 12, n, data = sales, geom = "line", xlab = "year", colour = factor(pricebin), size = I(2)) + scale_colour_brewer(pal = "Spectral", alpha=0.8)


# Relational operators on numbers
number1 <- 30
number2 <- 3

# Equal to
number1 == number2

# Not equal to
number1 != number2

# Less than
number1 < number2

# Les than equal to
number1 <= number2

# Greater than
number1 > number2

# Greater than equal to
number1 >= number2

# Relational operators on vectors
vector1 <- c(5, 10, 15)
vector2 <- c(3, 6, 9)

# Equal to
vector1 == vector2

# Not equal to
vector1 != vector2

# Less than
vector1 < vector2

# Less than equal to
vector1 <= vector2

# Greater than
vector1 > vector2

# Greater than equal to
vector1 >= vector2

# Check whether the number is in the vector
myVector <- c(5, 3, 15)
number <- 3

number %in% myVector

0 - Learn R from scratch/relational_operators.r


svdopt <- function(R, k, lr = 0.05, reg = 0.002, miter = 10) {
	global_mean <- mean(as.matrix(R[,3]), na.rm = TRUE)
	bu <- rep(0, max(R[,1]))
	bi <- rep(0, max(R[,2]))
	nusers <- max(R[,1])
	nitems <- max(R[,2])
	P <- matrix(rnorm(nusers*k, mean=0, sd=0.1), nusers, k)
	Q <- matrix(rnorm(nitems*k, mean=0, sd=0.1), nitems, k)
	error <- list()

	for(l in 1:miter) {
		sq_error <- 0
		for(j in 1:nrow(R)) {
			u <- R[j,1]
			i <- R[j,2]
			r_ui <- R[j,3]
			pred <- global_mean + bu[u] + bi[i] + P[u, ] %*% Q[i,]
			e_ui <- r_ui - pred
			sq_error <- sq_error + e_ui^2
			bu[u] <- bu[u] + lr * e_ui
			bi[i] <- bi[i] + lr * e_ui
			for(f in 1:k) {
				temp_uf <- P[u,f]
         		P[u,f] <- P[u,f] + lr * (e_ui * Q[i,f] - reg * P[u,f])
			    Q[i,f] <- Q[i,f] + lr * (e_ui * temp_uf - reg * Q[i,f])
			}
		}
		error <- c(error, sqrt(sq_error/nrow(R)))
	}

	return(list(bu = bu, bi = bi, P = P, Q = Q, error = error))
}


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 1   Chapter : 3.5     Page No: 170
# Columns of given matrix are dependent
library(pracma)
A<-matrix(c(1,2,1,0,1,0,3,5,3),nrow=3)
if(Rank(A)!=ncol(A)){
  print("The columns of A are dependent")
}
print("As the columns of A are dependent ,there is a nonzero solution to Ax=0")
x<-matrix(c(-3,1,1),ncol=1)
print(A%*%x)


install.packages(c("vegan", 'devtools', 'RVAideMemoire'))
devtools::install_github("jfq3/ggordiplots")

library(vegan)
data(dune)
str(dune)

# Ordination with metaMDS

  # Euclidean distance == PCA
    # takes the data + distance measure, or
    # a distance matrix fit by vegdist()
    # k = number of dimensions to fit
      dune.e.k2 <- metaMDS(dune, k=2, dist="euclidean")
      dune.e.k2  # in metaMDS, call the object, not summary()
      stressplot(dune.e.k2, las=1, # Goodness-of-fit between the distance
                 main="Euclidean") # between sites in the ordination,
                                   # and their actual dissimilarity
                                   # in the calculated distance matrix.
                                   # Less-good fit = more stress

  # 2-dimension NMDS  w/ Bray-Curtis measure
  	dune.b.k2 <- metaMDS(dune, k=2, dist="bray")
  	dune.b.k2
  	stressplot(dune.b.k2, las=1, main="Bray-Curtis")

  # Compare ordinations with procrustes rotations
  	pro1 <- procrustes(dune.e.k2, dune.b.k2)

    plot(pro1, kind=1, las=1)
    text(pro1)

    plot(pro1, kind=2, las=1)

    protest(dune.e.k2, dune.b.k2, scores="sites")

  # Got environmental data? Compare dissimilarities to gradients
  	data(dune.env)
  	str(dune.env)
  	round(rankindex(dune.env, dune, c("euc", "bray", "canb"), method="pearson"), 2)

	# Test environmental variables against ordination

  	env.euc <- envfit(dune.e.k2, dune.env, permu=999)
    	env.euc
  	  env.euc$factors
    	env.euc$vectors

	  env.bray <- envfit(dune.b.k2, dune.env, permu=999)
	    env.bray
	    env.bray$factors
	    env.bray$vectors

	  # Testing multi-level factors
	    library(RVAideMemoire)

	    pairwise.factorfit(dune.b.k2, dune.env$Management,
	                       nperm = 999, p.method = "none")

  # Compare ordinations by groups, gradient
    x11(12,6) # Check the size manually
    par(mgp=c(4, 1, 0), mar=c(6, 6, 1, 1), las=1, mfrow=c(1,2), cex.lab=1.2, cex.axis=1.2)
    	# Euclidean
    	plot(dune.e.k2, type="t", main="Euclidean")
    	ordispider(dune.e.k2, groups=dune.env$Management, label=TRUE)
    	plot(envfit(dune.e.k2 ~ A1, data=dune.env, permu=999), p.max=0.10, col="blue")

    	# Bray-Curtis
    	plot(dune.b.k2, type="t", main="Bray-Curtis")
    	ordispider(dune.b.k2, groups=dune.env$Management, label=TRUE)
    	plot(envfit(dune.b.k2 ~ A1, data=dune.env, permu=999), p.max=0.10, col="blue")
    dev.off()

  # Other gradient visualization
    	ob <- ordisurf(dune.b.k2 ~ A1, dune.env, add=FALSE, labcex = 1.2, bubble=5)
    	plot(ob)
    	plot(envfit(dune.b.k2 ~ A1, data=dune.env, permu=999), p.max=0.10, col="blue")
    	summary(ob)

    	# Non-linear:
    	(ob2 <- ordisurf(dune.b.k2 ~ A1, dune.env, add=FALSE, knots = 2, labcex = 1.2, bubble=5) )
    	summary(ob2)
    	anova(ob, ob2, test="Chisq")

  # GGplot the NMDS
    	library(ggordiplots)
    	gg_ordiplot(dune.b.k2, groups = dune.env$Management,
    	            kind="se", conf=0.95)
    	gg_ordiplot(dune.b.k2, groups = dune.env$Management,
    	            spiders=TRUE, ellipse=FALSE)

# Non-ordination approaches to multivariate hypothesis testing
  	# Permutational Multivariate Analysis of Variance (perMANOVA)
  	# has been popular. vegan::adonis is similar:

  	  (dM.ad <- adonis(dune ~ Management, dune.env))
    	round(coef(dM.ad),2)  # Coefficient table, each species response, each Management

  	# Then follow up with a post-hoc pairwise test from RVAideMemoire:
  	  dune.m <- vegdist(dune, "bray")
  	  pairwise.perm.manova(dune.m, dune.env$Management, nperm=999)

  	# But be careful: adonis is by default a Type I Sum of Squares test:
  	  adonis(dune ~ Manure + Management, dune.env)
  	  adonis(dune ~ Management + Manure, dune.env)

  	# RVAideMemoire provides a Type II method
  	  adonis.II(dune ~ Management + Manure, dune.env)
  	  adonis.II(dune ~ Manure + Management, dune.env)

Analysis of Ecosystems/10 & 11 - Ordination/10-2_ordination_with_metaMDS.r


## Libraries

library(factoextra)
library(dplyr)

## Importing Database
rm(list = ls())
source("libraries.R")
source("import_data.R") ; df <- efw_data_panel

## Database Labels

efw.labels = efw$country.efw
table(efw.labels)
efw_data <- efw[4:9]

## Scale Data

efw_data_scale <- scale(efw_data)
efw_data <- dist(efw_data_scale)

##Removing NA Values From Dataset

km_cluster <- kmeans(na.omit(efw_data_scale), 3)
km_cluster
km_cluster$withinss
km_cluster$tot.withiness/km_cluster$betweenss

df <- efw_data_scale[is.finite(rowSums(efw_data_scale)),]

## Sampling Data

m <- matrix(c(1,2,NA,NaN,1,Inf,-1,1,9,3),5)

## Removing All Rows With Non-Finite Values

m[!rowSums(!is.finite(m)),]

## Replace All Non-Finite Values With 0

m[!is.finite(m)] <- 0

## Calculate How Many Clusters You Need
## Within Sum Squares
## Plot Shows

fviz_nbclust(df, kmeans, method = "wss") +
  labs(subtitle = "Elbow method")

## Kmeans Cluster / Center is Kmeans, can be adjusted / nstart: if center is a
## number, how many random sets should be chosen?

km.out <- kmeans(df, center = 4, nstart = 100)
print(km.out)

## Visualizing Cluster Results

km.clusters <- km.out$cluster
rownames(df) <- paste(efw_scaled$country.efw, 1:dim(efw_data_scale)[1], sep = "_")
fviz_cluster(list(data = df, cluster = km.clusters))


pravd.f = function(x,p){
    plot(x, p, # plna kolecka - v skutecnych hodnotach
        ylab='p(x)',xaxt='n',pch=19,ylim=c(0,max(p)),main="Pravdepodobnostni funkce")
    lines(c(min(x)-100,max(x)+100),c(0, 0))
    for(i in 1:length(x)){
        lines(c(min(x)-100,max(x)+100), c(p[i],p[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontalni grid
        lines(c(x[i],x[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertikalni grid
    }
    par(new=TRUE) # ze chceme kreslit do jednoho grafu
    plot(x, p*0, # prazdna kolecka - tam kde je definovana nenulova hodnota
        ylab='p(x)', xaxt='n', ylim=c(0,max(p)))
    axis(1, at=x,labels=x) # nastaveni hodnot na X
    axis(4, at=p,labels=p, las=2, cex.axis=0.7, tck=-.01) # a Y
}

dist.f = function(x,p){
    F = cumsum(p)
    F_ext = c(0, F) # natahneme F o 0 na zacatku
    x_ext = c(x[1]-1, x, x[length(x)]+1) # a x z obou stran

    plot(x, F, ylab="F(x)", xaxt='n', ylim=c(0,1), # prazdna kolecka
         type='p', main="Distribucni funkce")
    par(new=TRUE) # ze chceme kreslit do jednoho grafu
    plot(x, F_ext[1:(length(F_ext)-1)], # plna kolecka
         ylab="F(x)", xaxt='n', ylim=c(0,1), type='p', pch=19)

    for(i in 1:(length(x_ext)-1)){
        lines(c(min(x)-100,max(x)+100), c(F_ext[i],F_ext[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontalni grid
        lines(c(x_ext[i],x_ext[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertikalni grid
        lines(x_ext[i:(i+1)], c(F_ext[i],F_ext[i])) # graf - cary
    }
    axis(1, at=x,labels=x) # nastaveni hodnot na X
    axis(4, at=F,labels=F, las=2, cex.axis=0.7, tck=-.01) # a Y
    #return(F)
}

souhrn=function(x,p){
  EX = sum(x*p)
  EX2 = sum(x*x*p)
  DX = EX2-EX^2
  sigma.X = sqrt(DX)
  modus = x[match(max(p),p)]
  # zapis vysledku do tabulky
  tab = rbind(EX, DX, sigma.X, modus)
  tab.popis = c("str. hodnota","rozptyl","smer. odchylka", "modus")
  rownames(tab) = tab.popis
  colnames(tab) = ""
  return(tab)
}

# 1A
# Pouzijeme Hypergeometrickou vetu, kde vybirame pocet uspechu v n zavislych pokusech
# X ... pocet projektu bez chyb mezi 4 vybranymi
# X ~ H(N = 9, M = 6, n = 4)

x = 0:4 #pocet projektu, ktere nas zajimaji
N = 9 #celkem 9 projektu
M = 6 #celkovy pocet projektu, ktere nas zajimaji
n = 4 #pocet projektu ve vyberu

# graf pravdepodobnostni funkce pro P(X = 0 az 4)
p = dhyper(x, M, N - M, n) # hodnoty pravdepodobnostni funkce pro x
#kontrola - melo by dat 1
#sum(p) == 1
#plot(x, p)

#jednotlive pravdepodobnosti p priradime k odpovidajicim hodnotam vytyhnutemu poctu spravnych projektu
pravdep = rbind(c("P(xi)",p))
colnames(pravdep) = c("xi",0:4)
rownames(pravdep) = ""
pravdep #tabulka pravdepodobnostni funkce
pravd.f(x, p) #vykresleni

#pravdepodobnosti prubezne scitame a priradime k nim omezeni
distrib = cbind(cumsum(p),c("x<=0","0<x<=1","0<x<=1","1<x<=2","x>3"))
colnames(distrib) = c("","")
rownames(distrib) = c("","","F(x) = ","","")
distrib #predpis distribucni funkce
dist.f(x,p) #vykresleni

# 1B
# stredni hodnota je soucet vsech hodnot vynasobenych jejich pravdepodobnosti
# rozptyl pomoci E(x^2) - E(x)^2
# smerodatna odchylka je odmocnina rozptylu
# modus je hodnota nejvetsi pravdepodobnosti
# vypocet modus by bylo treba nahradit y[matchAll(max(p),p)] misto y[match(max(p),p)],
# ale chtel jsem to mit spustitelne bez knihoven (matchAll je asi v knihovne tuple?)
souhrn(x,p)

# 1C
# vybirame alespon jeden spatny projekt, takze 1 nebo 2 nebo 3 spravne (4 spatne neexistuji)
# P(x<=3)
sum(p[1:4])

# 1D
(4 - sum(x*p)) * 200000 # celkem 4 projekty a odecteme sanci na vytazeni spravnych projektu

# 1E
# vetsi nez 250 tisic bude v pripade, ze vybereme alespon dva spatne projekty
# P(x<3)
sum(p[1:3])

# 2A
# definujeme distribucni funkci
F = c(0, 0.3, 0.5, 0.9, 1)
y = c(1,10,100,1000)

# z distribucni funkce zjistime pravdepodobnosti pro omezeni
p = diff(F)
pravd.f(y, p) #vykreslime pravdepodobnosti funkci
dist.f(y, p) #vykreslime distribucni funkci

# 2B
# P(Y=100)
p[match(100,y)] #dohledame hodnotu pro 100
# P(Y >= 10)
1-F[match(10,y)] #hledame vetsi nez, takze musime odecist pravdepodobnost 10 od jednicky
p[match(10,y)] + p[match(100,y)] + p[match(1000,y)] # nebo by jsme mohli secist zmeny vetsich nez

# 2C
souhrn(y, p) # podobne jako 1B

# 2D
R = log10(y) # prepocteme si omezeni podle logaritmu

# mohlo by dojit k nesetrizenym omezenim, takze je treba setridit
idx_sorted = order(R)
R = R[idx_sorted]
p_R = p[idx_sorted]

souhrn(R, p_R)

# 3A
# integral od -2/3 do 0 pro f(x)dx = 1 kde f(x) = c(6x+8)
# c(3*x^2+8*x) => c(0*0)-c(3*(-2/3)^2+8*(-2/3)) => c(0) - c(-4) => c*4 dame rovno jedne => c = 0.25
f = function(x){return(6*x+8)} # f(x) = 6x+8
dolniMez = -2/3
horniMez = 0
1/integrate(f, dolniMez, horniMez)$value

# kdybych pocital rucne, tak si vyberu dva krajni body -2/3 a 0 a vypocitam jejich hodnoty
# jelikoz jde o primku tak tyto dva body bych spojil a dal do uzavreneho intervalu
# zbytek grafu hustoty bude na nule do nekonecen s otevrenymi intervaly

f.dens = function(x){
    res = 6/4*x+2 # 1/4(6*x+8)
    res[x < -2/3] = 0
    res[x > 0] = 0
    return(res)
}

x = seq(from = -1, to = 0.5, by = 0.01)
FX = f.dens(x)
plot(x, FX, cex = 0.2, main="Graf hustoty")

# 3B
# integral od -2/3 do 0 pro F(t) = f(x)dx
#       0                   t < -2/3
# F(t)  6/8*t^2 + 2*t + 1   t <-2/3;0>
#       1                   t > 0
# pocitam integral od -2/3 do t, kde t je mensi nez 0, pro f(x)dx
# 6/4*x+2
# 6/8*x^2+2*x
# 6/8*t^2+2*t - (6/8*(-2/3)^2+2*(-2/3)) => 6/8*t^2 + 2*t + 1 => dosadim do F(t)

F.dist = function(x){
    res = 6/8*x^2 + 2*x + 1
    res[x < -2/3] = 0
    res[x > 0] = 1
    return(res)
}

x = seq(from = -1, to = 0.5, by = 0.01)
FX = F.dist(x)
plot(x, FX, type = 'l', main="Distribucni funkce")

# 3C
# vypocet se provadi integraci hustoty pravdepodobnosti v limitach danych zadanim pripadne oseknutou limitami hustoty
# integrace provedena v 3B, pouze dosazujeme (6/8*(-1/3)^2 + 2*(-1/3) + 1) - (6/8*(-2/3)^2 + 2*(-2/3) + 1)
# P(-1 <= X <= -1/3)
integrate(f.dens, -2/3, -1/3)$value

# P(X > -1/3)
# integrace provedena v 3B, pouze dosazujeme (6/8*(0)^2 + 2*(0) + 1) - (6/8*(-1/3)^2 + 2*(-1/3) + 1)
integrate(f.dens, -1/3, 0)$value

# 3D
x_fx = function(x){
    fx = f.dens(x)
    return(x*fx)
}
xx_fx = function(x){
    fx = f.dens(x)
    return(x*x*fx)
}

# pouzijeme vzorce E(x) = integral x*f(x)dx na celem nenulovem intervalu
# E(x^2) = integral x^2*f(x)dx, pro D(x) = E(x^2) - E(x)^2
E_X = integrate(x_fx, -2/3, 0)$value
E_XX = integrate(xx_fx, -2/3, 0)$value

D_X = E_XX - E_X^2
std_X = sqrt(D_X)

cbind(c("E(X)","D(X)","sigma x"),c(E_X,D_X,std_X))

# 3E
# pro Y = 4-2x vyuzijeme vzorecku
# E(aX + b) = a*E(x)+b
# D(aX + b) = a^2*D(x)
# a hodnot, ktere jsme vypocitali v 3D
E_Y = 4 - 2*E_X # E(4-2x)
D_Y = (-2)^2*D_X # D(4-2x)
std_Y = sqrt(D_Y)

cbind(c("E(Y)","D(Y)","sigma y"),c(E_Y,D_Y,std_Y))

# 4A
# hustota se pocita derivaci distribucni funkce
# zderivujeme sin x => cos x
# f(x)  cos x <0,pi/2>
#       0 (-inf,0) nebo (pi/2,inf)
f = function(x){
    res = cos(x)     # x^2+2x+1
    res[x < 0] = 0 # 0 pro x<=0
    res[x > pi/2] = 0  # 1 pro x>1
    return(res)
}

x = seq(from = -0.5, to = 2, by = 0.01)
FX = f(x)
plot(x, FX, cex = 0.2, main="Graf hustoty")

# 4B
# median nalezi do <0,pi/2> a pocita se z distribucni funkce
F.dist = function(x){
    res = sin(x)     # x^2+2x+1
    res[x <= 0] = 0 # 0 pro x<=0
    res[x > pi/2] = 1  # 1 pro x>1
    return(res)
}

x = seq(from = -0.5, to = 2, by = 0.001)
FX = F.dist(x)
plot(x, FX, type='l', main="Pravdepodobnostni funkce a median")
lines(c(-0.5, 2),c(0.5, 0.5))

asin(0.5)
x[FX >= 0.5][1]

# 4C
# podobne jako median spocitame i pravdepodobnost 60%, akorat musime pocitat s 1-0.6
x = seq(from = -0.5, to = 2, by = 0.001)
FX = F.dist(x)
plot(x, FX, type='l', main="Pravdepodobnostni funkce a pravdepodobnost 60%")
lines(c(-0.5, 2),c(0.4, 0.4))

asin(0.4)
x[FX >= 0.4][1]

#BONUS
F = c(0, 0.1, 0.3, 0.6, 1)
y = c(0,1,2,3)

# z distribucni funkce zjistime pravdepodobnosti pro omezeni
p = diff(F)
pravd.f(y, p) #vykreslime pravdepodobnosti funkci
dist.f(y, p) #vykreslime distribucni funkci

# 2B
# P(Y=100)
p[match(2,y)] #dohledame hodnotu pro 100
# P(Y >= 10)
1-F[match(1,y)] #hledame vetsi nez, takze musime odecist pravdepodobnost 10 od jednicky

# 2A
F = c(0, 0.2, 0.4, 0.7, 1)
y = c(0,1,2,3)

p = diff(F)
pravd.f(y, p)
dist.f(y, p)

# 2B
p[match(2,y)]
1-p[match(1,y)]

# 2C
souhrn(y, p)

# 2D
R =  y-y^2
idx_sorted = order(R)
R = R[idx_sorted]
p_R = p[idx_sorted]

#souhrn(R, p_R)
EX = sum(R*p_R)
EX
DX = sum(R*R*p_R)-EX^2
DX
sigma = sqrt(DX)
sigma

#A
#c(4x-3/2x^2)
f = function(x){return(4-3*x)}
a = 0
b = 2/3
1/integrate(f, a, b)$value # obsah pod primkou je 1 a pocitame kolik je c

#vyberu si dva body v intervalu abych vedel kde jde primka hustoty
#2-3/2*0
#2-(3/2)*(2/3)

f.dens = function(x){
    res = 2 - 3/2*x
    res[x < 0] = 0
    res[x > 2/3] = 0
    return(res)
}

x = seq(from = -0.5, to = 1, by = 0.01)
FX = f.dens(x)
plot(x, FX, cex=0.2, main="Hustota")

#B
#2-3/2*x #udelam integral od 0 do 2/3 s tckama - 3 hodnoty 0, x, 1
#       0               t < 0
# F(t)  2*t - 3/4*t^2   t <0;2/3>
#       1               t > 2/3
#2 - 3/2*x
#2x - 3/4*x^2
#2t - 3/4*t^2 - (0) => dosadim do F(t)

F.dist = function(x){
    res = 2*x - 3/4*x^2     # x^2
    res[x<=0] = 0 # 0 pro x<=0
    res[x>2/3] = 1  # 1 pro x>1
    return(res)
}

x = seq(from = -0.5, to = 1, by = 0.01)
FX = F.dist(x)
plot(x, FX, type = 'l', main="Distribucni funkce") # vykreslit jako caru

#C
f.dens = function(x){
  res = 2-(3/2)*x
  res[x < 0] = 0
  res[x > 2/3] = 0
  return(res)
}

# P(-1/3 ≤ X ≤ 1/3)
integrate(f.dens, -1/3, 1/3)$value

# P(X >0.3)
integrate(f.dens, 1/3, 2/3)$value # tohle nebude vzdy fungovat

#D
x_fx = function(x){
    fx = f.dens(x)
    return(x*fx)
}
xx_fx = function(x){
    fx = f.dens(x)
    return(x*x*fx)
}

# integrujeme jen tam kde vime, ze je f(x) nenulova
E_X = integrate(x_fx, 0, 2/3)$value
E_XX = integrate(xx_fx, 0, 2/3)$value

D_X = E_XX - E_X^2
std_X = sqrt(D_X)

cbind(c("E(X)","D(X)","sigma x"),c(E_X,D_X,std_X))

#E Y = 2-4x
E_Y = 2 - 4*E_X # E(2-4x)
D_Y = (-4)^2*D_X # D(2-4x)
std_Y = sqrt(D_Y)

cbind(c("E(Y)","D(Y)","sigma y"),c(E_Y,D_Y,std_Y))

x = 0:4 #pocet projektu, ktere nas zajimaji
N = 100000 #celkem 9 projektu
M = 20000 #celkovy pocet projektu, ktere nas zajimaji
n = 4 #pocet projektu ve vyberu

# graf pravdepodobnostni funkce pro P(X = 0 az 4)
p = dhyper(x, M, N - M, n) # hodnoty pravdepodobnostni funkce pro x
#kontrola - melo by dat 1
#sum(p) == 1
#plot(x, p)

#jednotlive pravdepodobnosti p priradime k odpovidajicim hodnotam vytyhnutemu poctu spravnych projektu
pravdep = rbind(c("P(xi)",p))
colnames(pravdep) = c("xi",0:4)
rownames(pravdep) = ""
pravdep #tabulka pravdepodobnostni funkce
pravd.f(x, p) #vykresleni

#pravdepodobnosti prubezne scitame a priradime k nim omezeni
distrib = cbind(cumsum(p),c("x<=0","0<x<=1","0<x<=1","1<x<=2","x>3"))
colnames(distrib) = c("","")
rownames(distrib) = c("","","F(x) = ","","")
distrib #predpis distribucni funkce
dist.f(x,p) #vykresleni


# Correlation between two assets from Yahoo Finance using Quantmod
if (!require(quantmod)) install.packages('quantmod')
library(quantmod)

getSymbols(c("SPY","^DJI"),src="yahoo")
data=data.frame(SPY[,6],DJI[,6])
data=as.xts(data,order.by=as.Date(row.names(data),"%Y-%m-%d"))
c1=rollapply(data,65,cor,by.column=F)
Correlation=c1[,2]; chartSeries(Correlation)


# ---------> complete and run the following code for this assignment <-------
##
R code for STA302 or STA1001H1F assignment 1
# copyright by Christina (Qi) Deng
# date: Oct. 04, 2016
#
## Load in the data set
brain = read.table("/Users/christinadeng/Desktop/Fall 2016/STA 302/Assignemnt /Assignment 1/BrainData.csv",sep=" ",## create an indicator for high-IQ (value =1) and low-IQ (value=0)
highIQ = ifelse(brain$FSIQ>=130,1, 0)
## Q1: t-test on MRI count between high- and low IQ groups
# subsets by high and low intelligence group (IG)
highIG_dat <- subset(brain, highIQ==1)
lowIG_dat <- subset(brain, highIQ==0)
# mean MRI count between the high and low IG.
t.test(highIG_dat$MRIcount, lowIG_dat$MRIcount);
## Q2: correlation analysis
# cor.test() : missing value is suppressed, default setting:
# mu = 0, alternative = c("two.sided"), paired = FALSE,var.equal = FALSE
# - find correlation between MRI count and 3 IQ variables
cor.test(brain[,2], brain[,7])
cor.test(brain[,3], brain[,7])
cor.test(brain[,4], brain[,7])
# - find correlation between MRI count and 3 IQ variables in high-IQ group
cor.test(highIG_dat[,2], highIG_dat[,7])
cor.test(highIG_dat[,3], highIG_dat[,7])
cor.test(highIG_dat[,4], highIG_dat[,7])
# - find correlation between MRI count and 3 IQ variables in low-IQ group
cor.test(lowIG_dat[,2], lowIG_dat[,7])
cor.test(lowIG_dat[,3], lowIG_dat[,7])
cor.test(lowIG_dat[,4], lowIG_dat[,7])
## Q4:
# - Scatterplot of PIQ vs MRI count
plot(brain$MRIcount, brain$PIQ, main ="PIQ vs MRI count", xlab="MRIcount", ylab = "PIQ");
abline(lm(brain$PIQ~brain$MRIcount));
# - find R-square, b0, b1, MSE and p-value for b1 in high-IQ group
smart <- lm(highIG_dat$PIQ~highIG_dat$MRIcount)
summary(smart)
(summary(smart)$sigma)^2
# - find R-square, b0, b1, MSE and p-value for b1 in low-IQ group
nonsmart <- lm(lowIG_dat$PIQ~lowIG_dat$MRIcount)
summary (nonsmart)
(summary(nonsmart)$sigma)^2

# ---------> complete and run the following code for this assignment <-------
###
R code for STA302 or STA1001H1F assignment 2
# copyright by Christina Deng
# date: Nov. 6, 2016
## Load in the data set
a2 = read.table("/Users/christinadeng/Desktop/Fall 2016/STA 302/Assignemnt /Assignment 2/DataA2.txt",header=T)
## Q1: fit a linear model to FEV on age
mod1 <- lm(a2$fev~a2$age)
## ==> Q1(a) produce the scatter plot (FEV vs Age) and the residual plot with fitted value
# plot the scatter plot and residual plot in one panel
par(mfrow=c(1,2))
# make a scatter plot of the data and add regression line
plot(a2$age,a2$fev, type="p",col="blue",pch=21, main="FEV vs age",
xlab = "age", ylab = "FEV")
abline(mod1,col="red",lty=2)
# to get the residual plot vs fitted value
plot(mod1,which=1)
##==> Q1(b): boxcox transformation
library(MASS)
# get the boxcox plot
boxcox(a2$fev~a2$age)
# find exact value of lambda
a=boxcox(a2$fev~a2$age, lambda=seq(-2, 4, 0.01))
Elambda= a$x[which.max(a$y)]
Elambda
## Q2
# fit a linear model to log(FEV) on age
m2 <- lm(log(fev) ~ age, data = a2)
# plot the scatter plot and residual plot in one panel
par(mfrow=c(1,2))
# make a scatter plot of the data and add regression line
plot(a2$age,log(a2$fev), type="p",col="blue",pch=21, main="log(FEV) vs age", xlab = "age", ylab = "log(FEV)")
abline(m2,col="red",lty=2)
# make a residual plot vs fitted value of mod 2 (m2)
plot(m2, which=1)
# get information on its slope and intercept
summary(m2)
# find 95% CI in untransformed scale
i <- predict(m2, interval = "confidence", newdata = data.frame(age = c(8, 17, 21)))
exp(i)
# find 95% PI in untransformed scale
j <- predict(m2,interval = "prediction", newdata = data.frame(age = c(8, 17, 21)))
exp(j)

# ---------> complete and run the following code for this assignment <-------
###
R code for STA302 or STA1001H1F assignment 3
# copyright by Christina Deng
# date: Nov. 30, 2016
## Load in the data set
a3 <- read.table("/Users/christinadeng/Desktop/Fall 2016/STA 302/Assignemnt /Assignment 3/a3data.txt",sep="",header=str(a3)
is.factor(a3$gender) # TRUE
is.factor(a3$smoke) # FALSE
a3$smoke = as.factor(a3$smoke) # convert smoke to a factor variable
is.factor(a3$smoke) # TRUE
a3$logPlasma <- log(a3$plasma)
head(a3)
## Q1:
# get the p-value of these pairs of variables
Find_Pvalue <- function(x, y, ...) {
horizontal <- (par("usr")[1] + par("usr")[2]) / 2;
vertical <- (par("usr")[3] + par("usr")[4]) / 2;
text(horizontal, vertical, format(cor.test(x,y)$p.value, digits=2))
}
pairs(a3[, c(1,4,6:11,13)], main = "P value plot", pch = 21,
bg = c("pink","yellow","purple"), upper.panel=Find_Pvalue)
# get the correlation of these pairs of variables
Find_correlation <- function(x, y, ...) {
horizontal <- (par("usr")[1] + par("usr")[2]) / 2;
vertical <- (par("usr")[3] + par("usr")[4]) / 2;
text(horizontal, vertical, format(abs(cor(x,y)), digits=2))
}
pairs(a3[, c(1,4,6:11,13)], main = "Correlations Plot", pch = 21,
bg = c("pink","yellow","purple"), upper.panel=Find_correlation)
# Strong correlation: Calories & Fat (0.9); Calories & CHL(0.67); Fat & CHL(0.71)
# Moderate correlation: Calories & Fiber (0.5); Fiber & DBC (0.48)
## Q2
# Fit the three regression equations
mod1 <- lm(logPlasma ~ Calories, data = a3)
mod2 <- lm(logPlasma ~ Calories + fat, data = a3)
mod3 <- lm(logPlasma ~ Calories + QI, data = a3)
summary(mod1) #p-value:0.2011; coeff of Calories: -8.586e-05
summary(mod2) #p-value:0.002872; coeff of Calories: 0.0003506
summary(mod3) #p-value:-8.252e-05; coeff of Calories: 9.192e-07
## Q3:
# fit the complete modeal
commod <- lm(logPlasma ~ age + factor(gender) + factor(smoke) + QI + factor(Vitamin) + Calories + fat + fiber + alcohol summary(commod)
## Q4
# no predictor in the model
nullmod <- lm(logPlasma ~ 1, data = a3)
# with all predictors in the model
fullmod <- lm(logPlasma ~ age + factor(gender) + factor(smoke) + QI + factor(Vitamin) + Calories + fat + fiber + alcohol # stepwise method: apply both directions method
bothways = step(nullmod ,scope=list(lower=formula(nullmod),upper=formula(fullmod)), direction="both")
formula(bothways)


f <- function(net) {
    return ( 1/(1+exp(-net)) )
}

df_dnet <- function(f_net) {
    return (f_net * (1 - f_net))
}

mlp.architecture <- function(input.length=2,
                             hidden.length=2,
                             output.length=1,
                             activation.function=f,
                             d_activation.function=df_dnet) {

    model = list()
    model$input.length = input.length
    model$hidden.length = hidden.length
    model$output.length = output.length

    model$hidden = matrix(runif(min=-0.5, max=0.5,
            hidden.length*(input.length+1)),
                   nrow=hidden.length, ncol=input.length+1)

    model$output = matrix(runif(min=-0.5, max=0.5,
            output.length*(hidden.length+1)),
                   nrow=output.length, ncol=hidden.length+1)

    model$f = activation.function
    model$df_dnet = d_activation.function

    return (model)
}

mlp.forward <- function(model, Xp) {
    # Hidden layer
    net_h_p = model$hidden %*% c(Xp, 1)
    f_net_h_p = model$f(net_h_p)

   # Output layer
   net_o_p = model$output %*% c(as.numeric(f_net_h_p), 1)
   f_net_o_p = model$f(net_o_p)

   # Results
   ret = list()
   ret$net_h_p = net_h_p
   ret$net_o_p = net_o_p
   ret$f_net_h_p = f_net_h_p
   ret$f_net_o_p = f_net_o_p

   return (ret)
}

mlp.backpropagation <- function(model,
                                dataset,
                                eta=0.1,
                                threshold=1e-4) {

    squaredError = 2 * threshold
    counter = 0

    while(squaredError > threshold) {
        squaredError = 0

        for (p in 1:nrow(dataset)) {
            Xp = as.numeric(dataset[p, 1:model$input.length])
            Yp = as.numeric(dataset[p,
                    (model$input.length+1):ncol(dataset)])

            results = mlp.forward(model, Xp)
            Op = results$f_net_o_p

            # Calculando o erro
            error = Yp - Op

            squaredError = squaredError + sum(error^2)

            delta_o_p = error * model$df_dnet(results$f_net_o_p)

            w_o_kj = model$output[,1:model$hidden.length]
            delta_h_p =
                as.numeric(model$df_dnet(results$f_net_h_p)) *
                    (as.numeric(delta_o_p) %*% w_o_kj)

            model$output = model$output +
                eta*(delta_o_p%*%as.vector(c(results$f_net_h_p,1)))
            model$hidden = model$hidden +
                eta*(t(delta_h_p) %*% as.vector(c(Xp,1)))
        }
        squaredError = squaredError / nrow(dataset)

        cat("Erro médio quadrado = ", squaredError, "\n")

        counter = counter + 1
    }
    cat("Base treinada Daniel, SEU GOSTOSO!\n")
    ret = list()
    ret$model = model
    ret$counter = counter

    return (ret)
}

dataset = read.csv('__dataset.csv', header=F, skip=1)
dataset <- dataset[c(1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14, 15, 8)]
ids = sample(1:nrow(dataset), size=33)
training = dataset[ids,]
test = dataset[-ids,]
model = mlp.architecture(input.length=14, output.length=1, hidden.length=15)
trained = mlp.backpropagation(dataset=training, model=model, eta=0.5)
write.csv(trained$model$hidden, file="hidden.csv", row.names=FALSE)
write.csv(trained$model$output, file="output.csv", row.names=FALSE)


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

predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

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

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

t <- read_csv("../processed_results/varying_eps_N100_max1.csv")

t %>% mutate(q=1-epistasis_coef) %>%
  group_by(q,sel_coef,mu_prob,k_start,rep) %>%
  summarise(mean_f_over_time=mean(mean_fitness)) -> t_sum

for (s in c(0.01, 0.001, 0.0001)){
  t_sum %>% filter(sel_coef==s) -> f
  Ne <- t$Ne[1]
  L <- t$L[1]
  an_f <- w_vs_eps(Ne, L, s, -1, 1) %>% mutate(q=1-eps)
  q_est <- qmin(s,Ne,100)

  p <- ggplot()+
    stat_summary(data=f,
                 inherit.aes=FALSE,
                 aes(x=q,y=mean_f_over_time,color=factor(mu_prob)),
                 fun.y = mean,
                 fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
                 fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
                 geom = "pointrange",
                 size=0.4)+
    geom_line(data=an_f, aes(x=q,y = w_ave))+
    #geom_vline(xintercept = q_est, linetype = 2)+
    #draw_text(x = q_est+0.02, y =1, hjust = 0, vjust = 1, text = "predicted q*", size = 12)+
    #scale_y_continuous(breaks=seq(0.2,1,0.2))+
    coord_cartesian(ylim=c(0.7,1),xlim=c(0,2))+
    guides(col = guide_legend(title="\u03BC"))+
    theme(axis.title = element_text(size = 14),
          axis.text = element_text(size = 12),
          legend.text = element_text(size = 11),
          legend.title = element_text(size = 12),
          legend.position = "none")+
    xlab('Q') +
    ylab('Mean fitness')
  save_plot(paste0("../plots/mean_fit_v_Q_s",s,"_N",Ne,"_max1.png"), p)
}

p3 <- make_fig(L = 100, s = 0.001, N = 100)


inverse.logit = function( x ) {
  # x should be the log odds ratio
  oddsratio = exp(x)
  prob = oddsratio / (1 + oddsratio )
  return (prob)
}


#' The zero-truncated compund poisson-lognormal distributions
#'
#' Density function and random generation for Zero-Trauncated Poisson Lognormal
#' distribution with parameters `mu` and sd `sig`.
#'
#' A compound Poisson-lognormal distribution is a Poisson probability
#' distribution where its parameter \eqn{\lambda} is a random variable with
#' lognormal distribution, that is to say \eqn{log\lambda} are normally
#' distributed with mean \eqn{\mu} and variance \eqn{\sigma^2} (Bulmer 1974).
#' The zero-truncated Poisson-lognormal distribution can be derived from a
#' zero-truncated Poisson distribution.
#'
#' Type 1 ZTPLN truncates zero based on Poisson-lognormal distribution and
#' type 2 ZTPLN truncates zero based on zero-truncated Poisson distribution.
#' For mathematical details, please see `vignette("ztpln")`
#'
#' @param n number of random values to return.
#' @param x	vector of (non-negative integer) quantiles.
#' @param mu mean of lognormal distribution.
#' @param sig standard deviation of lognormal distribution.
#' @param log logical; if TRUE, probabilities p are given as log(p).
#' @param type1 logical; if TRUE, Use type 1 ztpln else use type 2.
#' @return dztpln gives the (log) density and rztpln generates
#' random variates.
#' @references Bulmer, M. G. 1974. On Fitting the Poisson Lognormal Distribution to Species-Abundance Data. Biometrics 30:101-110.
#'
#' @seealso \code{\link{dztplnm}}
#'
#' @examples
#' rztpln(n = 10, mu = 0, sig = 1, type1 = TRUE)
#' rztpln(n = 10, mu = 6, sig = 4, type1 = TRUE)
#' dztpln(x = 1:5, mu = 1, sig = 2)
#' @export
dztpln <- function(x, mu, sig, log = FALSE, type1 = TRUE) {
  if (length(mu) > 1 | length(sig) > 1)
    stop("Vectorization of parameters not implemented")
  if (sig < 0) stop("sig needs to be > 0")
  if (any(!DistributionUtils::is.wholenumber(x))) warning("non integer values in x")
  if (min(x) <= 0) warning("zero in x")
  x <- x[x > 0]
  if (type1) {
    lik <- do_dztpln(x, mu, sig)
  } else lik <- do_dztpln2(x, mu, sig)
  if (log) return(log(lik)) else return(lik)
}

#' @rdname dztpln
#' @export
rztpln <- function(n, mu, sig, type1 = TRUE) {
  if (length(mu) > 1 | length(sig) > 1)
     stop("Vectorization of parameters not implemented")
  if (sig < 0) stop("sig needs to be > 0")
  if (sig > 15) stop("standard deviation > 15 in log-scale is too large")
  if (type1) do_vec_rztpln1(n, mu, sig) else do_vec_rztpln2(n, mu, sig)
}


# Pull PWT into dataframe
data("pwt9.1")

p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$si<- round(p$csh_i,digits=2)

p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.pop = dplyr::lag(pop, n = 10, default = NA))
p$g10.pop <- (log(p$pop) - log(p$lag10.pop))/10

p <- p[which((p$g10.pop>-.01) & (p$g10.pop <.06)),]
p <- p[which((p$si>0) & (p$g10.pop <.6)),]
p <-  p[which(p$year %in% c(1950,1960,1970,1980,1990,2000,2010,2015)),]

fig <- plot_ly(p,
               x = ~si,
               y = ~lngdppc,
               size = ~pop,
               frame = ~year,
               text = ~country,
               hoverinfo = "text",
               type = 'scatter',
               mode = 'markers'
) %>% animation_opts(frame=2000, transition=200)
fig <- fig %>% animation_button(
  x = 1, xanchor = "right", y = 0.4, yanchor = "bottom"
)
fig <- layout(fig, title = list(text = 'Level of GDP p,c. and capital formation', x=0),
              xaxis = list(title = 'Capital formation share of GDP'),
              yaxis = list (title = 'Log GDP per capita')
)

api_create(fig, filename = "pwt-corr-si")

fig <- plot_ly(p,
               x = ~g10.pop,
               y = ~lngdppc,
               size = ~pop,
               frame = ~year,
               text = ~country,
               hoverinfo = "text",
               type = 'scatter',
               mode = 'markers'
) %>% animation_opts(frame=2000, transition=200)
fig <- fig %>% animation_button(
  x = 1, xanchor = "right", y = 0.4, yanchor = "bottom"
)
fig <- layout(fig, title = list(text = 'Level of GDP p,c. and population growth', x=0),
              xaxis = list(title = '10-year annualized pop growth rate'),
              yaxis = list (title = 'Log GDP per capita')
)

api_create(fig, filename = "pwt-corr-gl")


#Developing multivariate normal with covariance. This recovers species abundances and covariance matrix.
#Eventually extend to dirlichet case.
#clear ennvironment, load packages.
rm(list=ls())
library(runjags)

#try with simulated data
y1 <- round(rnorm(100, 100, 5))
y2 <- round(y1*-2 + rnorm(100,0,5)) + 400
y3 <- round(rnorm(100,50,5))
y4 <- round(rnorm(100,50,5))
spp.y <- data.frame(y1,y2,y3,y4)
spp.y <- as.matrix(spp.y)
seqs <- rowSums(spp.y)

#introduce a sequence depth effect.
#Get a integer value to multiply species abundances by.
#effort <- round(runif(100,5,50))
#spp.y2 <- spp.y * effort
#eqs <- rowSums(spp.y2)
#seqs <- rep(1,nrow(spp.y))

jags.model = "
model {
#setup priors for each species
for(j in 1:N.spp){
  m0[j] ~ dnorm(0, .001) #intercept prior
}

#Sigma (covariance matrix) prior
sigma ~ dwish(r,S)

#implement multivariate normal.
for(i in 1:N){
  y.hat[i,1:N.spp] <- (m0[1:N.spp]) * seqs[i]
      y[i,1:N.spp] ~ dmnorm(y.hat[i,1:N.spp], sigma[1:N.spp,1:N.spp])
}

} #close model loop.
"

#Wish prior on covariance - weak covariance.
W = diag(ncol(spp.y))/10000

jags.data <- list(y = spp.y,
                  N = nrow(spp.y),
                  N.spp = ncol(spp.y),
                  r = W,
                  S = ncol(spp.y),
                  seqs = seqs)

jags.out <- run.jags(jags.model,
                     data=jags.data,
                     adapt = 100,
                     burnin = 3000,
                     sample = 2000,
                     n.chains=3,
                     monitor=c('m0','sigma'))

#true relative abundances across samples.
colMeans(spp.y) / sum(colMeans(spp.y))
#estimated relative abundances
summary(jags.out)[grep('m0',rownames(summary(jags.out))),'Median']

#Get estimated covariance matrix
z <- summary(jags.out)[grep('sigma',rownames(summary(jags.out))),'Median']
z.lo.95 <- summary(jags.out)[grep('sigma',rownames(summary(jags.out))),'Lower95']
z.hi.95 <- summary(jags.out)[grep('sigma',rownames(summary(jags.out))),'Upper95']
i.covm <- matrix(z, ncol = sqrt(length(z)))
i.covm.lo <- matrix(z.lo.95, ncol = sqrt(length(z.lo.95)))
i.covm.hi <- matrix(z.hi.95, ncol = sqrt(length(z.hi.95)))
solve(i.covm) #jags returns the inverse of the covariance matrix. This inverts it.

#What is the covariance of real data?
#spp.y.cov <- spp.y2 / seqs
#cov(spp.y.cov)
cov(spp.y)
cov(spp.y2)

cov2cor(cov(spp.y2))
(cov2cor(cov(spp.y)))^2

cov2cor(solve(i.covm))
cov2cor(solve(i.covm.lo))
cov2cor(solve(i.covm.hi))


#' ---
#' subtitle: Exploring incomplete gamma function
#' output: html_document
#' ---
#'
source("notebooks/eda_startup.r")
devtools::load_all(path = ".")
#'
#'
#' Incomplete gamma-function
#'
#' @param n day `n`
daily_lactation_f <- function(n, a, b, c) {
  a * n ** b * exp(-c * n)
}
#' @inheritParams daily_lactation_f
daily_lactation_df <- function(n, a, b, c) {
  #' alternative: `a exp(-c n) (b n^(-1 + b) - c n^b)`
  a * exp(-c * n) * n^(-1 + b) * (b - c * n)
}
#'
#'
#' Source: [Application of the Incomplete Gamma Function to
#' Predict Cumulative Milk Production](https://www.sciencedirect.com/science/article/pii/S0022030280828955)
#'
tibble(lactation = "first",
       a = 13.546, b = 19.575 / 1e2, c = 3.388 / 1e3) %>%
  add_row(lactation = "second",
          a = 18.820, b = 23.576 / 1e2, c = 5.441 / 1e3) %>%
  add_row(lactation = "third and more",
          a = 15.956, b = 30.004 / 1e2, c = 6.067 / 1e3) %>%
  mutate(lactation = fct_inorder(lactation)) %>%

  #' Change `a` to opposite sign just to get the curve that we are exploring
  mutate(a = -a) %>%

  #' Add suggested peaks
  mutate(peak_location = b/c) %>%
  # mutate(peak_level = ???) %>%

  #' Evaluate lactation-curve
  expand_grid(n = seq_len(305)) %>%
  mutate(daily_lactation_f  =
           pmap_dbl(select(., n, a, b, c), daily_lactation_f)) %>%
  mutate(daily_lactation_df  =
           pmap_dbl(select(., n, a, b, c), daily_lactation_df)) %>%
  pivot_longer(starts_with("daily_lactation")) %>%
  identity() %>% {
    ggplot(.) +
      # aes(n, daily_lactation_f,
      aes(n, value,
          groups = interaction(name, lactation),
          color = lactation) +
      geom_line() +

      geom_vline(aes(xintercept = peak_location,
                     color = lactation),
                 data = . %>% distinct(peak_location, lactation)) +
      facet_wrap(~name, ncol = 1, scales = "free_y") +
      NULL
  }
#'
#'
#'


# Master Thesis Project - Extreme Value Theory
# We use here QQ-plots to assess graphically the
# goodness of fit of our extreme distributions for
# the high ( above high quantile) and low (below low
# quantile) log-returns

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

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

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

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

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

# Fitting

	data_bnp <- diff(log(df_plain[[1]]))
	data_carrefour <- diff(log(df_plain[[2]]))
	data_lvmh <- diff(log(df_plain[[3]]))
	data_sanofi <- diff(log(df_plain[[4]]))
	data_total <- diff(log(df_plain[[5]]))

	# Computing the 95 % - quantiles  [97.5 % - quantile in the case of the LVMH stock]
	# and the 5 % quantiles for each of the stocks
	highQuantiles <- c(quantile(data_bnp,0.99), quantile(data_carrefour,0.995), quantile(data_lvmh,0.995),
					quantile(data_sanofi,0.995), quantile(data_total,0.995))
	lowQuantiles <- c(quantile(-data_bnp,0.01), quantile(-data_carrefour,0.005), quantile(-data_lvmh,0.005),
					quantile(-data_sanofi,0.005), quantile(-data_total,0.005))

	# Getting the data above the high threshold and below the low threshold
	data_bnp_H <- diff(log(df_plain[[1]]))
	data_bnp_H <- data_bnp_H[data_bnp_H > highQuantiles[1]]

	data_bnp_L <- -diff(log(df_plain[[1]]))
	data_bnp_L <- data_bnp_L[data_bnp_L < lowQuantiles[1]]

	data_carrefour_H <- diff(log(df_plain[[2]]))
	data_carrefour_H <- data_carrefour_H[data_carrefour_H > highQuantiles[2]]

	data_carrefour_L <- -diff(log(df_plain[[2]]))
	data_carrefour_L <- data_carrefour_L[data_carrefour_L < lowQuantiles[2]]

	data_lvmh_H <- diff(log(df_plain[[3]]))
	data_lvmh_H <- data_lvmh_H[data_lvmh_H > highQuantiles[3]]

	data_lvmh_L <- -diff(log(df_plain[[3]]))
	data_lvmh_L <- data_lvmh_L[data_lvmh_L < lowQuantiles[3]]

	data_sanofi_H <- diff(log(df_plain[[4]]))
	data_sanofi_H <- data_sanofi_H[data_sanofi_H > highQuantiles[4]]

	data_sanofi_L <- -diff(log(df_plain[[4]]))
	data_sanofi_L <- data_sanofi_L[data_sanofi_L < lowQuantiles[4]]

	data_total_H <- diff(log(df_plain[[5]]))
	data_total_H <- data_total_H[data_total_H > highQuantiles[5]]

	data_total_L <- -diff(log(df_plain[[5]]))
	data_total_L <- data_total_L[data_total_L < lowQuantiles[5]]

	# Fitting the data, and getting the corresponding location, scale and
	# shape parameters respectively, for each stock
	# Fitting the log-returns for the above-high-threshold data
	bnp_fit_H <- (gev.fit(data_bnp_H))
	carrefour_fit_H <- gev.fit(data_carrefour_H)
	lvmh_fit_H <- gev.fit(data_lvmh_H)
	sanofi_fit_H <- gev.fit(data_sanofi_H)
	total_fit_H <- gev.fit(data_total_H)
	# Fitting the minus log-returns for the below-low-threshold data
	bnp_fit_L <- (gev.fit(data_bnp_L))
	carrefour_fit_L <- gev.fit(data_carrefour_L)
	lvmh_fit_L <- gev.fit(data_lvmh_L)
	sanofi_fit_L <- gev.fit(data_sanofi_L)
	total_fit_L <- gev.fit(data_total_L)

	# Saving the GEV parameters for later use
	params_bnp_H <- bnp_fit_H$mle
	params_carrefour_H <- carrefour_fit_H$mle
	params_lvmh_H <- lvmh_fit_H$mle
	params_sanofi_H <- sanofi_fit_H$mle
	params_total_H <- total_fit_H$mle

	params_bnp_L <- bnp_fit_L$mle
	params_carrefour_L <- carrefour_fit_L$mle
	params_lvmh_L <- lvmh_fit_L$mle
	params_sanofi_L <- sanofi_fit_L$mle
	params_total_L <- total_fit_L$mle

# Drawing the QQ-plots
	# BNP stock

		N_bnp_H <- length(data_bnp_H)
		qVect_bnp_H <- (N_bnp_H + 1 - 1:N_bnp_H)/(N_bnp_H + 1)
		N_bnp_L <- length(data_bnp_L)
		qVect_bnp_L <- (N_bnp_L + 1 - 1:N_bnp_L)/(N_bnp_L + 1)

		# Ordering the samples
		data_bnp_H <- sort(data_bnp_H)
		data_bnp_L <- sort(data_bnp_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_bnp_H <- qgev(qVect_bnp_H ,params_bnp_H[3],params_bnp_H[1],params_bnp_H[2])
		gev_bnp_L <- qgev(qVect_bnp_L ,params_bnp_L[3],params_bnp_L[1],params_bnp_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_BNP_High.png")
		plot(qVect_bnp_H,gev_bnp_H, main = "QQ-plot BNP Paribas, above \n99 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_bnp_H~qVect_bnp_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_BNP_Low.png")
		plot(qVect_bnp_L,gev_bnp_L, main = "QQ-plot BNP Paribas, below \n1 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_bnp_L~qVect_bnp_L), col = "blue")
		dev.off()
		graphics.off()

	# Carrefour stock

		N_carrefour_H <- length(data_carrefour_H)
		qVect_carrefour_H <- (N_carrefour_H + 1 - 1:N_carrefour_H)/(N_carrefour_H + 1)
		N_carrefour_L <- length(data_carrefour_L)
		qVect_carrefour_L <- (N_carrefour_L + 1 - 1:N_carrefour_L)/(N_carrefour_L + 1)

		# Ordering the samples
		data_carrefour_H <- sort(data_carrefour_H)
		data_carrefour_L <- sort(data_carrefour_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_carrefour_H <- qgev(qVect_carrefour_H ,params_carrefour_H[3],params_carrefour_H[1],params_carrefour_H[2])
		gev_carrefour_L <- qgev(qVect_carrefour_L ,params_carrefour_L[3],params_carrefour_L[1],params_carrefour_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_Carrefour_High.png")
		plot(qVect_carrefour_H,gev_carrefour_H, main = "QQ-plot Carrefour, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_carrefour_H~qVect_carrefour_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_Carrefour_Low.png")
		plot(qVect_carrefour_L,gev_carrefour_L, main = "QQ-plot Carrefour, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_carrefour_L~qVect_carrefour_L), col = "blue")
		dev.off()
		graphics.off()

	# LVMH stock

		N_lvmh_H <- length(data_lvmh_H)
		qVect_lvmh_H <- (N_lvmh_H + 1 - 1:N_lvmh_H)/(N_lvmh_H + 1)
		N_lvmh_L <- length(data_lvmh_L)
		qVect_lvmh_L <- (N_lvmh_L + 1 - 1:N_lvmh_L)/(N_lvmh_L + 1)

		# Ordering the samples
		data_lvmh_H <- sort(data_lvmh_H)
		data_lvmh_L <- sort(data_lvmh_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_lvmh_H <- qgev(qVect_lvmh_H ,params_lvmh_H[3],params_lvmh_H[1],params_lvmh_H[2])
		gev_lvmh_L <- qgev(qVect_lvmh_L ,params_lvmh_L[3],params_lvmh_L[1],params_lvmh_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_LVMH_High.png")
		plot(qVect_lvmh_H,gev_lvmh_H, main = "QQ-plot LVMH, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_lvmh_H~qVect_lvmh_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_LVMH_Low.png")
		plot(qVect_lvmh_L,gev_lvmh_L, main = "QQ-plot LVMH, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_lvmh_L~qVect_lvmh_L), col = "blue")
		dev.off()
		graphics.off()

	# Sanofi stock

		N_sanofi_H <- length(data_sanofi_H)
		qVect_sanofi_H <- (N_sanofi_H + 1 - 1:N_sanofi_H)/(N_sanofi_H + 1)
		N_sanofi_L <- length(data_sanofi_L)
		qVect_sanofi_L <- (N_sanofi_L + 1 - 1:N_sanofi_L)/(N_sanofi_L + 1)

		# Ordering the samples
		data_sanofi_H <- sort(data_sanofi_H)
		data_sanofi_L <- sort(data_sanofi_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_sanofi_H <- qgev(qVect_sanofi_H ,params_sanofi_H[3],params_sanofi_H[1],params_sanofi_H[2])
		gev_sanofi_L <- qgev(qVect_sanofi_L ,params_sanofi_L[3],params_sanofi_L[1],params_sanofi_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_Sanofi_High.png")
		plot(qVect_sanofi_H,gev_sanofi_H, main = "QQ-plot Sanofi, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_sanofi_H~qVect_sanofi_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_Sanofi_Low.png")
		plot(qVect_sanofi_L,gev_sanofi_L, main = "QQ-plot Sanofi, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_sanofi_L~qVect_sanofi_L), col = "blue")
		dev.off()
		graphics.off()

	# Total stock

		N_total_H <- length(data_total_H)
		qVect_total_H <- (N_total_H + 1 - 1:N_total_H)/(N_total_H + 1)
		N_total_L <- length(data_total_L)
		qVect_total_L <- (N_total_L + 1 - 1:N_total_L)/(N_total_L + 1)

		# Ordering the samples
		data_total_H <- sort(data_total_H)
		data_total_L <- sort(data_total_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_total_H <- qgev(qVect_total_H ,params_total_H[3],params_total_H[1],params_total_H[2])
		gev_total_L <- qgev(qVect_total_L ,params_total_L[3],params_total_L[1],params_total_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_Total_High.png")
		plot(qVect_total_H,gev_total_H, main = "QQ-plot Total, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_total_H~qVect_total_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_Total_Low.png")
		plot(qVect_total_L,gev_total_L, main = "QQ-plot Total, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_total_L~qVect_total_L), col = "blue")
		dev.off()
		graphics.off()


h = max(10, plantHeight) / 100.0
conductance = (wind * vonKarman** 2) / (log((heightWeatherMeasurements - d * h) / (zm * h)) * log((heightWeatherMeasurements - d * h) / (zh * h)))


## 3. Populations and Samples ##

# question_1 <- ''
# question_2 <- ''
# question_3 <- ''
# question_4 <- ''
# question_5 <- ''
question_1 <- 'population'
question_2 <- 'population'
question_3 <- 'sample'
question_4 <- 'population'
question_5 <- 'sample'

## 4. Explore the Dataset ##

library(readr)
wnba <- read_csv("wnba.csv")

## 5. Sampling Error ##

set.seed(1)
parameter <- max(wnba$Games_Played)
sample <- sample(wnba$Games_Played, size = 30)
statistic <- max(sample)
sampling_error <- parameter - statistic

## 6. Simple Random Sampling ##

set.seed(1)
sample_1 <- mean(sample(wnba$PTS, size = 10))
sample_2 <- mean(sample(wnba$PTS, size = 10))
sample_3 <- mean(sample(wnba$PTS, size = 10))

## 7. Generating Numerous Random Samples ##

set.seed(1)
mean_points <- replicate(n = 100,
          expr = mean(sample(wnba$PTS, size = 10)))
minimum <- min(mean_points)
maximum <- max(mean_points)

## 8. Visualizing Random Samples ##

library(tibble)
library(ggplot2)
set.seed(1)
mean_points <- replicate(n = 100,
          expr = mean(sample(wnba$PTS, size = 10)))
sample_number <- 1:100
df <- tibble(x = sample_number, y = mean_points)
ggplot(data = df,
       aes(x = sample_number, y = mean_points)) +
    geom_point() +
    geom_hline(yintercept = mean(wnba$PTS),
               color = "blue") +
    ylim(90, 310)

Data Analyst in R/Step 5 - Probability and Statistics/1. Statistics Fundamentals in R/1. Simple Random Sampling.r


#' Calculates Future Value
#'
#' @param p numeric
#' @param r numeric
#' @param t numeric
#'
#' @return numeric
#' @export
#'
#' @examples
#' future_value(2500, 0.043, 8/12) #2571.67
future_value <- function(p, r, t) {
  p*(1+r*t)
  # Predicts the future value of the money invested
}


library(dplyr)
library(rafalib)

data <- read.csv("week2/mice_pheno.csv") %>% na.omit

x <- filter(data,
            Sex == "M",
            Diet == "chow") %>%
  select(Bodyweight) %>%
  unlist

# Q1
mean(x)

# Q2
popsd(x)

set.seed(1)
X <- sample(x, 25)
mean(X)

y <- filter(data,
            Sex == "M",
            Diet == "hf") %>%
  select(Bodyweight) %>%
  unlist

# Q3
mean(y)

# Q4
popsd(y)

# Q5
set.seed(1)
Y <- sample(y, 25)
mean(Y)

# Q6
set.seed(1)
abs((mean(y) - mean(x)) - (mean(Y) - mean(X)))


#Data preprocess template

#Importing the dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Split the dataset into the Training set and test set
# library(caTools)
# set.seed(123)
# split = sample.split(dataset$Purchased, SplitRatio = 0.8)
# training_set = subset(dataset, split==TRUE)
# test_set = subset(dataset, split==FALSE)

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

# Fitting Linear Regression to the dataset
lin_reg = lm(formula = Salary ~ ., data = dataset)

# Fitting Polynomial Regression to Dataset
dataset$Level2 = dataset$Level^2
dataset$Level3 = dataset$Level^3
dataset$Level4 = dataset$Level^4
dataset$Level6 = dataset$Level^6

poly_reg = lm(formula = Salary ~ ., data = dataset)

#Visualizing Linear Regression Results
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             color = 'red') +
  geom_line(aes(x=dataset$Level, y = predict(lin_reg, newdata = dataset)),
            color = 'blue') +
  ggtitle('Truth Or Bluff') +
  xlab("Level") +
  ylab("Salary")

# Visualizing Poly Regression To Dataset
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             color = 'red') +
  geom_line(aes(x=dataset$Level, y = predict(poly_reg, newdata = dataset)),
            color = 'blue') +
  ggtitle('Truth Or Bluff (Poly)') +
  xlab("Level") +
  ylab("Salary")

# Predicting a new result with linear Regression
y_pred = predict(lin_reg, data.frame(Level = 6.5))

# Predicting a new result with Poly Regression
y_pred = predict(poly_reg, data.frame(Level = 6.5,
                                      Level2 = 6.5^2,
                                      Level3 = 6.5^3,
                                      Level4 = 6.5^4,
                                      Level6 = 6.5^6))

Machine Learning A-Z Template Folder/Part two - Regression/Section 6 - Polynomial Regression/poly_reg.r


# an example of a greta function

# pull out the necessary internal functions from greta
op <- .internals$nodes$constructors$op
#' @importFrom  stats var median quantile
#' @import greta
#'
#' @title compute the Bayesian R square for a greta regression model
#' @export
#'
#' @description Compute a Bayesian version of R-square for regression models (GLMs ...)
#'
#' @usage ## S3 method for class 'mcmc.list'
#'  bayes_R2(y, pred, draws, summary = TRUE, probs = c(0.1, 0.9))
#'
#' @param y a greta array, the response variables
#' @param pred a greta array, the linear predictor
#' @param draws a greta_mcmc_list, posterior draws as returned from calling greta sampling algorithm (ie mcmc)
#' @param summary a logical, if TRUE (default) the function output summary statistics (mean, sd, 80% credible intervals) for the R2, if FALSE the raw values are returned
#' @param probs a vector of two numeric specifying the lower and upper limits for the credible intervals (default to 0.1, 0.9), only used if summary=TRUE
#'
#' @return If summary=TRUE a 1 x C matrix is returned (C = length(probs) + 2) containing summary statistics of Bayesian R-squared values. If summary = FALSE the posterior samples of the R-squared values are returned as a numeric vector of length S (S is the number of samples)
#'
#' @details See https://github.com/jgabry/bayes_R2/blob/master/bayes_R2.pdf for a description of the computation. Note that R2 only univariate models are supported. This function is largely inspired from brms::bayes_R2.
#'
#'
#' @examples
#' \dontrun{
#' intercept <- normal(0, 1)
#' slope <- normal(0, 1)
#' sd_resid <- cauchy(0, 1, truncation = c(0, 100))
#'
#' x <- runif(100)
#' y <- as_data(rnorm(100, 1 + 2 * x, 1))
#'
#' pred <- intercept + slope * x
#' distribution(y) <- normal(pred, sd_resid)
#'
#' m <- model(intercept, slope, sd_resid)
#' drr <- mcmc(m)
#'
#' bayes_R2(y, pred, drr)
#' }

bayes_R2 <- function(y, pred, draws, summary = TRUE, probs = c(0.1, 0.9)){

  # test that correct objects are being passed
  ## to dev

  # get the posterior draws for the linear predictor
  ypred <- calculate(pred, values = draws)

  # posterior residuals
  e <- -1 * sweep(as.matrix(ypred), 2, as.matrix(y))

  # variance in linear predictors
  var_ypred <- apply(as.matrix(ypred), 1, var)

  # variance in residuals
  var_e <- apply(e, 1, var)

  # R2 values
  post_r2 <- var_ypred / (var_ypred + var_e)

  # if summary=FALSE return these values
  if(summary){
    # get summary stats
    med <- median(post_r2)
    mad <- median(abs(post_r2 - med))
    ci <- quantile(post_r2, probs = probs)
    out <- matrix(c(med, mad, ci),ncol = 4,
                  dimnames = list("",
                                  c("median", "mad", "low-ci", "high-ci")))
    return(out)

  } else{
    return(post_r2)
  }
}


library(zoo)
library("ggplot2")
library(gridExtra)
library(grid)
library(qdapTools)

setwd("C:/Code/climData/glaser2019")

hhi <- read.csv("csv/hhi_summer_1000_2019.csv", sep=",", na = "NA")

cook <- read.csv("https://raw.githubusercontent.com/climdata/cook2015/master/csv/cook_de.csv", sep=",")

both <- merge(hhi,cook, by=c("year"))

new <- subset(both, both$year<1996 & both$year>1499)
old <- subset(both, both$year<1500 & both$year>999)

old <- subset(old, old$hhi != 0.0)
new <- subset(new, new$hhi != 0.0)

old <- subset(old, old$hhi*old$DE > 0.0)
new <- subset(new, new$hhi*new$DE > 0.0)

df <- data.frame(y = new[,"hhi"], x = new[,"DE"])
df <- subset(df, !is.na(df$x))
mx <- lm(y ~ x, df);
slope <- unname(coef(mx)[2])
eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2,
                 list(a = format(unname(coef(mx)[1]), digits = 3),
                      b = format(unname(coef(mx)[2]), digits = 5),
                      r2 = format(summary(mx)$r.squared, digits = 3)))
eq <- as.character(as.expression(eq))

p <- ggplot(data = df, aes(x = x, y = y)) +
  theme_classic(base_size=60) +
  scale_x_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-3.5,3.5)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3)) +
  geom_hline(aes(yintercept=0)) +
  geom_vline(aes(xintercept=0)) +
  labs(x="cook", y="HHI", title="", subtitle="") +
  geom_smooth(method = "lm", se=TRUE, color="cyan", formula = y ~ x) +
  geom_point(color="#0000AA", alpha=0.3, size=5) +
  geom_text(x = 2, y = -4, label = eq, parse = TRUE, size=15)

p

df <- data.frame(y = old[,"hhi"], x = old[,"DE"])
df <- subset(df, !is.na(df$x))
mx <- lm(y ~ x, df);
slope <- unname(coef(mx)[2])
eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2,
                 list(a = format(unname(coef(mx)[1]), digits = 3),
                      b = format(unname(coef(mx)[2]), digits = 5),
                      r2 = format(summary(mx)$r.squared, digits = 3)))
eq <- as.character(as.expression(eq))

p <- ggplot(data = df, aes(x = x, y = y)) +
  theme_classic(base_size=60) +
  scale_x_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-3.5,3.5)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3)) +
  geom_hline(aes(yintercept=0)) +
  geom_vline(aes(xintercept=0)) +
  labs(x="cook", y="HHI", title="", subtitle="") +
  geom_smooth(method = "lm", se=TRUE, color="cyan", formula = y ~ x) +
  geom_point(color="#0000AA", alpha=0.3, size=5) +
  geom_text(x = 2, y = -2, label = eq, parse = TRUE, size=15)

p


prag.n <- prag1[seq(1, nrow(prag1), 3), ]
prag.n <- prag.n[c(-1)]

napoved <- lm(data=prag.n, Dohodek ~Leto)
dodatna.leta <- data.frame(Leto=seq(2018,2020,1))
napoved.praga<-mutate(dodatna.leta, Dohodek=predict(napoved,dodatna.leta))

graf.napovedi.praga <- ggplot(prag.n, aes(x=Leto, y=Dohodek)) + geom_point(data=napoved.praga, inherit.aes = TRUE) +
  geom_smooth(method=lm, fullrange=TRUE, color='green') + geom_point() + scale_x_continuous('Leto',breaks = seq(2005, 2020, 1), limits = c(2005, 2020))

prag.n.r <- prag1[seq(1, nrow(prag1), 3), ]
prag.n.r <- prag.n.r[c(-1)]
prag.n.r <- prag.n.r[-c(1,2,3,4),]

napoved <- lm(data=prag.n.r, Dohodek ~Leto)
dodatna.leta <- data.frame(Leto=seq(2018,2020,1))
napoved.praga<-mutate(dodatna.leta, Dohodek=predict(napoved,dodatna.leta))

graf.napovedi.praga.realne <- ggplot(prag.n.r, aes(x=Leto, y=Dohodek)) + geom_point(data=napoved.praga, inherit.aes = TRUE) +
  geom_smooth(method=lm, fullrange=TRUE, color='green') + geom_point() + scale_x_continuous('Leto',breaks = seq(2009, 2020, 1), limits = c(2009, 2020))


# int array-vector
age  <- c(16, 18 , 22 , 27)

# float array-vector
  age  <- c(16, 18 , 22 , 27)

# bool array-vector
is_marriage  <- c(FALSE, FALSE, TRUE, TRUE)

# string array-vector
name <- c("Olga", "Maria", "Nastya", "Polina")

# list definition
data <- list(age, is_marriage)

# list element access
data[[1]][1]

my_vector <- c(19,18, 29 ,20, 22, 18, 16, 16, 13, 29, 21, 18, 19, 17, 13, 23, 17, 20, 23, 13, 20, 23, 20, 24, 11, 11, 16, 20, 22, 19, 16 ,18 ,26 ,19 ,17 ,23 ,18 ,28 ,25 ,28 ,16 ,19 ,16 ,19 ,26 ,18 ,24 ,20 ,20 ,18)

# mean value of vector's values
mean(my_vector)

# standart value of vector's values
sd(my_vector)

# all values in sd-mean+sd space
sta <- my_vector[mean(my_vector)-sd(my_vector) < my_vector & mean(my_vector)+sd(my_vector) > my_vector]

# console out
print(sta)


library(tidyverse)
library(xts)
library(zoo)
library(readr)

setwd("C:/Users/Ghozy Haqqoni/Documents/!Bahan Data Science Ghozy/DS Courses/DATACAMP/Time_Series_with_R_Track/1_Manipulating_Time_Series_Data_in_R_with_xts_&_zoo/")
temps <- read_csv(Temps.csv)
usd_eur <- read_csv(USDEUR.csv)

####CHAPTER_3

####Combining xts by column with merge####
# Perform an inner join of a and b
merge(a, b, join = "inner")
# Perform a left-join of a and b, fill missing values with 0
merge(a, b, join = "left", fill = 0)
####

####Combining xts by row with rbind####
# Row bind temps_june30 to temps, assign this to temps2
temps2 <- rbind(temps_june30, temps)
# Row bind temps_july17 and temps_july18 to temps2, call this temps3
temps3 <- rbind(temps_july17, temps_july18, temps2)
####

####Fill missing values using last or previous observation####
# Fill missing values in temps using the last observation
temps_last <- na.locf(temps)
# Fill missing values in temps using the next observation
temps_next <- na.locf(temps, fromLast = TRUE)
####

####NA interpolation using na.approx()####
# Interpolate NAs using linear approximation
na.approx(AirPass)
####

####Combine a leading and lagging time series####
# Create a leading object called lead_x
lead_x <- lag(x, k = -1)
# Create a lagging object called lag_x
lag_x <- lag(x, k = 1)
# Merge your three series together and assign to z
z <- cbind(lead_x, x ,lag_x)
####

####Calculate a difference of a series using diff()####
# Calculate the first difference of AirPass using lag and subtraction
diff_by_hand <- AirPass - lag(AirPass)
# Use merge to compare the first parts of diff_by_hand and diff(AirPass)
merge(head(diff_by_hand), head(diff(AirPass)))
# Calculate the first order 12 month difference of AirPass
diff(AirPass, lag = 12, differences = 1)
####

####CHAPTER_4
####Find intervals by time in xts####
#Use endpoints() to locate the end of week in your temps data.
# Use endpoints() to locate the end of every second week in your temps data. Remember to use the k argument.
# Locate the weeks
endpoints(temps, on = "weeks")
# Locate every two weeks
endpoints(temps, on = "weeks", k = 2)
####

####Apply a function by time period(s)####
# Calculate the weekly endpoints
ep <- endpoints(temps, on = "weeks")
# Now calculate the weekly mean and display the results
period.apply(temps[, "Temp.Mean"], INDEX = ep, FUN = mean)
####

####Using lapply() and split() to apply functions on intervals####
# Split temps by week
temps_weekly <- split(temps, f = "weeks")
temps_weekly
# Create a list of weekly means, temps_avg, and print this list
temps_avg <- lapply(X = temps_weekly, FUN = mean)
temps_avg
####

####Selection by endpoints vs. split-lapply-rbind####
# Use the proper combination of split, lapply and rbind
temps_1 <- do.call(rbind, lapply(split(temps, "weeks"), function(w) last(w, n = "1 day")))
# Create last_day_of_weeks using endpoints()
last_day_of_weeks <- endpoints(temps, "weeks")
# Subset temps using last_day_of_weeks
temps_2 <- temps[last_day_of_weeks]
####

####Convert univariate series to OHLC data####
# Convert usd_eur to weekly and assign to usd_eur_weekly
usd_eur_weekly <- to.period(usd_eur, period = "weeks")
# Convert usd_eur to monthly and assign to usd_eur_monthly
usd_eur_monthly <- to.period(usd_eur, period = "months")
# Convert usd_eur to yearly univariate and assign to usd_eur_yearly
usd_eur_yearly <- to.period(usd_eur, period = "years", OHLC = FALSE)
####

####Convert a series to a lower frequency####
data(edhec, package = "PerformanceAnalysis")
# Convert eq_mkt to quarterly OHLC
mkt_quarterly <- to.period(eq_mkt, period = "quarters", OHLC = TRUE)
# Convert eq_mkt to quarterly using shortcut function
mkt_quarterly2 <- to.quarterly(eq_mkt, name = NULL, indexAt = "firstof")
####

####Calculate basic rolling value of series by month####
# Split edhec into years
edhec_years <- split(edhec , f = "years")
# Use lapply to calculate the cumsum for each year in edhec_years
?lapply
edhec_ytd <- lapply(edhec_years, FUN = cumsum)
# Use do.call to rbind the results
edhec_xts <- do.call(rbind, edhec_ytd)
####

####Calculate the rolling standard deviation of a time series####
# Use rollapply to calculate the rolling 3 period sd of eq_mkt
#rollapply(x, width = 10, FUN = max, na.rm = TRUE)
eq_sd <- rollapply(eq_mkt, 3, FUN = sd)
####

####CHAPTER_5

####Class attributes - tclass, tzone, and tformat####
# View the first three indexes of temps
index(temps)[1:3]
# Get the index class of temps
indexClass(temps)
# Get the timezone of temps
indexTZ(temps)
# Change the format of the time display
indexFormat(temps) <- "%b-%d-%Y"
# View the new format
head(temps)
####

####Time Zones (and why you should care!)####
# Construct times_xts with tzone set to America/Chicago
#times_xts <- xts(___:___, order.by = ___, tzone = ___)
times_xts <- xts(1:10, order.by = times, tzone = "America/Chicago")
# Change the time zone of times_xts to Asia/Hong_Kong
#tzone(___) <-
tzone(times_xts) <- "Asia/Hong_Kong"
# Extract the current time zone of times_xts
indexTZ(times_xts)
####

####Determining periodicity####
# Calculate the periodicity of temps
periodicity(temps)
# Calculate the periodicity of edhec
periodicity(edhec)
# Convert edhec to yearly
edhec_yearly <- to.yearly(edhec)
# Calculate the periodicity of edhec_yearly
periodicity(edhec_yearly)
####

####Find the number of periods in your data####
# Count the months
nmonths(edhec)
# Count the quarters
nquarters(edhec)
# Count the years
nyears(edhec)
####

####Secret index tools####
# Explore underlying units of temps in two commands: .index() and .indexwday()
.index(temps)
.indexwday(temps)
# Create an index of weekend days using which()
index <- which(.indexwday(temps) == 0 | .indexwday(temps) == 6)
# Select the index
temps[index]
####

####Modifying timestamps####
# Make z have unique timestamps
z_unique <- make.index.unique(z, eps = 1e-4)
# Remove duplicate times in z
z_dup <- make.index.unique(z, drop = TRUE)
# Round observations in z to the next hour
z_round <- align.time(z, n = 3600)
####


#Define function to allocate integer quantities among categories
#---------------------------------------------------------------
#' Allocate integer quantities among categories
#'
#' \code{splitIntegers} splits a total value into a vector of whole numbers to
#' reflect input vector of proportions
#'
#' This function splits an input total into a vector of whole numbers to reflect
#' an input vector of proportions. If the input total is not an integer, the
#' value is rounded and converted to an integer.
#'
#' @param Tot a number that is the total value to be split into a vector of
#' whole numbers corresponding to the input proportions. If Tot is not an
#' integer, its value is rounded and converted to an integer.
#' @param Props_ a numeric vector of proportions used to split the total value.
#' The values should add up to approximately 1. The function will adjust so that
#' the proportions do add to 1.
#' @return a numeric vector of whole numbers corresponding to the Props_
#' argument which sums to the Tot.
#' @export
splitIntegers <- function(Tot, Props_) {
  #Convert Tot into an integer
  if (!is.integer(Tot)) {
    Tot <- as.integer(round(Tot))
  }
  #If Tot is 0, return vector of zeros
  if (Tot == 0) {
    integer(length(Props_))
  } else {
    #Make sure that Props_ sums exactly to 1
    Props_ <- Props_ / sum(Props_)
    #Make initial whole number split
    Ints_ <- round(Tot * Props_)
    #Determine the difference between the initial split and the total
    Diff <- Tot - sum(Ints_)
    #Allocate the difference
    if (Diff != 0) {
      for (i in 1:abs(Diff)) {
        IdxToChg <- sample(1:length(Props_), 1, prob = Props_)
        Ints_[IdxToChg] <- Ints_[IdxToChg] + sign(Diff)
      }
    }
    unname(Ints_)
  }
}


source("../power_priors_aux.r")
source("../data_Gaussian.r")

gs.data <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = 1
)

###
get_l_a0_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
  nstar <- a_0 * n0
  ybar <- mean(y0)
  s <- mean( (y0-ybar)^2 )
  kappa_n <- k0 + nstar
  alpha_n <- alpha0 + nstar/2
  beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
  ans <- lgamma(alpha_n)-lgamma(alpha0)
  ans <- ans + alpha0 * log(beta0) - alpha_n * log(beta_n)
  ans <- ans + .5 *( log(k0) - log(kappa_n) )-nstar/2 * log(2*pi)
  return(ans)
}

############
l_a0 <- function(x) {
  get_l_a0_gaussian(
    y0 = gs.data$y0,
    n0 = gs.data$N0,
    alpha0 = gs.data$alpha0,
    beta0 = gs.data$beta0,
    m0 = gs.data$mu0,
    k0 = gs.data$kappa0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
###
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)
l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

###

find_zero <- function(){
  obj <- function(x) (l_a0_p(x))^2
  res <- optimize(obj, lower = 0, upper = 10)
  return(res$minimum)
}
find_zero()

lhs <- function(a0){
  digamma(alpha_0 + N_0/2 * a0)
}

rhs <- function(a0){
  ybar <- mean(y_0)
  s <-  sum((y_0-ybar)^2)
  kappa_n <- kappa_0 + N_0*a0
  ##
  delta <- .5 * ( s  + (kappa_0/ kappa_n) * N_0 *(ybar-mu_0)^2)
  t1 <- (delta *(alpha_0 + N_0/2 * a0) )/(N_0 * (delta*a0  + beta_0))
  t2 <- log(delta*a0  + beta_0)
  t3 <- 4/ (a0 *N_0 + kappa_0)
  t4 <- log(2*pi)
  ans <- t1  + t2 + t3 + t4
  return(ans)
}

curve(lhs, 0, 1, lwd = 3, xlab = expression(a[0]))
curve(rhs, 0, 1, add = TRUE, col = 3, lwd = 3)
abline(v = find_zero(), lty = 2, lwd = 2)

find_zero_2 <- function(){
  obj2 <- function(x) (rhs(x) - lhs(x))^2
  res2 <- optimize(obj2, lower = 0, upper = 10)
  return(res2$minimum)
}

curve(l_a0_p)
abline(h = 0, lty = 2, lwd = 2)
abline(v = find_zero_2(), lty = 2, lwd = 2)

lfn <- function(x) l_a0(x + 1)-l_a0(x)
fn <- function(x) exp(lfn(x))

curve(lfn, 0, 10)
curve(fn, 0, 10)


pascalTriangle <- function(h) {
  for(i in 0:(h-1)) {
    s <- ""
    for(k in 0:(h-i)) s <- paste(s, "  ", sep="")
    for(j in 0:i) {
      s <- paste(s, sprintf("%3d ", choose(i, j)), sep="")
    }
    print(s)
  }
}


bacillus <- read.table('bacillus2.txt',header=T)

# construct indicator variables, == is the R is.equal logical
# reference group coding, with Placebo as the reference

bacillus$a1 <- bacillus$trt == 'Ab1'
bacillus$a2 <- bacillus$trt == 'Ab2'
bacillus$a3 <- bacillus$trt == 'Pl'

# a1, a2, and a3 are logicals (F or T), but they are interpreted
#  (at least most of the time) as 0 or 1

a.lm <- lm(post~a1+a2,data=bacillus)
a0.lm <- lm(post~ +1, data=bacillus)  # intercept only model
anova(a0.lm, a.lm)   # overall ANOVA
coef(a.lm)           # coefficients

# effects coding
bacillus$a1 <- bacillus$trt == 'Ab1'
bacillus$a2 <- bacillus$trt == 'Ab2'

bacillus$a1[bacillus$trt=='Pl'] <- -1
bacillus$a2[bacillus$trt=='Pl'] <- -1

b.lm <- lm(post~b1+b2,data=bacillus)
anova(a0.lm, b.lm)
coef(b.lm)

# cell means coding.
# the following should work

c.lm <- lm(post~-1 + a1 + a2 + a3, data=bacillus)

# the -1 suppresses the intercept

# BUT, R interprets the logicals as factors when
#  there isn't an intercept.  Wierd!
#  I think I have an explanation but would appreciate
#    any insight from an R guru

# To fit the cell means model, we need to convert the
#  indicator variables to integers (0 or 1)

bacillus$n1 <- as.integer(bacillus$a1)
# as.numeric() would also work
bacillus$n2 <- as.integer(bacillus$a2)
bacillus$n3 <- as.integer(bacillus$a3)
anova(a0.lm,c.lm)
coef(c.lm)

# R handles non-full rank X matrices gracefully

d.lm <- lm(post~a1 + a2 + a3, data=bacillus)
# or d.lm <- lm(post~n1 + n2 + n3, data=bacillus)

anova(d.lm)
coef(d.lm)

# if you use summary(), you get the appropriate
#  warning about singularities
summary(d.lm)

# You can see the X matrix automatically generated
#  by R for factor variables by looking at the output
#  from model.matrix()

bacillus$trt.f <- as.factor(bacillus$trt)

model.matrix(post~trt.f,data=bacillus)

# and can change the contrast coding using contrasts=

model.matrix(post~trt.f,data=bacillus,
  contrasts=list(trt.f=contr.SAS) )

# the named element is the factor and the value is
#   a specified set of contrasts
# R provides functions for:
#  contr.sas: "SAS" contrasts, reference = last
#  contr.sum: effect contrasts, sum to 0
#  contr.helmert: each group to average of subsequent ones
#  contr.poly: orthogonal polynomials
#  contr.treatment: reference contrasts to specified group

#  the default is contr.treatment using 1st group as ref.

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


sd<-.225
z_foralpha=qnorm(1-0.05)
z_forbeta=qnorm(1-0.01)
zstar<-z_foralpha+z_forbeta
E<-16.37 - 16.27
sample_size<- zstar^2 * sd * sd/ E^2
print(ceiling(sample_size))
#  the manufacturer must obtain a random sample of n = 80 boxes to conduct this test