# Modifications were made so that no global variables are used. (C DuBois)

#####################################
# R FUNCTIONS FOR PERFORMING UNIVARIATE SLICE SAMPLING.
#
# Radford M. Neal, 17 March 2008.
#
# Implements, with slight modifications and extensions, the algorithm described
# in Figures 3 and 5 of the following paper:
#
#   Neal, R. M (2003) "Slice sampling" (with discussion), Annals of Statistics,
#      vol. 31, no. 3, pp. 705-767.
#
# See the documentation for the function uni.slice below for how to use it.
# The function uni.slice.test was used to test the uni.slice function.

# GLOBAL VARIABLES FOR RECORDING PERFORMANCE.

# UNIVARIATE SLICE SAMPLING WITH STEPPING OUT AND SHRINKAGE.
#
# Performs a slice sampling update from an initial point to a new point that
# leaves invariant the distribution with the specified log density function.
#
# Arguments:
#
#   x0    Initial point
#   g     Function returning the log of the probability density (plus constant)
#   w     Size of the steps for creating interval (default 1)
#   m     Limit on steps (default infinite)
#   lower Lower bound on support of the distribution (default -Inf)
#   upper Upper bound on support of the distribution (default +Inf)
#   gx0   Value of g(x0), if known (default is not known)
#
# The log density function may return -Inf for points outside the support
# of the distribution.  If a lower and/or upper bound is specified for the
# support, the log density function will not be called outside such limits.
#
# The value of this function is the new point sampled, with an attribute
# of "log.density" giving the value of the log density function, g, at this
# point.  Depending on the context, this log density might be passed as the
# gx0 argument of a future call of uni.slice.
#
# The global variable uni.slice.calls is incremented by one for each call
# of uni.slice.  The global variable uni.slice.evals is incremented by the
# number of calls made to the g function passed.
#
# WARNING:  If you provide a value for g(x0), it must of course be correct!
# In addition to giving wrong answers, wrong values for gx0 may result in
# the uni.slice function going into an infinite loop.

uni.slice.alt <- function (x0, g, w=1, m=Inf, lower=-Inf, upper=+Inf, gx0=NULL)
{
  # Check the validity of the arguments.

  if (!is.numeric(x0) || length(x0)!=1
   || !is.function(g)
   || !is.numeric(w) || length(w)!=1 || w<=0
   || !is.numeric(m) || !is.infinite(m) && (m<=0 || m>1e9 || floor(m)!=m)
   || !is.numeric(lower) || length(lower)!=1 || x0<lower
   || !is.numeric(upper) || length(upper)!=1 || x0>upper
   || upper<=lower
   || !is.null(gx0) && (!is.numeric(gx0) || length(gx0)!=1))
  {
    stop ("Invalid slice sampling argument")
  }

  # Keep track of the number of calls made to this function.
  uni.slice.calls <- 0	# Number of calls of the slice sampling function
  uni.slice.evals <- 0	# Number of density evaluations done in these calls

  uni.slice.calls <- uni.slice.calls + 1

  # Find the log density at the initial point, if not already known.

  if (is.null(gx0))
  { uni.slice.evals <- uni.slice.evals + 1
    gx0 <- g(x0)
  }

  # Determine the slice level, in log terms.

  logy <- gx0 - rexp(1)

  # Find the initial interval to sample from.

  u <- runif(1,0,w)
  L <- x0 - u
  R <- x0 + (w-u)  # should guarantee that x0 is in [L,R], even with roundoff

  # Expand the interval until its ends are outside the slice, or until
  # the limit on steps is reached.

  if (is.infinite(m))  # no limit on number of steps
  {
    repeat
    { if (L<=lower) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(L)<=logy) break
      L <- L - w
    }

    repeat
    { if (R>=upper) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(R)<=logy) break
      R <- R + w
    }
  }

  else if (m>1)  # limit on steps, bigger than one
  {
    J <- floor(runif(1,0,m))
    K <- (m-1) - J

    while (J>0)
    { if (L<=lower) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(L)<=logy) break
      L <- L - w
      J <- J - 1
    }

    while (K>0)
    { if (R>=upper) break
      uni.slice.evals <- uni.slice.evals + 1
      if (g(R)<=logy) break
      R <- R + w
      K <- K - 1
    }
  }

  # Shrink interval to lower and upper bounds.

  if (L<lower)
  { L <- lower
  }
  if (R>upper)
  { R <- upper
  }

  # Sample from the interval, shrinking it on each rejection.

  repeat
  {
    x1 <- runif(1,L,R)

    uni.slice.evals <- uni.slice.evals + 1
    gx1 <- g(x1)

    if (gx1>=logy) break

    if (x1>x0)
    { R <- x1
    }
    else
    { L <- x1
    }
  }

  # Return the point sampled, with its log density attached as an attribute.

  attr(x1,"log.density") <- gx1
  attr(x1,"uni.slice.evals") <- uni.slice.evals
  attr(x1,"uni.slice.calls") <- uni.slice.calls
  return (x1)

}

# FUNCTION TO TEST THE UNI.SLICE FUNCTION.
#
# Produces Postscript plots in slice-test.ps, one page per test, with the
# tests described in the code below.
#
# Each test applies a series of univariate slice sampling updates (ss*thin of
# them) to some distribution, starting at a point drawn from that distribution,
# with particular settings of the slice sampling options.  The page for a
# test contains the following:
#
#   - a trace plot of the results (at every 'thin' updates)
#   - a plot of the autocorrelations for this trace
#   - a plot of the bivariate distribution before and after 'thin' updates
#   - a qqplot of the sample produced vs. a correct sample
#   - the average number of evaluations per call
#   - the result of a t test for the sample mean vs. the correct mean, based
#     on 200 equally spaced points from the sample generated (which are
#     presumed to be virtually independent)

uni.slice.alt.test <- function ()
{
  postscript("slice-test.ps")
  par(mfrow=c(2,2))

  # Function to do the slice sampling updates.

  updates <- function (x0, g, reuse=FALSE)
  {
    uni.slice.calls <- 0
    uni.slice.evals <- 0

    s <<- numeric(ss)
    x1 <- x0
    s[1] <<- x0
    last.g <- NULL

    for (i in 2:ss)
    { for (j in 1:thin)
      { if (reuse)
        { x1 <- uni.slice (x1, g, w=w, m=m, lower=lower, upper=upper,
                           gx0=last.g)
          last.g <- attr(x1,"log.density")
          uni.slice.calls <- uni.slice.calls + attr(x1,"uni.slice.calls")
          uni.slice.evals <- uni.slice.evals + attr(x1,"uni.slice.evals")
        }
        else
        { x1 <- uni.slice (x1, g, w=w, m=m, lower=lower, upper=upper)
        }
      }
      s[i] <<- x1
    }
  }

  # Function to display the results.

  display <- function (r,mu,test)
  {
    plot(s,type="p",xlab="Iteration",ylab="State",pch=20)

    title (paste( test, "  ss =",ss," thin =",thin))

    acf (s, lag.max=length(s)/20, main="")

    title (paste ("w =",w," m =",m," lower =",lower," upper =",upper))

    plot(s[-1],s[-length(s)],pch=20,xlab="Current state",ylab="Next state")

    title (paste ("Average number of evaluations:",
                   round(uni.slice.evals/uni.slice.calls,2)))

    qqplot(r,s,pch=".",
       xlab="Quantiles from correct sample",
       ylab="Quantiles from slice sampling")
    abline(0,1)

    p.value <- t.test (s[seq(1,length(s),length=200)]-mu) $ p.value
    title (paste ("P-value from t test:",round(p.value,3)))
  }

  # Standard normal, m = Inf.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.5
  m <- Inf
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1), function (x) -x^2/2)
  display (rnorm(ss),0,"Standard normal")

  # Standard normal, reusing density, m = Inf.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.5
  m <- Inf
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1), function (x) -x^2/2, reuse=TRUE)
  display (rnorm(ss),0,"Standard normal, reusing density")

  # Normal mixture, m = 1.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 2.2
  m <- 1
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1,-1,1), function (x) log(dnorm(x,-1,1)+dnorm(x,1,0.5)))
  display (c (rnorm(floor(ss/2),-1,1), rnorm(ceiling(ss/2),1,0.5)), 0,
           "Normal mixture")

  # Normal mixture, m = 3.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.8
  m <- 3
  lower <- -Inf
  upper <- +Inf

  updates (rnorm(1,-1,1), function (x) log(dnorm(x,-1,1)+dnorm(x,1,0.5)))
  display (c (rnorm(floor(ss/2),-1,1), rnorm(ceiling(ss/2),1,0.5)), 0,
           "Normal mixture")

  # Exponential, m = Inf.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 10
  m <- Inf
  lower <- 0
  upper <- +Inf

  updates (rexp(1), function (x) -x)
  display (rexp(ss), 1, "Exponential")

  # Exponential, m = 2.

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1.5
  m <- 2
  lower <- 0
  upper <- +Inf

  updates (rexp(1), function (x) -x)
  display (rexp(ss), 1, "Exponential")

  # Beta(0.5,0.8).

  set.seed(1)

  ss <- 2000
  thin <- 3
  w <- 1e9
  m <- Inf
  lower <- 0
  upper <- 1

  updates (rbeta(1,0.5,0.8), function (x) dbeta(x,0.5,0.8,log=TRUE))
  display (rbeta(ss,0.5,0.8), 0.5/(0.5+0.8), "Beta(0.5,0.8)")

  dev.off()
}


# ......................................................................................
# ...............Cvičení 5 - Vybraná rozdělení diskrétní náhodné veličiny...............
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

#  Přehled rozdělení a jejich funkcí ####
# * Úvod: Pravděpodobnostní, Kumulativní pravděpodobnostní (Distribuční) a Kvantilová ####
# funkce
# ** Pravděpodobnostní funkce ####
# - začíná písmenkem **d**: $p = P(X = x)$: p = d...(x, ...)
#
# ** Kumulativní pravděpodobnostní (Distribuční funkce) ####
# - začíná písmenkem **p**: $p = P(X \leq x)$: p = p...(x, ...)
# - pozor Kumulativní pravděpodobnostní je s alternativní definicí $P(X \leq t)$
# - pro naši distribuční funkci $F(t) = P(X<t)$: F(t) = p...(t - 1, ...)
#
# ** Kvantilová funkce ####
# - začíná písmenkem **q**:  $p \geq P(X \leq x)$: x = q...(p, ...)
# - hledá nejmenší $x$ pro které je $P(X \leq x)$ větší než $p$

# * Binomické (Alternativní): $X \sim Bi(n, π),X \sim A(π) = Bi(1, π)$ ####
# - počet úspěchů v $n$ Bernoulliho pokusech (případně pro jeden pokus v případě
# Alternativní)
# - každý pokus má šanci na úspěch $π$

# Pravděpodobnostní funkce P(X = x)
x = 10   # hodnota, pro níž hledáme p-stní funkci
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
dbinom(x, n, p)

dbinom(3.2, n, p)

options(warn=-1) # tímto se dají vypnout warningy

dbinom(3.2, n, p)

options(warn=0) # tímto zase zapnout

# vykreslíme si pravděpodobnostní funkci
x = 0:21 # minimálně 0, maximálně n má kladnou pravděpodobnost
P_x = dbinom(x, n, p)
plot(x, P_x)
grid()

# Kumulativní pravděpodobnostní funkce P(X <= x)
x = 10   # hodnota, pro níž hledáme kumulativní p-stní funkci
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
pbinom(x, n, p)

# Distribuční funkce F(x) = P(X < x)
x = 10   # hodnota, pro níž hledáme kumulativní p-stní funkci
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
pbinom(x, n, p) - dbinom(x, n, p)
# nebo
pbinom(x - 1, n, p)

# vykreslíme si distribuční funkci
x = 0:21 # minimálně 0, maximálně n má kladnou pravděpodobnost
P_x = dbinom(x, n, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# nebo
x = seq(0, 21, 0.01) # minimálně 0, maximálně n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
plot(x, F_x, cex=0.3)
grid()
options(warn=0)

# zkontrolujeme korektnost na hodnotě 10
x = seq(9.9, 10.1, 0.01) # minimálně 0, maximálně n
options(warn=-1)
F_x = pbinom(x, n, p) - dbinom(x, n, p)
options(warn=0)
plot(x, F_x, cex=0.5)
grid()

# najdi x pro dané q: q = P(X <= x)
q = 0.7  # h
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
qbinom(q, n, p)
pbinom(11, n, p)
pbinom(12, n, p)
pbinom(13, n, p)

# Kvantilová funkce (inverzi dist. fce): q = F(x) = P(X < x)
q = 0.7   # pravděpodobnost pro kterou hledáme kvantil
n = 21   # rozsah výběru
p = 0.5  # pravděpodobnost úspěchu
qbinom(q, n, p) + 1
pbinom(12 - 1, n, p)
pbinom(13 - 1, n, p)
pbinom(14 - 1, n, p)

# * Hypergeometrické: $X \sim H(N, M, n)$ ####
# - počet úspěchů v $n$ závislých pokusech
# - závislost typu:
#  - $N$ objektů,
#  - z toho $M$ objektů se zadanou vlastností,
#  - výběr velikosti $n$
#  - **při výběru nevracíme zpět - pravděpodobnost výběru objektu s danou vlastností se
# mění s každým dalším vybraným objektem**
# - **R funkce bere jako parametry *hyper(k, M, N - M, n)**
#  - k je počet úspěchů pro které počítáme pravděpodobnost,
#  - M je počet objektů se zadanou vlastností,
#  - N-M je počet objektů bez zadané vlastnosti,
#  - n je ceklová velikost výběru.

# Pravděpodobnostní funkce P(X = x)
x = 5   # hodnota, pro níž hledáme p-stní funkci
N = 20  # celkový počet objektů
M = 5   # z toho se zadanou vlastností
n = 10  # velikost výběru
dhyper(x, M, N - M, n)

# vykreslíme si pravděpodobnostní funkci
x = 0:5 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dhyper(x, M, N - M, n)
plot(x, P_x)
grid()

# Distribuční funkce F(x) = P(X < x)
x = 5   # hodnota, pro níž hledáme dist. funkci
N = 20  # celkový počet objektů
M = 5   # z toho se zadanou vlastností
n = 10  # velikost výběru
phyper(x - 1, M, N - M, n)

# vykreslíme si Distribuční funkci
x = 0:5 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dhyper(x, M, N - M, n)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Kvantilová funkce (inverzi dist. fce): q = P(X < x)
q = 0.7 # pravděpodobnost pro kterou hledáme kvantil
N = 20  # celkový počet objektů
M = 5   # z toho se zadanou vlastností
n = 10  # velikost výběru
qhyper(q, M, N - M, n) + 1
phyper(3 - 1, M, N - M, n)
phyper(4 - 1, M, N - M, n)
phyper(5 - 1, M, N - M, n)

# * Negativně binomické (Geometrické): $X \sim NB(k, π), X \sim Ge(π) = NB(1, π)$ ####
# - počet pokusů do $k$. úspěchu (včetně)
# - každý pokus má šanci na úspěch $π$
# - **Negativně binomická NV je v Rku definována jako počet neúspěchů před k-tým
# úspěchem**
#  - proto jako první parametr budeme posílat x - k

# Pravděpodobnostní funkce P(X = x)
x = 15   # počet pokusů pro který hledáme pravd. fci
k = 5    # požadovaný počet úspěchů
p = 0.3  # pravd. jednotlivých pokusů
# pozor první argument musí být počet neúspěchů
dnbinom(x - k, k, p)

# vykreslíme si pravděpodobnostní funkci
x = 0:40 # minimálně k, maximum neomezeno
P_x = dnbinom(x - k, k, p)
plot(x, P_x)
grid()
# hodnoty 0,1,2,3,4 mají P(x)=0

# Distribuční funkce F(x) = P(X < x)
x = 15   # počet pokusů pro který hledáme pravd. fci
k = 5    # požadovaný počet úspěchů
p = 0.3  # pravd. jednotlivých pokusů
# pozor první argument musí být počet neúspěchů
pnbinom(x - k - 1, k, p)

# vykreslíme si Distribuční funkci
x = 0:40 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dnbinom(x - k, k, p)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Kvantilová funkce (inverzi dist. fce): q = P(X < x)
q = 0.7  # pravd. pro kvantil
k = 5    # požadovaný počet úspěchů
p = 0.3  # pravd. jednotlivých pokusů
qnbinom(q, k, p) + k + 1
pnbinom(19 - k - 1, k, p)
pnbinom(20 - k - 1, k, p)
pnbinom(21 - k - 1, k, p)

# * Poissonovo: $X \sim Po(λt)$ ####
# - počet událostí v Poissonově procesu v uzavřené oblasti (v čase, na ploše, v objemu)
# - s hustotou výskytu $λ$
# - v čase/ploše/objemu velikosti $t$

# Pravděpodobnostní funkce P(X = x)
x = 9       # počet pokusů pro který hledáme pravd. fci
lambda = 5  # hustota výskytu
t = 2       # pravd. jednotlivých pokusů
lt = lambda*t
dpois(x, lt)

# vykreslíme si pravděpodobnostní funkci
x = 0:25 # minimálně 0, maximum neomezeno
P_x = dpois(x, lt)
plot(x, P_x)
grid()

# Distribuční funkce F(x) = P(X < x)
x = 9       # počet pokusů pro který hledáme pravd. fci
lambda = 5  # hustota výskytu
t = 2       # pravd. jednotlivých pokusů
lt = lambda*t
ppois(x - 1, lt)

# vykreslíme si Distribuční funkci
x = 0:25 # minimálně 0, maximálně n nebo M má kladnou pravd.
P_x = dpois(x, lt)
F_x = cumsum(P_x)
plot(x, F_x, type='s')
grid()

# Kvantilová funkce (inverzi dist. fce): q = P(X < x)
q = 0.4     # pravd. pro kvantil
lambda = 5  # hustota výskytu
t = 2       # pravd. jednotlivých pokusů
lt = lambda*t
qpois(q, lt) + 1
ppois(9 - 1, lt)
ppois(10 - 1, lt)
ppois(11 - 1, lt)

#  Příklady ####
# * Příklad 1. ####
# Bridž se hraje s 52 bridžovými kartami, které se rozdají mezi 4 hráče. Vždy 2 hráči
# hrají spolu. Při rozdávání (13 karet) jste dostali do rukou 2 esa. Jaká je
# pravděpodobnost, že váš partner bude mít zbývající dvě esa?

# X ... počet es mezi 13 kartami
# X ~ H(N = 39, M = 2, n = 13)
# P(X = 2)
M = 2
N = 39 # 52-13
n = 13
# výpočet
dhyper(2, M, N - M, n) # což je dhyper(2,2,37,13)

# graf pravděpodobnostní funkce
x = 0:M   # všechny možné realizace NV X
p = dhyper(x, M, N - M, n) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 2. ####
# Pokusy se zjistilo, že radioaktivní látka vyzařuje během 7,5 s průměrně 3,87
# α-částice. Určete pravděpodobnost toho, že za 1 sekundu vyzáří tato látka alespoň
# jednu α-částici.

# X ... počet vyzářených alfa částic během 1 s
# X ~ Po(lt = 3.87/7.5)

lambda = 3.87/7.5 # četnost výskytu
t = 1 # za 1 sekundu
lt = lambda*t # parametr Poissonova rozdělení

# P(X >= 1) = P(X > 0) = 1 - P(X <= 0)
1 - ppois(1 - 1, lt)

# graf pravděpodobnostní funkce
# teoreticky může být vyzářeno až nekonečně mnoho částic,
# od jisté hodnoty je pravděpodobnost zanedbatelná
x = 0:10
p = dpois(x, lt) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 3. ####
# Kamarád vás pošle do sklepa, abyste donesl(a) 4 lahvová piva - z toho dvě desítky a
# dvě dvanáctky. Nevíte, kde rozsvítit, proto vezmete z basy poslepu 4 láhve. S jakou
# pravděpodobností jste vyhověl(a), víte-li, že v base bylo celkem 10 desítek a 6
# dvanáctek?

# X ... počet 10°piv mezi 4 vybranými
# X ~ H(N = 16, M = 10, n = 4)

x = 2
N = 16
M = 10
n = 4

# P(X = 2)
dhyper(x, M, N - M, n)

# graf pravděpodobnostní funkce
x = 0:4    # všechny možné realizace NV X
p = dhyper(x, M, N - M, n) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 4. ####
# V jednom mililitru určitého dokonale rozmíchaného roztoku se v průměru nachází 15
# určitých mikroorganismů. Určete pravděpodobnost, že při náhodném výběru vzorku o
# objemu 1/2 mililitru bude ve zkumavce méně než 5 těchto mikroorganismu.

# X ... počet mikroorganismů v 0.5 ml roztoku
# X ~ Po(lt = 15/2)

lambda = 15
t = 1/2
lt = lambda*t   # parametr Poissonova rozd.

# P(X < 5) = P(X <= 4)
ppois(5 - 1, lt)
# nebo
ppois(5,lt) - dpois(5,lt)

# graf pravděpodobnostní funkce
# teoreticky může být v roztoku až nekonečně mnoho mikroorganismů,
# od jisté hodnoty je pravděpodobnost zanedbatelná
x = 0:20
p = dpois(x, lt) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 5. ####
# Na stůl vysypeme 15 mincí. Jaká je pravděpodobnost, že počet mincí ležících lícem
# nahoře, je od 8 do 15?

# X ... počet mincí, které padnou lícem nahoru z celkového množství 15 mincí
# X ~ Bi(n = 15, p = 0.5)

n = 15
p = 0.5

# P(8 <= X <= 15) = P(X <= 15) - P(X < 8) = P(X <= 15) - P(X <= 7)
pbinom(15, n, p) - pbinom(7, n, p)

#jinak: P(8<=X<=15)=P(X>7)=1-P(X<=7)
1 - pbinom(7, n, p)

# graf pravděpodobnostní funkce
x = 0:15    # všechny možné realizace NV X
p = dbinom(x, n, p) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 6. ####
# Pravděpodobnost, že se dovoláme do studia rozhlasové stanice, která právě vyhlásila
# telefonickou soutěž je 0,08. Jaká je pravděpodobnost, že se dovoláme nejvýše na 4.
# pokus?

# X ... počet pokusů než se dovoláme do rozhlasového studia
# X ~ NB(k = 1,p = 0.08) nebo G(0.08)

x = 4
k = 1
p = 0.08

# P(X <= 4)
pnbinom(x - k, k, p)

# graf pravděpodobnostní funkce
# teoreticky můžeme uskutečnit až nekonečně mnoho pokusů,
# od jisté hodnoty je pravděpodobnost zanedbatelná
x = 1:40
p = dnbinom(x - k, k, p) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 7. ####
# V továrně se vyrobí denně 10 % vadných součástek. Jaká je pravděpodobnost, že
# vybereme-li třicet součástek z denní produkce, tak nejméně dvě budou vadné?

# X ... počet vadných součástek ze 30 vybraných
# X ~ Bi(n = 30, p = 0.1)

n = 30
p = 0.1

# P(X >= 2) = 1 - P(X < 2) = 1 - P(X <= 1)
1 - pbinom(1, n, p)

# nebo P(X >= 2) vsechno mimo 0 a 1
1 - (dbinom(0, n, p) + dbinom(1, n, p))

# graf pravděpodobnostní funkce
x = 0:30            # všechny možné realizace NV X
p = dbinom(x, n, p) # hodnoty pravděpodobnostní funkce pro x
plot(x,p)

# * Příklad 8. ####
# Ve skladu je 200 součástek. 10 % z nich je vadných. Jaká je pravděpodobnost, že
# vybereme-li ze skladu třicet součástek, tak nejméně dvě budou vadné?

# X ... počet vadných součástek ze 30 vybraných z 200
# X ~ H(N = 200, M = 20, n = 30)

N = 200
M = 20
n = 30

# P(X >= 2) = 1 - P(X < 2) = 1 - P(X <= 1)
1 - phyper(2 - 1, M, N - M, n)

# graf pravděpodobnostní funkce
x = 0:30   # všechny možné realizace NV X
p = dhyper(x, M, N - M, n) # hodnoty pravděpodobnostní funkce pro x
plot(x, p)

# * Příklad 9. ####
# V určité firmě bylo zjištěno, že na 33 % počítačů je nainstalován nějaký nelegální
# software. Určete pravděpodobnostní a distribuční funkci počtu počítačů s nelegálním
# softwarem mezi třemi kontrolovanými počítači.

# X ... počet počítačů s nelegálním softwarem ze 3 kontrolovaných
# X ~ Bi(n = 3,p = 0.33)

n = 3
p = 0.33

# pravděpodobnostní funkce
x = 0:3  # všechny možné realizace NV X
p = dbinom(x, n, p) # hodnoty pravděpodobnostní funkce pro x

p = round(p, 3) # zaokrouhlení pravděpodobností na 3 des. místa
p[4] = 1 - sum(p[1:3]) # dopočet poslední hodnoty do 1

tab = rbind(x, p) # vytvoření tabulky pravděpodobnostní funkce
rownames(tab) = c("x", "P(x)")
tab

# graf pravděpodobnostní funkce
plot(x, p)

#distribuční funkce
cumsum(p) # zjednodušený výpis distribuční funkce

# * Příklad 10. ####
# Sportka je loterijní hra, v níž sázející tipuje šest čísel ze čtyřiceti devíti, která
# očekává, že padnou při budoucím slosování. K účasti ve hře je nutné zvolit alespoň
# jednu kombinaci 6 čísel (vždy 6 čísel na jeden sloupec) a pomocí křížků tato čísla
# označit na sázence společnosti Sazka a.s. do sloupců, počínaje sloupcem prvním.
# Sázející vyhrává v případě, že uhodne alespoň tři čísla z tažené šestice čísel. Jaká
# je pravděpodobnost, že proto, aby sázející vyhrál, bude muset vyplnit:

# Nejprve pravděpodobnost, že vehrajeme v jednom sloupci

# Y ... počet uhádnutých čísel v 6 tažených ze 49
# Y ~ H(N = 49, M = 6, n = 6)

N = 49
M = 6
n = 6

# P-st uhádnutí alespoň 3 čísel v jednom sloupci
# P(Y >= 3) = 1 - P(Y < 3) = 1 - P(Y <= 2)
pp = 1 - phyper(3 - 1, M, N - M, n)
pp

# ** a) ####
# právě tři sloupce,

# X … počet sloupců, které bude muset sázející vyplnit, aby vyhrál
# X ~ NB(k = 1, p = pp)

# a) P(X = 3)
k = 1
p = pp

dnbinom(3 - k, k, pp)

# ** b)  ####
# alespoň 5 sloupců,

# b) P(X >= 5) = 1 - P(X < 5) = 1 - P(X <= 4)

1 - pnbinom(5 - k - 1, k, pp)

# ** c) ####
# méně než 10 sloupců,

# c) P(X < 10) = P(X <= 9)
pnbinom(10 - k - 1, k, pp)

# * d) ####
# více než 5 a nejvýše 10 sloupců?

# P(5 < X <= 10) = P(X <= 10) - P(X <= 5)
pnbinom(10 - k, k, pp)-pnbinom(5 - k, k, pp)
# nebo P(X < 11) - P(X < 6)
pnbinom(11 - k - 1, k, pp)-pnbinom(6 - k - 1, k, pp)

# * Příklad 11. ####
# Pravděpodobnost, že hodíme 6 na 6stěnné kostce je 1/6. Hážeme tak dlouho, než hodíme
# šestku 10 krát.
# ** a)  ####
# Jaká je střední hodnota počtu hodů.

# X … hodů kostkou než hodíme 10 šestek
# X ~ NB(k = 10, p = 1/6)

k = 10
p = 1/6

E_X = k/p
E_X

# ** b)  ####
# S kolika hody nejméně musíme počítat, pokud chceme, aby pradvěpodobnost, že se nám
# podaří naházet 10 šestek, byla alespoň 70%.

# P(X <= k) >= 0.7
qnbinom(0.7, k, p) + k


#' Samples from a mixture model
#'
#' A matrix of 2-dimensional Gaussian mixture samples, the samples came from 4 different Gaussian distributions
#'
#' @docType data
#'
#' @usage data(mmData)
#'
#' @format A matrix of Gaussian samples, each row is one sample.
"mmData"

#' Samples from a hierarchical mixture model
#'
#' A list of 2-dimensional Gaussian mixture samples and the corresponding group labels. The samples are generated by 4 different Gaussian distributions. The samples are separated into 30 groups.
#'
#' @docType data
#'
#' @usage data(mmhData)
#'
#' @format A list of two elements:
#' \describe{
#'   \item{x}{: matrix, 2-dimensional Gaussian samples, each row is a sample}
#'   \item{groupLabel}{: integer, the group label of each Gaussian sample}
#' }
"mmhData"

#' Samples from a hierarchical mixture model with two layers of hierarchies
#'
#' A list of 2-dimensional Gaussian mixture samples and the corresponding group labels. The samples are generated by 4 different Gaussian distributions. Each sample is assigned to a group and a subgroup. There are 2 groups, group 1 has 10 subgroups, group 2 has 20 subgroups.
#'
#' @docType data
#'
#' @usage data(mmhhData)
#'
#' @format A list of three elements:
#' \describe{
#'   \item{x}{: matrix, 2-dimensional Gaussian samples, each row is a sample}
#'   \item{groupLabel}{: integer, the group label of each Gaussian sample}
#'   \item{subGroupLabel}{: integer, the subgroup label of each Gaussian sample}
#' }
"mmhhData"

#' Samples from a simple linear model
#'
#' A list of two elements, a matrix "X" and a numeric vector "x". They came from a linear model: x = X*0.3 + epsilon, where epsilon is Gaussian distributed with mean 0 and variance 25.
#'
#' @docType data
#'
#' @usage data(lrData)
#'
#' @format A list of two elements:
#' \describe{
#'   \item{x}{: numeric, linear samples}
#'   \item{X}{: matrix, the "locations" of the linear samples}
#' }
"lrData"

#' @title Samples from a hierarchical linear model
#' @description
#' The data was part of the 2002 Educational Longitudinal Study (ELS), a survey of students from a large sample of schools across the United States. This dataset includes a population of schools as well as a population of students within each school.
#' @docType data
#'
#' @usage data(lrData)
#'
#' @format A list of three elements:
#' \describe{
#'   \item{mathScore}{: numeric, the mathScore of each student}
#'   \item{socioeconomicStatus}{: numeric, the socioeconomic status score of each student}
#'   \item{schoolID}{: integer, the school ID of each student}
#' }
#' @references Hoff, Peter D. A first course in Bayesian statistical methods. Vol. 580. New York: Springer, 2009.
"hlrData"

#' farm ads data
#'
#' A subset of farm ads data from https://archive.ics.uci.edu/ml/datasets/Farm+Ads
#'
#' @docType data
#'
#' @usage data(farmadsData)
#'
#' @format A list of two elements:
#' \describe{
#'   \item{word}{: character, the words}
#'   \item{document}{: integer, document id of each word}
#' }
#' @source \href{https://archive.ics.uci.edu/ml/datasets/Farm+Ads}{Farm-Ads}
"farmadsData"

#' Cancer mortality of 20 cities
#'
#' Cancer mortality data from Ordinal Data Modeling(1999) p24. This dataset is a list of 20 character vectors, representing the individuals in 20 cities' cancer mortality information. There can be only two possible values "death" and "no death" in each character vector. For example "death" occurs 3 times the 10th character vector, while "no death" occurs 582 times, this mean there are 3 death among the 585 cancer patients in city 10.
#'
#' @docType data
#'
#' @usage data(cancerData)
#'
#' @format A list of 20 character vectors.
#' @references Johnson, Valen E., and James H. Albert. Ordinal data modeling. Springer Science & Business Media, 2006.
"cancerData"

#' @title Samples from a hidden Markov model
#' @description
#' Random samples generated from a Hidden Markov Model (HMM) with 3 hidden states. The initial distribution is c(0.2,0.6,0.2), the transition matrix is matrix(c(0.9, 0.04, 0.06, 0.06, 0.9, 0.07, 0.04, 0.06, 0.87),3,3).
#'
#' @docType data
#'
#' @usage data(hmmData)
#'
#' @format A list of four elements:
#' \describe{
#'   \item{x}{: matrix, two dimensional Gaussian observations. The observations are split into 'Nsegs' segment, see 'Nsegs' and 'breaks' below.}
#'   \item{z}{: integer vector, the real hidden states.}
#'   \item{Nsegs}{: integer, the number of segments.}
#'   \item{breaks}{: integer vector, the starting and ending locations of the segments. The ith segment start at breaks[i]+1, ends at breaks[i+1]}
#' }
"hmmData"


LISP Interpreter Run

[[[[[

 A LISP expression that evaluates to itself!

 Let f(x): x -> (('x)('x))

 Then (('f)('f)) is a fixed point.

]]]]]

[Here is the fixed point done by hand:]

(
'lambda(x) cons cons "' cons x nil
           cons cons "' cons x nil
                nil

'lambda(x) cons cons "' cons x nil
           cons cons "' cons x nil
                nil
)

expression  ((' (lambda (x) (cons (cons ' (cons x nil)) (cons
            (cons ' (cons x nil)) nil)))) (' (lambda (x) (cons
             (cons ' (cons x nil)) (cons (cons ' (cons x nil))
             nil)))))
value       ((' (lambda (x) (cons (cons ' (cons x nil)) (cons
            (cons ' (cons x nil)) nil)))) (' (lambda (x) (cons
             (cons ' (cons x nil)) (cons (cons ' (cons x nil))
             nil)))))

[Now let's construct the fixed point.]

define (f x) let y [be] cons "' cons x nil [y is ('x)        ]
             [return] cons y cons y nil    [return (('x)('x))]

define      f
value       (lambda (x) ((' (lambda (y) (cons y (cons y nil)))
            ) (cons ' (cons x nil))))

[Here we try f:]

(f x)

expression  (f x)
value       ((' x) (' x))

[Here we use f to calculate the fixed point:]

(f f)

expression  (f f)
value       ((' (lambda (x) ((' (lambda (y) (cons y (cons y ni
            l)))) (cons ' (cons x nil))))) (' (lambda (x) (('
            (lambda (y) (cons y (cons y nil)))) (cons ' (cons
            x nil))))))

[Here we find the value of the fixed point:]

eval (f f)

expression  (eval (f f))
value       ((' (lambda (x) ((' (lambda (y) (cons y (cons y ni
            l)))) (cons ' (cons x nil))))) (' (lambda (x) (('
            (lambda (y) (cons y (cons y nil)))) (cons ' (cons
            x nil))))))

[Here we check that it's a fixed point:]

= (f f) eval (f f)

expression  (= (f f) (eval (f f)))
value       true

[Just for emphasis:]

= (f f) eval eval eval eval eval eval (f f)

expression  (= (f f) (eval (eval (eval (eval (eval (eval (f f)
            )))))))
value       true

End of LISP Run

Elapsed time is 0 seconds.


library(ggplot2)
library(tikzDevice)

disp_prob = function(C,Cth,gamma) { # defines the dispersal function
  d = rep(0,length(C))
  d[C>Cth] = 1 - (Cth*(1-gamma))/(C[C>Cth]-Cth*gamma)
  return(d)
}

densx = seq(0,3,len=100) # a vector of population densities
Cth = 1.1 # defining a threshold density value
gammas = c(0,0.5,0.9,0.99)

d = numeric()
dens = numeric()
gam = numeric()

for (g in gammas) {
  d = c(d,disp_prob(densx,Cth,g))
  dens = c(dens,densx)
  gam = c(gam,rep(g,length(densx)))
}

res = data.frame(dens=dens,disp=d,gamma=factor(gam))

gamlab = c(paste(expression(gamma==0)),
           paste(expression(gamma==0.5)),
           paste(expression(gamma==0.9)),
           paste(expression(gamma==0.99)))

x11()

ggplot(res,aes(x=dens,y=disp,colour=gamma, group=gamma, linetype=gamma)) + geom_line(size=1.25) +
  theme_bw(base_size=25) +
  scale_color_grey() +
  theme(legend.position="none", text=element_text(size=25),axis.line.x=element_line(color="black"),axis.line.y=element_line(color="black")) +
  ylab(expression(paste("Emigration probability ", italic(d)[TAE]))) +
  xlab(expression(paste("Estimated population density ",italic(N)[i]^E/bar(italic(K))))) +
  annotate("text",x=c(2.5,2.3,1.9,1.55),y=c(0.475,0.6,0.8,0.9),parse=T,label=gamlab, size=7)

dev.copy2eps(file="figure_1.eps",title="Poethke et al. | Figure 1")


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Optimizing Omega Ration Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Omega
# page 6,9, Optimizing Omega by H. Mausser, D. Saunders, L. Seco
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# The Omega function has the form
# MAX [ SUM <over j> 1/T * u.j ]
# [ SUM <over i> r.ij * x.i ] - u.j + d.j - L * t = 0, for each j = 1,...,T
# [ SUM <over j> 1/T * d.j ] = 1
#  u.j, d.j >= 0, for each j = 1,...,T
#
# Binary b.j enforces that only one of u.j or d.j is greter than 0
# u.j <= b.j
# d.j <= 1 - b.j
#' @export
###############################################################################
add.constraint.omega <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add u.j, d.j, t
	constraints = add.variables(2*nt + 1, constraints, lb = c(rep(0,2*nt),-Inf))
		# Aw < b => Aw1 - bt < 0
		constraints$A[n + 2*nt + 1, ] = -constraints$b
		constraints$b[] = 0

		# lb/ub same transformation
		index = which( constraints$ub[1:n] < +Inf )
		if( len(index) > 0 ) {
			a = rbind( diag(n), matrix(0, 2*nt, n), -constraints$ub[1:n])
			constraints = add.constraints(a[, index], rep(0, len(index)), '<=', constraints)
		}

		index = which( constraints$lb[1:n] > -Inf )
		if( len(index) > 0 ) {
			a = rbind( diag(n), matrix(0, 2*nt, n), -constraints$lb[1:n])
			constraints = add.constraints(a[, index], rep(0, len(index)), '>=', constraints)
		}

		constraints$lb[1:n] = -Inf
		constraints$ub[1:n] = Inf

	# [ SUM <over i> r.ij * x.i ] - u.j + d.j - L * t = 0, for each j = 1,...,T
	a = rbind( matrix(0, n, nt), -diag(nt), diag(nt), -omega)
		a[1 : n0, ] = t(ia$hist.returns)
	constraints = add.constraints(a, rep(0, nt), '=', constraints)

	# [ SUM <over j> 1/T * d.j ] = 1
	constraints = add.constraints(c( rep(0,n), rep(0,nt), (1/nt) * rep(1,nt), 0), 1, '=', constraints)

	# objective : Omega
	# [ SUM <over j> 1/T * u.j ]
	constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, nt), rep(0, nt), 0), value, type[1], constraints)

	return( constraints )
}

#' @export
portfolio.omega <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n]
	if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( apply(portfolio.returns, 1, function(x) mean(pmax(x - omega,0)) / mean(pmax(omega - x,0)) ) )
}

###############################################################################
# Find portfolio that Maximizes Omega
#' @export
###############################################################################
max.omega.portfolio <- function
(
	ia,				# input assumptions
	constraints,	# constraints
	type = c('mixed', 'lp', 'nlp')
)
{
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)
	type = type[1]

	if(type == 'mixed'	|| type == 'lp') {
		sol = optimize.portfolio(ia, constraints, add.constraint.omega, portfolio.omega, 'max', T)

		x = rep(NA, n)
		if(!inherits(sol, 'try-error') && sol$status ==0) {
			x0 = sol$solution[1:n]
			u = sol$solution[(1+n):(n+nt)]
			d = sol$solution[(n+nt+1):(n+2*nt)]
			t = sol$solution[(n+2*nt+1):(n+2*nt+1)]
			x = x0/t
		}
	}

	#portfolio.omega(t(x),ia)
	#sol$value

	if((type == 'mixed' && (sol$status !=0 || any( u*d != 0 ) )) || type == 'nlp') {
		# Try solving problem using Rdonlp2
		if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

		# omega
		fn <- function(x){
			portfolio.returns = x %*% t(ia$hist.returns)
			mean(pmax(portfolio.returns - omega,0)) / mean(pmax(omega - portfolio.returns,0))
		}

		x = optimize.portfolio.nlp(ia, constraints, fn, direction = 'max')
		#portfolio.omega(t(x),ia)
	}

	return( x )
}

###############################################################################
# Create efficient frontier
#' @export
###############################################################################
portopt.omega <- function
(
	ia,						# Input Assumptions
	constraints = NULL,		# Constraints
	nportfolios = 50,		# Number of portfolios
	name = 'Omega'			# Name
)
{
	# set up output
	out = list(weight = matrix(NA, nportfolios, nrow(constraints$A)))
		colnames(out$weight) = rep('', ncol(out$weight))
		colnames(out$weight)[1:ia$n] = ia$symbols

	ef.risk = portopt(ia, constraints, 2)

	# maximum return portfolio
	out$weight[nportfolios, ] = ef.risk$weight[2,]

	# minimum risk portfolio
	out$weight[1, ] = ef.risk$weight[1,]
		constraints$x0 = out$weight[1, ]

	# find points on efficient frontier
	out$return = portfolio.return(out$weight, ia)
	target = seq(out$return[1], out$return[nportfolios], length.out = nportfolios)

	constraints = add.constraints(c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)),
						target[1], type = '<=', constraints)

	for(i in 1:nportfolios ) {
		cat('i =', i, '\n')

		constraints$b[ len(constraints$b) ] = -target[i]
		out$weight[i, ] = max.omega.portfolio(ia, constraints)

			constraints$x0 = out$weight[i, ]
	}

	# compute risk / return
	out$return = portfolio.return(out$weight, ia)
	out$risk = portfolio.risk(out$weight, ia)
	out$name = name

	return(out)
}

###############################################################################
# Plot Omega Ratio for given portfolios (weights)
#' @export
###############################################################################
plot.omega <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	omegafn = function(x,L) { mean(pmax(x-L,0)) / mean(pmax(L-x,0)) }

	if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)

	threshhold = quantile(portfolio.returns, probs = c(0.05, 0.95))
	threshhold = seq(threshhold[1], threshhold[2], length.out = 100)

	par(mar = c(4,4,2,1), cex = 0.8)
	for(i in 1:nrow(weight)) {
		data = sapply(threshhold, function(L) omegafn(portfolio.returns[i, ], L))

		if(i==1) plot(threshhold,log(data), type='l', col=i,
			xlab='Threshhold', ylab='Log(Omega)', main='Portfolio Omega')
		lines(threshhold, log(data), col=i)
	}
	abline(v = omega, col='orange')
	grid()
	plota.legend(rownames(weight) ,1:nrow(weight), x = 'bottomleft')
}


#' svd
#'
#' Singular value decomposition.
#'
#' @details
#' The factorization works by first forming the crossproduct \eqn{X^T X}
#' and then taking its eigenvalue decomposition.  In this case, the square root
#' of the eigenvalues are the singular values.  If the left/right singular
#' vectors \eqn{U} or \eqn{V} are desired, then in either case, \eqn{V} is
#' computed (the eigenvectors).  From these, \eqn{U} can be reconstructed, since
#' if \eqn{X = U\Sigma V^T}, then \eqn{U = XV\Sigma^{-1}}.
#'
#' @section Communication:
#' The operation is completely local except for forming the crossproduct, which
#' is an \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' A shaq.
#' @param nu
#' number of left singular vectors to return.
#' @param nv
#' number of right singular vectors to return.
#' @param LINPACK
#' Ignored.
#'
#' @return
#' A list of elements \code{d}, \code{u}, and \code{v}, as with R's own
#' \code{svd()}.  The elements are, respectively, a regular vector, a shaq, and
#' a regular matrix.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' svd = svd(x)
#' comm.print(svd$d) # a globally owned vector
#' svd$u # a shaq
#' comm.print(svd$v) # a globally owned matrix
#'
#' finalize()
#' }
#'
#' @name svd
#' @rdname svd
NULL

svd.shaq = function(x, retu=FALSE, retv=FALSE)
{
  if (!retu && !retv)
    only.values = TRUE
  else
    only.values = FALSE

  cp = cp.shaq(x)

  ev = eigen(cp, only.values=only.values, symmetric=TRUE)

  d = sqrt(ev$values)

  if (retu)
  {
    # u.local = ev$vectors %*% diag(1/d)
    u.local = sweep(ev$vectors, STATS=1/d, MARGIN=2, FUN="*")
    u.local = Data(x) %*% u.local
    u = shaq(u.local, nrow(x), ncol(x), checks=FALSE)
  }
  else
    u = NULL

  if (retv)
    v = ev$vectors
  else
    v = NULL

  list(d=d, u=u, v=v)
}

#' @rdname svd
#' @export
setMethod("svd", signature(x="shaq"),
  function(x, nu = min(n, p), nv = min(n, p), LINPACK = FALSE)
  {
    n = nrow(x)
    p = ncol(x)

    check.is.natnum(nu)
    check.is.natnum(nv)

    retu = nu > 0
    retv = nv > 0

    ret = svd.shaq(x, retu, retv)

    if (nu && ncol(ret$u) > nu)
      ret$u = ret$u[, 1:nu]

    if (nv && NCOL(ret$v) > nv)
      ret$v = ret$v[, 1:nv]

    ret
  }
)


pi = 3.14159
circle_radius = 10.2
circle_perimeter = 2 * pi * circle_radius
circle_area = pi * circle_radius * circle_radius
cat("Let there be a circle with the radius", circle_radius, "cm.\n")
cat("Then the perimeter of the circle is", circle_perimeter, "cm.\n")
cat("The area of the circle is", circle_area, "cm squared.\n")


# Returns the number of conversions
get_conversions <- function(theta, impressions) {
  k <- ncol(theta)
  y <- rep(0.0, k)
  for (i in 1:k) {
    y[i] <- rbinom(1, size=impressions[i], prob=theta[i])
  }
  return(y)
}

# Returns the probability
get_probability <- function(conversion, impressions) {
  k <- length(conversion)
  theta <- matrix(nrow=1000, ncol=k)
  for (i in 1:k) {
    theta[,i] <- rbeta(1000, shape1=conversion[i]+1, shape2=impressions[i]-conversion[i]+1)
  }
  return(theta)
}

#Compute allocations
get_allocations <- function(theta) {
  k <- ncol(theta)
  allocations <- table(factor(max.col(theta), level=1:k))
  return(allocations/sum(allocations))
}

# COnversion and impressions are cumulative counts
# Assumed conversion rate of each creative for testing
ndays <- 10 #days to simulate
assumed_conversion <- c(0.02, 0.01, 0.01, 0.02)
conversion <- matrix(0, nrow=ndays, ncol=4)
impressions <- matrix(0, nrow=ndays, ncol=4)
impressions[1,] <- c(1000, 0, 0, 0)
next_day_allocations <- matrix(0, nrow=ndays+1, ncol=4)

#Simulating day 1
conversion[1,] <- assumed_conversion * impressions[1,]
theta <- get_probability(conversion[1,], impressions[1,])
y <- get_conversions(theta, impressions[1,])
next_day_allocations[2,] <- get_allocations(theta) * 1000

#Simulating days
for (day in 2:ndays) {
  impressions[day,] <- impressions[day-1,] + next_day_allocations[day,]
  conversion[day,] <- conversion[day-1,] + (assumed_conversion * next_day_allocations[day,])
  theta <- get_probability(conversion[day,], impressions[day,])
  y <- get_conversions(theta, impressions[day,])
  next_day_allocations[day+1,] <- get_allocations(theta) * 1000
}


#' Path disutility updater
#'
#' This function updates the path disutility at time t+1 based on disutility and path costs at time t. The path costs are computed from pattern of link flows.
#' @param x Traffic flow on all links of network
#' @param A Link-path incidence matrix
#' @param psi Recency parameter, controlling weight assigned to most recent path costs when updating disutility. Defaults to 1.
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param ut Vector of path disutilities prior to update
#' @return Vector of path disutilities
#' @keywords disutility
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' Alpha <- rep(10,7)
#' Beta <- rep(2,7)
#' pow <- rep(4,7)
#' path_flow <- c(10,20,15,15)
#' x <- A%*%path_flow
#' ut <- c(10,10,10,10)
#' Utility(x,A,psi=0.5,Alpha,Beta,pow,ut)
#' @export

Utility <- function(x,A=diag(length(x)),psi=1,Alpha,Beta,pow=4,ut=0){
  	psi*PathCost(x,A,Alpha=Alpha,Beta=Beta,pow=pow) + (1-psi)*ut
}


# Copyright 2014-2019 Arnaud Poret
# This work is licensed under the BSD 2-Clause License.
# To view a copy of this license, visit https://opensource.org/licenses/BSD-2-Clause

# continuous logical NOT operator
# here the algebraic formulation is used
not<-function(a) {
    return(1-a)
}

# continuous logical AND operator
# here the algebraic formulation is used
# note that it accepts two or more arguments
and<-function(a,b,...) {
    x<-c(a,b,...)
    y<-x[1]
    for(i in seq(2,length(x))) {
        y<-y*x[i]
    }
    return(y)
}

# continuous logical OR operator
# here the algebraic formulation is used
# note that it accepts two or more arguments
or<-function(a,b,...) {
    x<-c(a,b,...)
    y<-x[1]
    for(i in seq(2,length(x))) {
        y<-y+x[i]-y*x[i]
    }
    return(y)
}

# main function: performs the simulation
dothejob<-function(node0,r,w,kend,nedge,nnode,nodelab,plotall,printall) {
    node<-as.matrix(node0)
    edge<-as.matrix(fedge(node,1,nedge))
    for(k in seq(2,kend)) {
        edge<-cbind(edge,as.matrix((1-r)*edge[,k-1]+r*w*fedge(node,k-1,nedge)))
        node<-cbind(node,as.matrix(fnode(edge,k-1,nnode)))
    }
    if(plotall) {
        for(i in seq(ceiling(nnode/9))) {
            dev.new()
            par(mfrow=c(3,3))
        }
        for(i in seq(nnode)) {
            nplot<-ceiling(i/9)
            dev.set(nplot+1)
            plot(node[i,],type="l",main=nodelab[i],ylim=c(0,1),xlab="",ylab="")
            if(printall) {
                dev.print(device=svg,filename=paste("plot",as.character(nplot),".svg",sep=""))
            }
        }
    }
    return(node)
}


vis2aot_vermote <- function(vis) {
  aot = (3.9449 / vis) + 0.08498

  return(aot)
}

vis2aot_k <- function(vis) {
  aot = (3.912 / vis)

  return(aot)
}

vis2aot_sixs <- function(vis) {
  # vertical repartition of aerosol density for v=23km
  #                 (in number of particles per cm3)
   an23 = c(2.828e+03,1.244e+03,5.371e+02,2.256e+02,1.192e+02
  ,8.987e+01,6.337e+01,5.890e+01,6.069e+01,5.818e+01,5.675e+01
  ,5.317e+01,5.585e+01,5.156e+01,5.048e+01,4.744e+01,4.511e+01
  ,4.458e+01,4.314e+01,3.634e+01,2.667e+01,1.933e+01,1.455e+01
  ,1.113e+01,8.826e+00,7.429e+00,2.238e+00,5.890e-01,1.550e-01
  ,4.082e-02,1.078e-02,5.550e-05,1.969e-08,0.000e+00)

  # vertical repartition of aerosol density for v=5km
  #                 (in number of particles per cm3)
   an5 = c(1.378e+04,5.030e+03,1.844e+03,6.731e+02,2.453e+02
  ,8.987e+01,6.337e+01,5.890e+01,6.069e+01,5.818e+01,5.675e+01
  ,5.317e+01,5.585e+01,5.156e+01,5.048e+01,4.744e+01,4.511e+01
  ,4.458e+01,4.314e+01,3.634e+01,2.667e+01,1.933e+01,1.455e+01
  ,1.113e+01,8.826e+00,7.429e+00,2.238e+00,5.890e-01,1.550e-01
  ,4.082e-02,1.078e-02,5.550e-05,1.969e-08,0.000e+00)

   # Altitude (z) levels
   z = c(0.,    1.,    2.,    3.,    4.,    5.,    6.,    7.,    8.,
   9.,   10.,   11.,   12.,   13.,   14.,   15.,   16.,   17.,
  18.,   19.,   20.,   21.,   22.,   23.,   24.,   25.,   30.,
  35.,   40.,   45.,   50.,   70.,  100.,99999.)

   aot = 0.0
   sigma = 0.056032

#    if (any(vis <= 0))
#    {
#      return()
#    }

   # Numerically integrate over each layer of the atmosphere summing the
   # calculated AOT

   for (k in 1:32)
   {
     # Calculate dz (the difference on the x axis)
     dz = z[k+1] - z[k]

     # Get the points on the curve for both ends of dz
     point_left_5 = an5[k]
     point_right_5 = an5[k+1]

     point_left_23 = an23[k]
     point_right_23 = an23[k+1]

     # Calculate the difference
     diff_left = (115.0/18.0) * (point_left_5 - point_left_23)
     diff_right = (115.0/18.0) * (point_right_5 - point_right_23)

     # Convert from per Km back to Km
     diff_left_km = (5.0 * point_left_5/18.0) - (23.0 * point_left_23/18.0)
     diff_right_km = (5.0 * point_right_5/18.0) - (23.0 * point_right_23/18.0)

     # Use interpolation formula from the docs (uses -b(z) as shown in FORTRAN code rather than +b(z) as in manual)
     interp_left = diff_left/vis - diff_left_km
     interp_right = diff_right/vis - diff_right_km

     # Calculate AOT for this level
     ev = dz * exp( (log(interp_left)+log(interp_right)) * 0.5)
     aot = aot + (ev * sigma * 1.0e-03)
   }
   return(aot)
}

data <- read.csv("data/MODTRAN_VisAOT.csv")
vis2aot_modtran <- approxfun(data$vis, data$aot)


library(nloptr)
library(rlist)
source("bootstrapping.r")

get_expected_I = function(beta, N0, lambda) {
  "
  Calculates expected new case counts for each step in the time series.

  Parameters
  ----------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  N0 : numeric
    Initial number of cases.
  lambda : numeric
    (1 / mean) number of days an individual will continue to be infectious.

  Returns
  -------
  expected_I : numeric vector
    Daily expected number of new cases.
  "
  moments = length(beta)
  expected_I = rep(0, moments)
  expected_N = rep(0, moments)
  N_previous = N0
  for(t in 1:moments){
    expected_N[t] = N_previous * (beta[t] + pexp(1, rate=lambda, lower.tail=FALSE))
    expected_I[t] = N_previous * beta[t]
    N_previous = expected_N[t]
  }
  return(expected_I)
}

optimize_lambda = function(observed_I, beta, N0, lambda0, lambda_min, lambda_max) {
  "
  Find lambda that optimizes the quartic error of estimation of E[I(t)].

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  N0 : numeric
    Initial number of cases.
  lambda0 : numeric
    Initial value for lambda.

  Returns
  -------
  lambda : numeric
    Optimal value for lambda.
  "
  # define objective function: mean quartic error of estimation  of new cases
  mean_quartic_error = function(lambda) {
    expected_I = get_expected_I(beta, N0, lambda)
    return(mean((observed_I - expected_I) ^ 4))
  }
  # optimize
  local_opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                      "xtol_rel" = 1.0e-7 )
  opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                "xtol_rel" = 1.0e-7,
                "maxeval" = 100000,
                "local_opts" = local_opts )
  result <- nloptr(x0=lambda0, eval_f=mean_quartic_error, eval_grad_f=NULL,
                   lb=lambda_min, ub=lambda_max, opts=opts)
  return(result$solution)
}

fit = function(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
               lambda_max, N0_min, N0_max, alpha, ignore_beta_diff) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # set optimization parameters
  moments = length(observed_I)
  beta_min =rep(beta_min, times=moments)
  beta_max =rep(beta_max, times=moments)
  local_opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                      "xtol_rel" = 1.0e-7 )
  opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                "xtol_rel" = 1.0e-7,
                "maxeval" = 100000,
                "local_opts" = local_opts )
  # optimize over several N0
  best = list()
  best$loss = Inf
  for (N0 in N0_min:N0_max) {
    loss = function(beta) {
      lambda = optimize_lambda(observed_I, beta, N0, lambda0, lambda_min,
                               lambda_max)
      expected_I = get_expected_I(beta, N0, lambda)
      beta_diff = diff(beta)
      beta_diff = beta_diff[!1:length(beta_diff) %in% ignore_beta_diff]
      loss = mean((expected_I - observed_I) ^ 4) + alpha * mean(beta_diff ^ 2)
      return(loss)
    }
    result <- nloptr(x0=beta0, eval_f=loss, eval_grad_f=NULL, lb=beta_min,
                     ub=beta_max, opts=opts)
    if(result$objective < best$loss) {
      best$loss = result$objective
      best$N0 = N0
      best$beta = result$solution
    }
  }
  best$lambda = optimize_lambda(observed_I, best$beta, best$N0, lambda0,
                                lambda_min, lambda_max)
  return(best)
}

fit2 = function(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
               lambda_max, N00, N0_min, N0_max, alpha, ignore_beta_diff) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, lambda0, N00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), lambda_min, N0_min)
  ub = c(rep(beta_max, steps), lambda_max, N0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7,
              "maxeval" = 10000000)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    lambda = x[steps + 1]
    N0 = x[steps + 2]
    # calculate loss
    expected_I = get_expected_I(beta, N0, lambda)
    beta_diff = diff(beta)
    beta_diff = beta_diff[!1:length(beta_diff) %in% ignore_beta_diff]
    loss = mean((expected_I - observed_I) ^ 4) + alpha * mean(beta_diff ^ 2)
  }
  result = nloptr(x0=x0, eval_f=loss, eval_grad_f=NULL, lb=lb, ub=ub, opts=opts)
  model = list()
  model$beta = result$solution[1:steps]
  model$lambda = result$solution[steps + 1]
  model$N0 = result$solution[steps + 2]
  model$loss = result$objective
  return(model)
}

fit3 = function(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
               lambda_max, N00, N0_min, N0_max, regularization, regularization_weights, ignore_beta_diff, window_size=10) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, lambda0, N00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), lambda_min, N0_min)
  ub = c(rep(beta_max, steps), lambda_max, N0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7,
              "maxeval" = 100000)
  observed_variances = compute_variances(observed_I, window_size)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    lambda = x[steps + 1]
    N0 = x[steps + 2]
    # calculate loss
    expected_I = get_expected_I(beta, N0, lambda)
    beta_diff = diff(beta)
    alpha = regularization_weights*(observed_variances)
    #6.4e8
    loss = mean((expected_I - observed_I) ^ 4) +(regularization)* mean(alpha[1:(length(alpha) - 1)] * (beta_diff ^ 2))
    return(loss)
  }
  result = nloptr(x0=x0, eval_f=loss, eval_grad_f=NULL, lb=lb, ub=ub, opts=opts)
  model = list()
  model$beta = result$solution[1:steps]
  model$lambda = result$solution[steps + 1]
  model$N0 = result$solution[steps + 2]
  model$loss = result$objective
  return(model)
}


#importa pacote
library('readr')

# Lê/coleta dados no arquivo

dados_cliente <- read.csv("./clientes.csv",sep=";")

head(dados_cliente)

# Descrever a estrutura dos dados

str(dados_cliente)

tail(dados_cliente)

# Definimos que a variável Grau.Instrução deve ser tratada como ordinal

levels(dados_cliente$Grau.Instrução)

# Frequência absoluta

fa <- table(dados_cliente$Estado.civil)
fa

# Frequência relativa

fr1 <- fa/length(dados_cliente$Estado.civil)
fr1

# Frequência relativa

fr2 <- prop.table(fa)
fr2

# Frequência percentual

fpct <- prop.table(fa)*100
fpct

round(fpct,digit=2)

# Moda
names(fa)[which.max(fa)]

barplot(fa,main = "Frequência absoluta",xlab = "Estado Civil",ylab = "Quantidade")

pie(main = "Frequência relativa percentual",fpct,labels=as.character(round(fpct,digits = 2)))

# Frequência absoluta

fa <- table(dados_cliente$Grau.Instrução)
fa
# Frequência relativa

fr <- prop.table(fa)
fr

# Frequência percentual

fpct <- prop.table(fa)*100
fpct

# Moda
names(fa)[which.max(fa)]

barplot(sort(fr),main = "Frequência relativa",xlab = "Valor",ylab = "Grau de Instrução",col = "darkred",horiz = TRUE)

barplot(sort(fa),main = "Frequência absoluta",ylab = "Qtde",xlab = "Grau de Instrução")

barplot(fa,main = "Frequência absoluta",ylab = "Qtde",xlab = "Grau de Instrução")

levels(dados_cliente$Grau.Instrução)

dados_cliente$Grau.Instrução <- factor(dados_cliente$Grau.Instrução,levels = c('Fundamental','Médio','Superior','Mestrado','Doutorado'))

fa <- table(dados_cliente$Grau.Instrução)

barplot(fa,main = "Frequência absoluta",ylab = "Qtde",xlab = "Grau de Instrução")

head(dados_cliente,2)

# Frequência absoluta

fa <- table(dados_cliente$Qtde.Filhos)
print('Frequência absoluta:')
fa

# Frequência relativa

fr <- prop.table(fa)
print('Frequência relativa:')
round(fr,digit=0)

# Frequência percentual

fpct <- prop.table(fa)*100
print('Frequência relativa percentual:')
round(fpct,digit=0)

# na.rm=TRUE --> Pq alguns valores são NA
# Moda
print("Moda")
names(fa)[which.max(fa)]

# Mediana
print("Mediana")
median(dados_cliente$Qtde.Filhos,na.rm=TRUE)

#Média
print("Media")
mean(dados_cliente$Qtde.Filhos,na.rm=TRUE)

#Quartis
print("quartis")
quantile(dados_cliente$Qtde.Filhos,na.rm=TRUE)
#min
print("min")
min(dados_cliente$Qtde.Filhos,na.rm=TRUE)
#max
print("max")
max(dados_cliente$Qtde.Filhos,na.rm=TRUE)

# Amplitude (max-min)
print("Amplitude")
diff(range(dados_cliente$Qtde.Filhos,na.rm=TRUE))

# Variancia
print("Variancia")
var(dados_cliente$Qtde.Filhos,na.rm=TRUE)

# Desvio-padrão
print("Desvio-padrão")
sd(dados_cliente$Qtde.Filhos,na.rm=TRUE)

# Coeficiênte de variação
print("Coeficiênte de variação")
sd(dados_cliente$Qtde.Filhos,na.rm=TRUE)/mean(dados_cliente$Qtde.Filhos,na.rm=TRUE)

quartis <- quantile(dados_cliente$Qtde.Filhos,na.rm=TRUE)
# Amplitude interquartilica
print("Amplitude interquartilica")
quartis[4]-quartis[2]

#Resumo
summary(dados_cliente$Qtde.Filhos)

# Frequência absoluta acumulada

faa <- cumsum(fa)
faa

fa

plot(fa,main = "Frequência absoluta",ylab = "Frequência",xlab = "Qtde. de Filhos")

plot(faa,main = "Frequência absoluta acumulada",ylab = "Frequência",xlab = "Qtde. de Filhos",type="S")

head(dados_cliente,2)

summary(dados_cliente$Salário)

# Min e Max
range(dados_cliente$Salário)

#min
min <- min(dados_cliente$Salário,na.rm=TRUE)
#max
max <- max(dados_cliente$Salário,na.rm=TRUE)

#Qtde de classes
nclass.Sturges(dados_cliente$Salário)

# Agrupar
print(cut(dados_cliente$Salário,breaks=seq(min,max,length.out=8)))

# Agrupar
grupos <- cut(dados_cliente$Salário,breaks=seq(min,max,length.out=8))

print(grupos)

# Frequência absoluta

fa <- table(grupos)
print('Frequência absoluta:')
fa

# Frequência relativa

fr <- prop.table(fa)
print('Frequência relativa:')
round(fr,digit=0)

hist(dados_cliente$Salário,main=" Histograma - Salário",ylab = "Frequência",xlab = "Valor salário")

hist(dados_cliente$Salário,main=" Histograma - Salário",ylab = "Densidade",xlab = "Valor salário",freq=FALSE,labels=TRUE)

boxplot(dados_cliente$Salário,main=" Boxplot - Salário",ylab = "Valor salário")

BootCamp Engenheiro de Dados/Modulo 1 - Materiais/Material_complementar_videoaulas/Analise_univariada.r


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

# Brad Ballard
# CS498 Applied Machine Learning at UIUC

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

# Works cited
# Resource used: http://luthuli.cs.uiuc.edu/~daf/courses/AML-18/RCodeClassification/pimanbholdout.R
# Resource used: http://luthuli.cs.uiuc.edu/~daf/courses/AML-18/RCodeClassification/klarcaret.R
# Resource used: http://luthuli.cs.uiuc.edu/~daf/courses/AML-18/RCodeClassification/svmholdout.R
# Worked with Jacob Rettig (classmate) on this assignment

# Import packages
options(warn=-1)
library(caret)
library(klaR)

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

# Part A: Naive Bayes without package

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

#load data
setwd('/Users/bradjballard/')
data_in<-read.csv('pima.csv', header=FALSE)
x_vector <- data_in[-c(9)]
y_labels <- data_in[,9]

#train naive bayes model
trscore<-array(dim=10)
tescore<-array(dim=10)

for (wi in 1:10){
  #create training and testing sets
  datasplit <- createDataPartition(y=y_labels, p=.8, list=FALSE)
  trainx <- x_vector[datasplit,]
  trainy <- y_labels[datasplit]
  testx <- x_vector[-datasplit,]
  testy <- y_labels[-datasplit]

  #splitting positive and negative examples
  trposflag<-trainy>0
  positive_examples <- trainx[trposflag, ]
  negative_examples <- trainx[!trposflag,]

  #calculate means and sds
  ptrmean<-sapply(positive_examples, mean, na.rm=TRUE)
  ntrmean<-sapply(negative_examples, mean, na.rm=TRUE)
  ptrsd<-sapply(positive_examples, sd, na.rm=TRUE)
  ntrsd<-sapply(negative_examples, sd, na.rm=TRUE)

  #calculate offsets and scales
  ptroffsets<-t(t(trainx)-ptrmean)
  ptrscales<-t(t(ptroffsets)/ptrsd)

  pteoffsets<-t(t(testx)-ptrmean)
  ptescales<-t(t(pteoffsets)/ptrsd)
  ptelogs<--(1/2)*rowSums(apply(ptescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ptrsd))
  nteoffsets<-t(t(testx)-ntrmean)
  ntescales<-t(t(nteoffsets)/ntrsd)
  ntelogs<--(1/2)*rowSums(apply(ntescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ntrsd))
  lvwte<-ptelogs>ntelogs
  gotright<-lvwte==testy
  tescore[wi]<-sum(gotright)/(sum(gotright)+sum(!gotright))
}
accuracy <- sum(tescore) / length(tescore)

#accuracy after cross validating 10 times
accuracy

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

# Part B: NB with missing data removed

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

#replace '0' in columns with NA
x_vector_copy <- x_vector
for (i in c(3, 4, 6, 8)){
  non_values <- x_vector[, i]==0
  x_vector_copy[non_values, i]=NA
}

#train naive bayes model
trscore<-array(dim=10)
tescore<-array(dim=10)

for (wi in 1:10){
  #create training and testing sets
  datasplit <- createDataPartition(y=y_labels, p=.8, list=FALSE)
  trainx <- x_vector_copy[datasplit,]
  trainy <- y_labels[datasplit]
  testx <- x_vector_copy[-datasplit,]
  testy <- y_labels[-datasplit]

  #splitting positive and negative examples
  trposflag<-trainy>0
  positive_examples <- trainx[trposflag, ]
  negative_examples <- trainx[!trposflag,]

  #calculate means and sds
  ptrmean<-sapply(positive_examples, mean, na.rm=TRUE)
  ntrmean<-sapply(negative_examples, mean, na.rm=TRUE)
  ptrsd<-sapply(positive_examples, sd, na.rm=TRUE)
  ntrsd<-sapply(negative_examples, sd, na.rm=TRUE)

  #calculate offsets and scales
  ptroffsets<-t(t(trainx)-ptrmean)
  ptrscales<-t(t(ptroffsets)/ptrsd)

  pteoffsets<-t(t(testx)-ptrmean)
  ptescales<-t(t(pteoffsets)/ptrsd)
  ptelogs<--(1/2)*rowSums(apply(ptescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ptrsd))
  nteoffsets<-t(t(testx)-ntrmean)
  ntescales<-t(t(nteoffsets)/ntrsd)
  ntelogs<--(1/2)*rowSums(apply(ntescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ntrsd))
  lvwte<-ptelogs>ntelogs
  gotright<-lvwte==testy
  tescore[wi]<-sum(gotright)/(sum(gotright)+sum(!gotright))
}
accuracy <- sum(tescore) / length(tescore)

#accuracy after cross validating 10 times
accuracy

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

## Part C: NB with package

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

#create training and testing sets
test_accuracies <- array(dim=10)

for (wi in 1:10){
  datasplit <- createDataPartition(y=y_labels, p=.8, list=FALSE)
  trainx <- x_vector[datasplit,]
  trainy <- y_labels[datasplit]
  testx <- x_vector[-datasplit,]
  testy <- y_labels[-datasplit]

  #train naive bayes model using klaR package
  tr <- trainControl(method='cv' , number=10)
  model <- train (trainx , factor(trainy) , 'nb' , trControl=tr)

  #prediction
  predictions <- predict(model, newdata=testx)
  correct <- length(testy[testy == predictions])
  wrong <- length(testy[testy != predictions])
  accuracy <- correct / (correct + wrong)
  test_accuracies[wi] <- accuracy
}
cross_validation_accuracy <- sum(test_accuracies)/length(test_accuracies)

#accuracy after cross validating 10 times
cross_validation_accuracy

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

## Part D: Using SVMLight

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

#create data sets for training and testing
datasplit<-createDataPartition(y=y_labels, p=.8, list=FALSE)
trainx <- x_vector[datasplit,]
trainy <- y_labels[datasplit]
testx <- x_vector[-datasplit,]
testy <- y_labels[-datasplit]

#train svm
svm <- svmlight(trainx, factor(trainy), pathsvm="/Users/bradjballard/svm_light_osx.8.4_i7/")
labels <- predict(svm, testx)
answers <- labels$class

#accuracy
correct <- sum(answers == testy)
wrong <- sum(answers != testy)
accuracy <- correct / (correct + wrong)
accuracy


model_netradiation <- function (minTair = 0.7,
         maxTair = 7.2,
         albedoCoefficient = 0.23,
         stefanBoltzman = 4.903e-09,
         elevation = 0.0,
         solarRadiation = 3.0,
         vaporPressure = 6.1,
         extraSolarRadiation = 11.7){
    #'- Name: NetRadiation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: NetRadiation Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * Abstract: It is calculated at the surface of the canopy and is givenby the difference between incoming and outgoing radiation of both short
    #'                     and long wavelength radiation
    #'- inputs:
    #'            * name: minTair
    #'                          ** description : minimum air temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** default : 0.7
    #'                          ** unit : °C
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: maxTair
    #'                          ** description : maximum air Temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** default : 7.2
    #'                          ** unit : °C
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: albedoCoefficient
    #'                          ** description : albedo Coefficient
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.23
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: stefanBoltzman
    #'                          ** description : stefan Boltzman constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 4.903E-09
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: elevation
    #'                          ** description : elevation
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0
    #'                          ** min : -500
    #'                          ** max : 10000
    #'                          ** unit : m
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: solarRadiation
    #'                          ** description : solar Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 3
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: vaporPressure
    #'                          ** description : vapor Pressure
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 6.1
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: extraSolarRadiation
    #'                          ** description : extra Solar Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 11.7
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : MJ m2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: netRadiation
    #'                          ** description :  net radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: netOutGoingLongWaveRadiation
    #'                          ** description : net OutGoing Long Wave Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    Nsr <- (1.0 - albedoCoefficient) * solarRadiation
    clearSkySolarRadiation <- (0.75 + (2 * 10.0 ^ (-5) * elevation)) * extraSolarRadiation
    averageT <- ((maxTair + 273.16) ^ 4 + (minTair + 273.16) ^ 4) / 2.0
    surfaceEmissivity <- 0.34 - (0.14 * sqrt(vaporPressure / 10.0))
    cloudCoverFactor <- 1.35 * (solarRadiation / clearSkySolarRadiation) - 0.35
    Nolr <- stefanBoltzman * averageT * surfaceEmissivity * cloudCoverFactor
    netRadiation <- Nsr - Nolr
    netOutGoingLongWaveRadiation <- Nolr
    return (list ("netRadiation" = netRadiation,"netOutGoingLongWaveRadiation" = netOutGoingLongWaveRadiation))
}


=begin
  # sample-factorize04.rb

  require "algebra"

  A = AlgebraicExtensionField(Rational, "a") {|a| a**2 - 2}
  B = AlgebraicExtensionField(A, "b"){|b| b**2 + 1}
  P = Polynomial(B, "x")
  x = P.var
  f = x**4 + 1
  p f.factorize
  #=> (x - 1/2ab - 1/2a)(x + 1/2ab - 1/2a)(x + 1/2ab + 1/2a)(x - 1/2ab + 1/2a)
((<_|CONTENTS>))
=end


#' @title
#' Multivatiate functional regression via nested reduced-rank regularization
#'
#' @description
#' This function takes functional observations as input and fits a nested
#' reduced-rank regression with a user-specified rank selection method.
#' The B-spline basis is used to conduct basis expansion.
#'
#' @usage
#' NRRR.func(Y, X, jx, jy, degree = 3, S.interval = NULL, T.interval = NULL,
#'           tuning = c('CV', 'BIC', 'BICP', 'AIC', 'GCV')[1],
#'           nfold = 10, norder = NULL, method = c('RRR', 'RRS')[1],
#'           lambda = 0, maxiter = 300, conv = 1e-4,
#'           dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
#'           yrankfix = NULL, lang = c('R', 'Rcpp')[1])
#'
#' @param Y a data frame of the functional responses with d columns
#'          for the values of the response components, a column indicating subject ID named as 'ID'
#'          and a column of observation times named as 'TIME'.
#' @param X a data frame of the functional predictors with p columns
#'          for the values of the predictor components, a column indicating subject ID named as 'ID'
#'          and a column of observation times named as 'TIME'. Order of Subject ID should be the SAME as that of Y.
#' @param jx number of basis functions to expand the predictor trajectory.
#' @param jy number of basis functions to expand the response trajectory.
#' @param S.interval range of observation times of X, e.g., \code{S.interval = c(0, 1)}. Default is NULL.
#' @param T.interval range of observation times of Y, e.g., \code{T.interval = c(0, 1)}. Default is NULL.
#' @param degree degree of piecewise polynomial. Default is 3. See \code{\link{bs}}.
#' @param tuning methods to select ranks. If \code{tuning = 'CV'}, then cross validation
#'               is used to select ranks. Otherwise, the selected information criterion
#'               is used to select ranks.
#' @param nfold the number of folds used in cross validation. Default is 10.
#' @param norder a vector of length n that assigns samples to multiple folds for cross validation.
#' @param method 'RRR' (default): no additional ridge penalty; 'RRS': add an
#'               additional ridge penalty.
#' @param lambda the tuning parameter to control the amount of ridge
#'               penalization. It is only used when \code{method = 'RRS'}.
#'               Default is 0.
#' @param maxiter the maximum iteration number of the
#'                blockwise coordinate descent algorithm. Default is 300.
#' @param conv the tolerance level used to control the convergence of the
#'             blockwise coordinate descent algorithm. Default is 1e-4.
#' @param dimred a vector of logical values to decide whether to use the specified tuning method
#'               do rank selection on certain dimensions. TRUE means the rank is selected
#'               by the specified tuning method.
#'               If \code{dimred[1] = FALSE}, r is provided by \code{rankfix}
#'               or \eqn{min(jy*d, rank(X))};
#'               If \code{dimred[2] = FALSE}, rx equals to \code{xrankfix} or p;
#'               If \code{dimred[3] = FALSE},
#'               ry equals to \code{yrankfix} or d.
#'               Default is \code{c(TRUE, TRUE, TRUE)}.
#' @param rankfix a user-provided value of r when \code{dimred[1] = FALSE}. Default is NULL
#'                which leads to \eqn{r = min(jy*d, rank(X))}.
#' @param xrankfix a user-provided value of rx when \code{dimred[2] = FALSE}. Default is NULL
#'                 which leads to \code{rx = p}.
#' @param yrankfix a user-provided value of ry when \code{dimred[3] = FALSE}. Default is NULL
#'                 which leads to \code{ry = d}.
#' @param lang 'R' (default): the R version function is used; 'Rcpp': the Rcpp
#'             version function is used.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'   \item{Al}{the estimated A.}
#'   \item{Bl}{the estimated B.}
#'   \item{C}{the estimated coefficient matrix C.}
#'   \item{df}{the estimated degrees of freedom of the selected model.}
#'   \item{sse}{the sum of squared errors of the selected model.}
#'   \item{ic}{a vector containing values of BIC, BICP, AIC, GCV of the selected model.}
#'   \item{rx_path}{a matrix displays the path of selecting rx with cross validation. Only available when 'CV' is selected.}
#'   \item{ry_path}{a matrix displays the path of selecting ry with cross validation. Only available when 'CV' is selected.}
#'   \item{r_path}{a matrix displays the path of selecting r with cross validation. Only available when 'CV' is selected.}
#   \item{iter}{the number of iterations needed to converge in the selected model.}
#'   \item{rank}{the estimated r.}
#'   \item{rx}{the estimated rx.}
#'   \item{ry}{the estimated ry.}
#'   \item{sseq}{sequence of the time points of observing the predictor trajectory.}
#'   \item{phi}{the basis functions to expand the predictor trajectory.}
#'   \item{tseq}{sequence of the time points of observing the response trajectory.}
#'   \item{psi}{the basis functions to expand the response trajectory.}
#'
#' @details
#' This function applies a basis expansion and truncation method to transform
#' the functional problem into a classical finite-dimensional regression problem,
#' and then fits a nested reduced-rank regression.
#' The functional observations are commonly collected in a discrete mannar, and before using this
#' function, the functional response observations and functional predictor observations
#' should be saved as a data frame. Data standardization procedures, e.g., centering or
#' scaling, should be conducted before using this function. B-spline basis is
#' used to conduct basis expansion. If the functional data are already processed into an integrated form,
#' functions like \code{\link{NRRR.est}}, \code{\link{NRRR.ic}} or \code{\link{NRRR.cv}} can
#' be used to fit a NRRR model.
#'
#'
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#'
#' @examples
#' n <- 100
#' ns <- 80
#' nt <- 80
#' p <- 10
#' d <- 10
#' jx <- 8
#' jy <- 8
#' library(NRRR)
#' set.seed(3)
#' # generate functional data
#' simDat <- NRRR.sim(n = 100, ns = 80, nt = 80, r = 3, rx = 3, ry = 3,
#'                    jx = 8, jy = 8, p = 10, d = 10, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' # dimension: c(n, d, nt)
#' dim(simDat$Y)
#' # dimension: c(n, p, ns)
#' dim(simDat$X)
#' # process the functional data into a data frame with columns:
#' # predictor/response components, subject ID, and observation time
#'
#' Y <- t(simDat$Y[1,,])
#' for (i in 2:n){
#'   Y <- rbind(Y, t(simDat$Y[i,,]))
#' }
#' Y <- data.frame(Y)
#' Y$TIME <- rep(simDat$tseq, n)
#' Y$ID <- rep(1:n, each = nt) # Y: nt*n rows, d+2 columns
#' head(Y)
#'
#' X <- t(simDat$X[1,,])
#' for (i in 2:n){
#'   X <- rbind(X, t(simDat$X[i,,]))
#' }
#' X <- data.frame(X)
#' X$TIME <- rep(simDat$sseq, n)
#' X$ID <- rep(1:n, each = ns) # X: ns*n rows, p+2 columns
#' head(X)
#'
#' fit_func <- NRRR.func(Y, X, jx, jy, degree = 3, S.interval = NULL, T.interval = NULL,
#'                       tuning = c('CV', 'BIC', 'BICP', 'AIC', 'GCV')[2],
#'                       nfold = 10, norder = NULL, method = c('RRR', 'RRS')[1],
#'                       lambda = 0, maxiter = 300, conv = 1e-4,
#'                       dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
#'                       yrankfix = NULL, lang = c('R', 'Rcpp')[1])
#' @export
NRRR.func <- function(Y, X, jx, jy, degree = 3, S.interval = NULL, T.interval = NULL,
                      tuning = c('CV', 'BIC', 'BICP', 'AIC', 'GCV')[1],
                      nfold = 10, norder = NULL, method = c('RRR', 'RRS')[1],
                      lambda = 0, maxiter = 300, conv = 1e-4,
                      dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
                      yrankfix = NULL, lang = c('R', 'Rcpp')[1]){

  # X and Y are data.frames or matrices
  X <- as.data.frame(X)
  Y <- as.data.frame(Y)

  if(is.null(S.interval)) {
    S.interval <- range(X[, "TIME"])
  } else {
    filter_id <- X[, "TIME"] >= S.interval[1]
    filter_id <- X[filter_id, "TIME"] <= S.interval[2]
    X <- X[filter_id, ]
  }
  if(nrow(X) == 0) stop("S.interval is out of range of observed data points in X.")

  if(is.null(T.interval)) {
    T.interval <- range(Y[, "TIME"])
  } else {
    filter_id <- Y[, "TIME"] >= T.interval[1]
    filter_id <- Y[filter_id, "TIME"] <= T.interval[2]
    Y <- Y[filter_id, ]
  }
  if(nrow(Y) == 0) stop("T.interval is out of range of observed data points in Y.")

  nx <- length(unique(X[,"ID"]))
  p <- ncol(X) - 2
  ny <- length(unique(Y[,"ID"]))
  d <- ncol(Y) - 2
  if (nx != ny) stop("The same number of observations in predictor and response is required")
  n <- nx

  X.list <- split(X[, which(!colnames(X)%in%c("ID"))], X[, "ID"])
  Xint <- array(dim = c(n, p, jx), NA)
  for (i in 1:n){
    x <- X.list[[i]]
    sseq <- sort(unique(x[, "TIME"]))
    ns <- length(sseq)
    if (ns != dim(x)[1]) stop("repeated observations in X")
    x <- x[order(x[, "TIME"]), ]  # ns-by-p
    x <- as.matrix(x[, -which(colnames(x) == "TIME")])
    phi <- splines::bs(x = c(0, sseq), df = jx, degree = degree)[-1,]
    sdiff <- (sseq - c(0, sseq[-ns]))
    for (l in 1:p){
      for (j in 1:jx){
        Xint[i, l, j] <- sum(phi[, j] * x[ , l] * sdiff)
      }
    }
  }

  # compute Jpsi and Jpsi^{-1/2}
  tseq <- sort(unique(Y[, "TIME"]))
  nt <- length(tseq)
  psi <- splines::bs(x = c(0, tseq), df = jy, degree = degree)[-1,]
  Jpsi <- matrix(nrow = jy, ncol = jy, 0)
  tdiff <- (tseq - c(0, tseq[-nt]))
  for (t in 1:nt) Jpsi <- Jpsi + psi[t, ] %*% t(psi[t, ]) * tdiff[t]
  eJpsi <- eigen(Jpsi)
  Jpsihalf <- eJpsi$vectors %*% diag(sqrt(eJpsi$values)) %*% t(eJpsi$vectors)
  Jpsihalfinv <- eJpsi$vectors %*% diag(1 / sqrt(eJpsi$values)) %*% t(eJpsi$vectors)

  Y.list <- split(Y[, which(!colnames(Y)%in%c("ID"))], Y[, "ID"])
  Yint <- array(dim = c(n, d, jy), NA)
  for (i in 1:n){
    y <- Y.list[[i]]
    tseq <- sort(unique(y[, "TIME"]))
    nt <- length(tseq)
    if (nt != dim(y)[1]) stop("repeated observations in Y")
    y <- y[order(y[, "TIME"]), ]  # nt-by-d
    y <- as.matrix(y[, -which(colnames(y) == "TIME")])
    psi <- splines::bs(x = c(0, tseq), df = jy, degree = degree)[-1,]
    psistar <- psi %*% Jpsihalfinv
    tdiff <- (tseq - c(0,tseq[-nt]))
    for (l in 1:d){
      for (j in 1:jy){
        Yint[i, l, j] <- sum(psistar[, j] * y[ , l] * tdiff)
      }
    }
  }

  # obtain matrices Y and X in matrix approximation form
  Yest <- Yint[, , 1]
  for (j in 2:jy) Yest <- cbind(Yest, Yint[, , j])

  Xest <- Xint[, , 1]
  for (j in 2:jx) Xest <- cbind(Xest, Xint[, , j])

  if (tuning == 'CV') {
    fit.nrrr <- NRRR.cv(Yest, Xest, nfold, norder, Ag0 = NULL, Bg0 = NULL,
                        jx, jy, p, d, n, maxiter, conv, method, lambda,
                        dimred, rankfix, xrankfix, yrankfix, lang)
  } else {
    fit.nrrr <- NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
                        jx, jy, p, d, n, maxiter, conv,
                        method, lambda, ic = tuning,
                        dimred, rankfix, lang)
  }
  fit.nrrr$sseq <- sseq
  fit.nrrr$phi <- phi
  fit.nrrr$tseq <- tseq
  fit.nrrr$psi <- psi
  return(fit.nrrr)
}


spiral_matrix <- function(n) {
    spiralv <- function(v) {
        n <- sqrt(length(v))
        if (n != floor(n))
            stop("length of v should be a square of an integer")
        if (n == 0)
            stop("v should be of positive length")
        if (n == 1)
            m <- matrix(v, 1, 1)
        else
            m <- rbind(v[1:n], cbind(spiralv(v[(2 * n):(n^2)])[(n - 1):1, (n - 1):1], v[(n + 1):(2 * n - 1)]))
        m
    }
    spiralv(1:(n^2))
}


# Enter your code here. Read input from STDIN. Print output to STDOUT
val <- pnorm(9800, 205 * 49, sqrt( 49 * (15 ^ 2) ))
write(round(val, 4), stdout())


# 4. faza: Napredna analiza podatkov
library(ranger)
library(randomForest)

set.seed(123)

#KORELACIJA MED BDP PER CAPITA IN ŠTEVILOM VELEMOJSTROV
velemojstri_drzave <- velemojstri_drzave[complete.cases(velemojstri_drzave),]
bdp_gm <- ggplot(velemojstri_drzave, aes(x=`BDP_per_capita`, y=`Stevilo_velemojstrov`)) + geom_point()

linearna1 <- lm(data = velemojstri_drzave, velemojstri_drzave$BDP_per_capita ~ velemojstri_drzave$Stevilo_velemojstrov)

premica1 <- bdp_gm + geom_smooth(method = "lm", formula = y ~ x) +
  labs(y = "Velemojstri") +
  labs(x = "BDP per capita") +
  ggtitle("Korelacija med BDP per capita in velemojstri")

#KORELACIJA MED BDP PER CAPITA IN ŠTEVILOM VELEMOJSTROV PER CAPITA
bdp_gm_pc <- ggplot(velemojstri_drzave, aes(x=`BDP_per_capita`, y=`Velemojstri_per_capita`)) + geom_point()

linearna2 <- lm(data = velemojstri_drzave, velemojstri_drzave$BDP_per_capita ~ velemojstri_drzave$Velemojstri_per_capita)

premica2 <- bdp_gm_pc + geom_smooth(method = "lm", formula = y ~ x) +
  labs(y = "Velemojstri per capita") +
  labs(x = "BDP per capita") +
  ggtitle("Korelacija med BDP per capita in velemojstri per capita")

#REGRESIJA, NAPOVEDOVANJE

# Datume dam v numericno obliko kot stevilo dnevov od 1/1/1970
igre_magnus_otb_ratingi$Date.numeric = as.numeric(igre_magnus_otb_ratingi$Date)
#igre_magnus_otb_ratingi$ID <- seq.int(nrow(igre_magnus_otb_ratingi))

#4. stopnja, ker se najbolj prilega ratingu 1.2.2022
# prileganje <- lm(Rating_Magnusa ~ poly(Date.numeric,4), data=igre_magnus_otb_ratingi)
#napovedni_datumi <- data.frame(Date.numeric = as.numeric(as.Date(c("2022-02-01","2022-08-01","2023-02-01", "2023-08-01"))))
#
# prediction <- mutate(napovedni_datumi, Rating_Magnusa = predict(prileganje, napovedni_datumi,interval = "prediction"))
# prediction["Date"] <- as.Date(as.numeric(prediction$Date.numeric), origin = "1970-01-01")
# prediction <- prediction[,c(2,3,1)]
#
# graf_napovedi <- ggplot(igre_magnus_otb_ratingi, aes(x=Date, y=Rating_Magnusa)) + geom_point()
# graf_napovedi
#
# igre_magnus_otb_ratingi <- rbind(igre_magnus_otb_ratingi, prediction)
#
# regresija <- igre_magnus_otb_ratingi %>%ggplot(aes(x=Date,y=Rating_Magnusa))+
#   geom_smooth(method='lm', fullrange=TRUE, color='red', formula=y ~ poly(x,4,raw=TRUE)) +
#   geom_point()
#
#
# graf_napoved <- ggplot() +
#   geom_point(aes(x = Date,y = Rating_Magnusa),data=head(igre_magnus_otb_ratingi,-4),colour = '#3399ff', size=1) +
#   geom_point(aes(x = Date,y = Rating_Magnusa),data=tail(igre_magnus_otb_ratingi,4),colour = '#ff00ff', size=2) +
#   geom_smooth(data=head(igre_magnus_otb_ratingi,-3), aes(x = Date, y= Rating_Magnusa),method='lm', fullrange=TRUE, color='red', formula=y ~ poly(x,4,raw=TRUE)) +
#   xlab(label = 'Leto') +
#   ylab(label = 'Rating')

#regresija

#Primerjal napake različnih modelov, na koncu se odločil za naključne gozdove

# formule <- c(Rating_Magnusa ~ poly(Date.numeric,1),
#              Rating_Magnusa ~ poly(Date.numeric,2),
#              Rating_Magnusa ~ poly(Date.numeric,3),
#              Rating_Magnusa ~ poly(Date.numeric,4),
#              Rating_Magnusa ~ poly(Date.numeric,5),
#              Rating_Magnusa ~ poly(Date.numeric,6),
#              Rating_Magnusa ~ poly(Date.numeric,7),
#              Rating_Magnusa ~ poly(Date.numeric,8),
#              Rating_Magnusa ~ poly(Date.numeric,9),
#              Rating_Magnusa ~ poly(Date.numeric,10))

# napake <- rep(0, 15)
# for (i in 1:15){
#   formula <- Rating_Magnusa ~ poly(Date.numeric,i)
#   model <- igre_magnus_otb_ratingi %>% ucenje(formula, "lin.reg")
#   napaka <- napaka_regresije(igre_magnus_otb_ratingi, model, "lin.reg")
#   napake[i] <- napaka
# }
# which.min(napake)
# napake

#lin.model <- igre_magnus_otb_ratingi %>% ucenje(Rating_Magnusa ~ poly(Date.numeric,8), "lin.reg")
#lin.model
#print(igre_magnus_otb_ratingi %>% napaka_regresije(lin.model, "lin.reg"))
#pp.ratingi <- pp.razbitje(10, stratifikacija = igre_magnus_otb_ratingi)
#pp.ratingi <- razbitje(igre_magnus_otb_ratingi,10)

#print(precno.preverjanje(igre_magnus_otb_ratingi, pp.ratingi,Rating_Magnusa ~ poly(Date.numeric,11),"lin.reg", F))
#precno.preverjanje(igre_magnus_otb_ratingi, pp.ratingi,Rating_Magnusa ~ poly(Date.numeric,11),"lin.reg", F)

#ng.model <- igre_magnus_otb_ratingi %>% ucenje(Rating_Magnusa ~ Date.numeric, "ng")
#napaka.ng <- igre_magnus_otb_ratingi %>% napaka_regresije(ng.model, "ng")
#napaka.ng
#p1 = predict(ng.model, data = igre_magnus_otb_ratingi)
#head(p1)

#prediction <- mutate(napovedni_datumi, Rating_Magnusa = predict(ng.model, data=igre_magnus_otb_ratingi))

#
# pp <- pp.razbitje(igre_magnus_otb_ratingi)
# razbitje1 <- razbitje(igre_magnus_otb_ratingi[-2], 3)
# pp
# razbitje1
#print(precno.preverjanje(igre_magnus_otb_ratingi[-2], razbitje1,Rating_Magnusa ~ Date.numeric , "ng", FALSE))

ratingi <- igre_magnus_otb_ratingi[,1]
ratingi

Lag <- function(x, n) {c(rep(NA, n), x)[1:length(x)]
}

naredi.df <- function(x){
  data.frame(ratingi = x, ratingi1 = Lag(x,1), ratingi2 = Lag(x,2))
}
df.ng <- naredi.df(c(ratingi))
df.ng
model1 <- ranger(formula = ratingi ~ ., data = df.ng %>% drop_na())

n <- nrow(df.ng)
for(i in 1:12) {
  df.ng <- naredi.df(c(df.ng$ratingi, NA))
  napoved <- predict(model1, data = df.ng[n+i,])$predictions
  df.ng[n+i,1] <- napoved
}

napovedi <- df.ng[(n+1):(n+12),1] %>% round()

napovedi
napovedni_meseci <- c(as.Date(c("2022-02-01","2022-04-01","2022-06-01", "2022-08-01",
                                "2022-10-01","2022-12-01","2023-02-01", "2023-04-01",
                                "2023-06-01","2023-08-01","2023-10-01", "2023-12-01")))
ratingi <- c(ratingi, napovedi)
napovedi.df <- data.frame(Rating_Magnusa = napovedi, Date = napovedni_meseci, Date.numeric = as.numeric(napovedni_meseci))
igre_magnus_otb_ratingi <- rbind(igre_magnus_otb_ratingi, napovedi.df)

graf_napoved <- ggplot() +
  geom_point(aes(x = Date,y = Rating_Magnusa),data=head(igre_magnus_otb_ratingi,-12),colour = '#3399ff', size=0.8) +
  geom_point(aes(x = Date,y = Rating_Magnusa),data=tail(igre_magnus_otb_ratingi,12),colour = '#ff00ff', size=0.8) +
  xlab(label = 'Leto') +
  ylab(label = 'Rating')

graf_napoved

ratingi

#Razvrščanje v skupine
set.seed(50)
velemojstri_drzave$Stevilo_velemojstrov <- as.numeric(velemojstri_drzave$Stevilo_velemojstrov)
velemojstri_drzave$Populacija <- as.numeric(velemojstri_drzave$Populacija)
velemojstri_drzave$Velemojstri_per_capita <- as.numeric(velemojstri_drzave$Velemojstri_per_capita)
velemojstri_drzave$BDP_per_capita <- as.numeric(velemojstri_drzave$BDP_per_capita)
velemojstri_drzave_skupine <- scale(velemojstri_drzave[,-1])
velemojstri_drzave[,-1] <- velemojstri_drzave_skupine
velemojstri_drzave <- na.omit(velemojstri_drzave)

skupine <- velemojstri_drzave[,-1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()
#print(skupine)

velemojstri_drzave["Skupina"] <- skupine
#velemojstri_drzave[,2:5] <- NULL
velemojstri_drzave_zemljevid <- left_join(velemojstri_drzave_zemljevid, velemojstri_drzave, by="Drzava")

zemljevid4 <- tm_shape(velemojstri_drzave_zemljevid) +
  tm_fill("Skupina", title = "Razvrstitev glede na BDP, število velemojstrov in številu prebivalcev",
          popup.vars = c("Skupina" = "Skupina")) +
  tm_borders() +
  tm_view(view.legend.position = c("right", "bottom"))
zemljevid4

#Preveril optimalno število skupin
r.hc = velemojstri_drzave[, -1] %>% obrisi(hc = TRUE)
r.km = velemojstri_drzave[, -1] %>% obrisi(hc = FALSE)
diagram.obrisi(r.hc)
diagram.obrisi(r.km)
#Diagrama pokažeta, da sta optimalni števili 3 in 5, odločil sem se za 3, saj v primeru 5ih se pri prvem diagramu močno spustimo

#ggpairs(igre_magnus_otb_ratingi)

#datumi <- as.data.frame(as.Date(prediction$Date.numeric, "1970-01-01"))


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
setwd("your/working/directory/goes/here")
# Download the NBER-CES data and save it to a working directory
# Then, read in the CSV file
mfgdata <- read.csv("naics5811.csv")

# Convert columns which should be categorical variables from text
# Also pull out NAICS sectors
mfgdata$naicsind <- as.factor(mfgdata$naics)
mfgdata$naicssector <- as.factor(substr(mfgdata$naics, 1, 2))
mfgdata$yearfactor <- as.factor(mfgdata$year)

# Initialize percentage changes for value-added and investment
# Then, go through all the industries and calculate the log-return
# (percentage change) for each industry's value-added and investment.
# Also save last period's (lagged) percentage change in value-added.
mfgdata$varet <- 0
mfgdata$invret <- 0
for (ind in levels(mfgdata$naicsind)) {
    temp <- mfgdata[mfgdata$naicsind == ind,]
    nobs <- dim(temp)[1]
    # add one into logs to guard against zeros
    varet <- c(NA, log(temp$vadd[2:nobs]+1) - log(temp$vadd[1:(nobs-1)])+1)
    invret <- c(NA, log(temp$invest[2:nobs]+1) - log(temp$invest[1:(nobs-1)])+1)
    mfgdata[mfgdata$naicsind == ind,"varet"] <- varet
    mfgdata[mfgdata$naicsind == ind,"lagvaret"] <- c(NA, varet[1:(nobs-1)])
    mfgdata[mfgdata$naicsind == ind,"invret"] <- invret
}

# Some data may have been missing. Build indices to remove
# missing data for procedures which do not handle it.
usable.idx <- !is.na(mfgdata$invret)
usablear.idx <- !is.na(mfgdata$laginvret)

# Fit the model, summarize the data, and plot residuals
simple.model <- lm(invret ~ varet, data=mfgdata, weight=cap)
summary(simple.model)
plot(mfgdata$year[usable.idx], residuals(simple.model), pch=".")
grid(col="gray")

# Do likewise for the year-slope model
yearslope.model <- lm(invret ~ varet + varet:yearfactor,
                      weight=cap, data=mfgdata)
summary(yearslope.model)
plot(mfgdata$year[usable.idx], residuals(yearslope.model), pch=".")
grid(col="gray")

# And do this again for a model with a lagged value-added component
yearslopear.model <- lm(invret ~ varet + lagvaret + varet:yearfactor,
                        data=mfgdata, weight=cap)
summary(yearslopear.model)
plot(mfgdata$year[usablear.idx], residuals(yearslopear.model), pch=".")
grid(col="gray")