# ......................................................................................
# .............. Cvičení 10. Úvod do testování hypotéz, jednovýběrové testy.............
# ......................... Michal Béreš, Martina Litschmannová.........................
# ......................................................................................

# 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

#  Od intervalových odhadů k testům hypotéz ####
# * Co je to statistický test hypotéz? ####
# Mějme následující:
# - náhodná veličina X (například výška mužů)
# - výběr z náhodné veličiny (měření výšky 30 mužů)
#
# Statistické testování hypotéz rozhoduje na základě získaných dat z náhodného výběru o
# platnosti:
# - $H_0$ - nulové hypotézy
# - $H_A$ - alternativní hypotézy
#
# Například:
# $H_0$: $\mu_X = 175$
# $H_A$: $\mu_X > 175$
# Jelikož se jedná o statistické rozhodnutí, vždy bude vázáno k nějaké hladnině
# významnosti $\alpha$. Vždy můžeme dospět pouze k 2 různým rozhodnutím:
# - Zamítám $H_0$ ve prospěch $H_A$
#     - to znamená, že tvrdím, že $H_0$ neplatí
#     - toto rozhodnutí je s maximální chybou $\alpha$ (hladina významnosti, chyba I.
# druhu) - to znamená, že velikost této chyby jsme schopni ovlivnit
# - Nezamítám $H_0$
#     - to znamená, že tvrdím, že vzhledem k získaným datům (výběr) nelze vyvrátit $H_0$
#     - toto rozhodnutí je s chybou $\beta$ (chyba II. druhu), tato chyba není přímo
# ovlivnitelná a záleží na typu použitého testu
#
# Jak testy hypotéz souvisí s intervalovými odhady a jak do nich vstupuje hladina
# významnosti si ukážeme v další části.

# * Intervalový odhad a hladina významnosti ####

data = readxl::read_excel("D:/_VSB/S8/PS/Beres/GitPS/CV10/data/uvod.xlsx")
head(data)

options(repr.plot.width = 12) # šířka grafů v Jupyteru
par(mfrow = c(1, 2))          # matice grafů 1x2

boxplot(data$data)
hist(data$data)

moments::skewness(data$data)       # šikmost
moments::kurtosis(data$data) - 3   # špičatost

shapiro.test(data$data)$p.value    # test normality

length(data$data)
mean(data$data)
sd(data$data)

# Vyrobíme 95% intervalový odhad střední hodnoty pomocí t-testu:

t.test(data$data, alternative = "two.sided", conf.level = 0.95)$conf.int

# Představme si nyní, že chceme testovat hypotézu:
# $H_0$: $\mu = 100$
# $H_A$: $\mu \neq 100$
# Jaké by bylo rozhodnutí vzhledem k spočtenému IO a tedy hladině významnosti $\alpha =
# 0.05$?

# Představme si dále, že chceme testovat hypotézu:
# $H_0$: $\mu = 105$
# $H_A$: $\mu \neq 105$
# Jaké by bylo rozhodnutí vzhledem k spočtenému IO a tedy hladině významnosti $\alpha =
# 0.05$?

# **To co jsme právě udělali se nazývá klasický test.**
# Ukážeme si ještě klasické testy pro jednostranné alternativy.
# $H_0$: $\mu = 105$
# $H_A$: $\mu > 105$

t.test(data$data, alternative = "greater", conf.level = 0.95)$conf.int

# $H_0$: $\mu = 105$
# $H_A$: $\mu < 105$

t.test(data$data, alternative = "less", conf.level = 0.95)$conf.int

# Všimněte si, že první z těchto jednostranných alternativ vedla k "nezamítnutí" $H_0$.
# Je to z důvodu porovnávání nepravděpodobné $H_0$ s ještě méně pravděpodobnou $H_A$.
# *** Čistý test významnosti a souvislost s IO ####
# Alternativou ke klasickému testu (kde vytváříme IO - v terminologii klasických testů
# tzv. obor přijetí a jeho doplněk do R kritický obor) je tzv. čistý test významnosti:

# H_0: mu = 105
# H_A: mu <> 105
t.test(data$data, mu = 105, alternative = "two.sided")

t.test(data$data, mu = 105, alternative = "two.sided")$p.value

# Výsledkem čistého testu významnosti je p-hodnota. Na jejím základě rozhodujeme o
# zamítnutí či nezamítnutí $H_0$.
# p-hodnota se dá chápat jako nejvyšší možná hladina váznamnosti, taková aby naše
# rozhodnutí bylo - nezamítám. Tedy IO/obor přijetí by obsahoval zkoumanou hodnotu:

# H_0: mu = 105
# H_A: mu <> 105

p.hod = t.test(data$data, mu = 105, alternative = "two.sided")$p.value
p.hod

t.test(data$data, alternative = "two.sided", conf.level = 1 - p.hod)$conf.int

# H_0: mu = 105
# H_A: mu > 105

p.hod = t.test(data$data, mu = 105, alternative = "greater")$p.value
p.hod

t.test(data$data, alternative = "greater", conf.level = 1 - p.hod)$conf.int

# H_0: mu = 105
# H_A: mu < 105

p.hod = t.test(data$data, mu = 105, alternative = "less")$p.value
p.hod

t.test(data$data, alternative = "less", conf.level = 1 - p.hod)$conf.int

# * Přehled testů ####
# ** Míry polohy ####
# Mírami polohy rozumíme údaj určující polohu dat, nehledě na tom jak jsou rozptýlená.
# Pro data z normálního rozdělení můžeme odhadovat střední hodnotu, pro ostatní medián.
# *** a) studentův t-test ####
# - testujeme střední hodnotu
# - data musejí pocházet z normálního rozdělení
#     - exploračně: šikmost a špičatost leží v (-2,2)
#     - exploračně: QQ graf má body přibližně na čáře
#     - exaktně: pomocí statistického testu, např. Shapiro-Wilk test
# (shapiro.test(data))

# H_0: mu = 100
# H_A: mu <> 100
t.test(data$data, mu = 100, alternative = 'two.sided')$p.value

# H_0: mu = 100
# H_A: mu > 100
t.test(data$data, mu = 100, alternative = 'greater')$p.value

# H_0: mu = 100
# H_A: mu < 100
t.test(data$data, mu = 100, alternative = 'less')$p.value

# *** b) Wilcoxnův test ####
# - testujeme medián
# - data musejí pocházet ze symetrického rozdělení
#     - exploračně: šikmost leží v (-2,2)
#     - exploračně: histogram vypadá přibližně symetricky
#     - exaktně: pomocí statistického testu, např. balíček "lawstat", funkce
# "symmetry.test(data,boot=FALSE)"

# H_0: X_0.5 = 100
# H_A: X_0.5 <> 100
wilcox.test(data$data, mu = 100, alternative = 'two.sided')$p.value

# H_0: X_0.5 = 100
# H_A: X_0.5 > 100
wilcox.test(data$data, mu = 100, alternative = 'greater')$p.value

# H_0: X_0.5 = 100
# H_A: X_0.5 < 100
wilcox.test(data$data, mu = 100, alternative = 'less')$p.value

# *** c) znaménkový test test ####
# - testujeme medián
# - výběr většího rozsahu (>10)
# - vyžaduje knihovnu "BSDA"
# - jakožto nejrobustnější test, se dá použít i na nespojitá data - např. pořadí v
# nějakém seznamu

# H_0: X_0.5 = 100
# H_A: X_0.5 <> 100
BSDA::SIGN.test(data$data, md = 100, alternative = 'two.sided')$p.value

# H_0: X_0.5 = 100
# H_A: X_0.5 > 100
BSDA::SIGN.test(data$data, md = 100, alternative = 'greater')$p.value

# H_0: X_0.5 = 100
# H_A: X_0.5 < 100
BSDA::SIGN.test(data$data, md = 100, alternative = 'less')$p.value

# ** Míry variability ####
# Mírami variability rozumíme údaj určující rozptýlenost/variabilitu dat, nehledě na
# celkových hodnotách. Pro data z normálního rozdělení můžeme odhadovat směrodatnou
# odchylku.
# *** test směrodatné odchylky ####
# - testujeme směrodatnou odchylku
# - data musejí pocházet z normálního rozdělení
#     - exploračně: šikmost a špičatost leží v (-2,2)
#     - exploračně: QQ graf má body přibližně na čáře
#     - exaktně: pomocí statistického testu, např. Shapiro-Wilk test
# (shapiro.test(data))
# - vyžaduje balíček "EnvStats"
# - funkce v Rku, porovnává rozptyl!!!

# H_0: sigma = 10
# H_A: sigma <> 10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'two.sided')$p.value

# H_0: sigma = 10
# H_A: sigma > 10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'greater')$p.value

# H_0: sigma = 10
# H_A: sigma < 10
EnvStats::varTest(data$data, sigma.squared = 10*10,
                  alternative = 'less')$p.value

# * Pravděpodobnost výskytu u jednoho výběru ####
# *** IO pravděpodobnosti ####
# - testujeme pravděpodobnost
# - vyžadujeme dostatečný počet dat: $n>\frac{9}{p(1-p)}$
# - Clopperův - Pearsonův odhad (binom.test)
#     - jako parametr nebere data, ale počet úspěchů a počet pozorování

pi = 0.3
data_bin = runif(n = 100, min = 0, max = 1) < pi

n = length(data_bin)
x = sum(data_bin)
n
x

# H_0: pi = 0.2
# H_A: pi <> 0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'two.sided')$p.value

# H_0: pi = 0.2
# H_A: pi > 0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'greater')$p.value

# H_0: pi = 0.2
# H_A: pi < 0.2
binom.test(x = x, n = n, p = 0.2, alternative = 'less')$p.value

#  Příklady ####
# * Příklad 1. ####
# Máme výběr 216 pacientů a změřili jsme jejich bílkovinné sérum (soubor
# testy_jednovyberove.xlsx list bilk_serum). Ověřte, zda se průměrné bílkovinné sérum
# (Albumin) všech pacientů tohoto typu (populační průměr µ) statisticky významně liší od
# hodnoty 35 g/l.

# Načtení dat z xlsx souboru (pomoci balíčku readxl)
albumin = readxl::read_excel("D:/_VSB/S8/PS/Beres/GitPS/CV10/data/testy_jednovyberove.xlsx",
                             sheet = "bilk_serum")
head(albumin)

colnames(albumin)="hodnoty"

# Explorační analýza
boxplot(albumin$hodnoty)
summary(albumin$hodnoty)

length(albumin$hodnoty) # sd zaokrouhlujeme na 3 platné cifry
sd(albumin$hodnoty)     # sd a míry polohy zaokrouhlujeme na tisíciny

# **Test na míru polohy**

# Ověření normality - exploračně
moments::skewness(albumin$hodnoty)    # šikmost
moments::kurtosis(albumin$hodnoty)-3  # špičatost

options(repr.plot.width = 12) # šířka grafů v Jupyteru
par(mfrow = c(1, 2))          # matice grafů 1x2

qqnorm(albumin$hodnoty)
qqline(albumin$hodnoty)
hist(albumin$hodnoty)

# Pro konečné rozhodnutí o normalitě dat použijeme test normality.

# Předpoklad normality ověříme Shapirovovým - Wilkovovým testem.
# H0: Data jsou výběrem z normálního rozdělení.
# Ha: Data nejsou výběrem z normálního rozdělení.
shapiro.test(albumin$hodnoty)
# p-value > 0.05 -> Na hl. významnosti 0,05 nelze předpoklad normality zamít.

# normalita OK -> t.test

# H0: mu = 35 g/l
# Ha: mu <> 35 g/l

t.test(albumin$hodnoty, mu=35, alternative = "two.sided")

# p-value < 0.05 -> Na hl. významnosti 0,05 zamítáme nulovou hypotézu
# ve prospěch hypotézy alternativní
# Střední hodnota albuminu se statisticky významně liší od 35 g/l.

# * Příklad 2. ####
# V souboru testy_jednovyberove.xlsx list preziti jsou uvedeny doby přežití pro 100
# pacientů s rakovinou plic léčených novým lékem. Z předchozích studií je známo, že
# průměrné přežití takových pacientů bez podávání nového léku je 22,2 měsíce. Lze na
# základě těchto dat usoudit, že nový lék prodlužuje přežití?

# Načtení dat z xlsx souboru (pomoci balíčku readxl)
preziti = readxl::read_excel("D:/_VSB/S8/PS/Beres/GitPS/CV10/data/testy_jednovyberove.xlsx",
                             sheet = "preziti")
head(preziti)

colnames(preziti)="hodnoty"

## Explorační analýza
par(mfrow = c(1, 2))          # matice grafů 1x2

boxplot(preziti$hodnoty)
hist(preziti$hodnoty)

# **Data obsahují OP -> můžeme je odstranit. Nebo si také všimnout, že se pravděpdobně
# jedná o exponenciální rozdělení a OP tam ve skutečnosti nejsou (rozdělení se tak
# prostě chová).**

# Data obsahují odlehlá pozorování. Pomoci f-ce boxplot je umíme vypsat.
pom=boxplot(preziti$hodnoty, plot = FALSE)
pom$out
# rozhodli-li jsme se pro odstranění odlehlých hodnot, pak
preziti$hodnoty.bez=preziti$hodnoty # doporučujeme nepřepisovat původní data
preziti$hodnoty.bez[preziti$hodnoty %in% pom$out]=NA

## Explorační analýza pro data bez odlehlých pozorování
boxplot(preziti$hodnoty.bez)
summary(preziti$hodnoty.bez,na.rm=TRUE)

length(na.omit(preziti$hodnoty.bez))   # sd zaokrouhlujeme na 3 platné cifry
sd(preziti$hodnoty.bez,na.rm=TRUE)     # sd a míry polohy zaokr. na desetiny

# **Test o míře polohy (střední hodnotě / mediánu)**

# Ověření normality - exploračně
moments::skewness(preziti$hodnoty.bez,na.rm=TRUE)
moments::kurtosis(preziti$hodnoty.bez,na.rm=TRUE)-3

par(mfrow = c(1, 2))          # matice grafů 1x2

qqnorm(preziti$hodnoty.bez)
qqline(preziti$hodnoty.bez)
hist(preziti$hodnoty.bez)

# QQ - graf i hist. ukazují, že výběr pravd. není výběrem z norm. rozdělení.
# Šikmost i špičatost odpovídá norm. rozdělení.
# použijeme test normality.

# Předpoklad normality ověříme Shapirovovým . Wilkovovým testem.
shapiro.test(preziti$hodnoty.bez)
# p-value < 0.05 -> Na hl. významnosti 0.05 zamítáme předpoklad normality

# explorační posouzení symetrie - výše hist. a šikmost

# Předpoklad symetrie - ověření testem
# H0: data pocházejí ze symetrického rozdělení
# HA: ~H0

lawstat::symmetry.test(preziti$hodnoty.bez,boot=FALSE)
# p-value < 0.05 -> Na hl. významnosti 0.05 zamítáme předpoklad symetrie

# normalita zamítnuta -> symetrie zamítnuta -> Sign. test
# H0: median = 22,2 měsíců
# Ha: median > 22,2 měsíců

BSDA::SIGN.test(preziti$hodnoty.bez, md=22.2,
                alternative="greater", conf.level=0.95)

# p-value > 0.05 -> Na hl. významnosti 0,05 nelze zamítnout nulovou hypotézu
# Medián doby přežití není statisticky významně větší než 22,2 měsíců.

median(preziti$hodnoty.bez, na.rm = TRUE)

# H0: median = 22,2 měsíců
# Ha: median < 22,2 měsíců

BSDA::SIGN.test(preziti$hodnoty.bez, md=22.2,
                alternative="less", conf.level=0.95)

# * Příklad 3. ####
# Automat vyrábí pístové kroužky o daném průměru. Výrobce udává, že směrodatná odchylka
# průměru kroužku je 0,05 mm. K ověření této informace bylo náhodně vybráno 80 kroužků a
# vypočtena směrodatná odchylka jejich průměru 0,04 mm. Lze tento rozdíl považovat za
# statisticky významný ve smyslu zlepšení kvality produkce? Ověřte čistým testem
# významnosti. Předpokládejte, že průměr pístových kroužků má normální rozdělení.

# Test o směrodatné odchylce

# Předpokládáme normalitu dat (dle zadání)
n = 80   # rozsah souboru
s = 0.04 # mm .... výběrová směrodatná odchylka (bodový odhad sm. odchylky)

# H0: sigma = 0.05 mm
# Ha: sigma < 0.05 mm

x.obs = (n-1)*s^2/0.05^2
x.obs

p.hodnota = pchisq(x.obs,n-1)
p.hodnota

# p.hodnota < 0.05 -> Na hladině významnosti 0,05 zamítáme nulovou hypotézu
# ve prospěch alternativní hypotézy
# Směr. odchylka průměru kroužku je statisticky významně menší než 0,05 mm.

# * Příklad 4. ####
# Automat vyrábí pístové kroužky o daném průměru. Výrobce udává, že směrodatná odchylka
# průměru kroužku je 0,05 mm. K ověření této informace bylo náhodně vybráno 80 kroužků a
# byl změřen jejich průměr (soubor testy_jednovyberove.xlsx list krouzky). Lze zjištěné
# výsledky považovat za statisticky významné ve smyslu zlepšení kvality produkce? Ověřte
# čistým testem významnosti.

# Načtení dat z xlsx souboru (pomoci balíčku readxl)
krouzky = readxl::read_excel("D:/_VSB/S8/PS/Beres/GitPS/CV10/data/testy_jednovyberove.xlsx",
                             sheet = "krouzky")
head(krouzky)

colnames(krouzky)="hodnoty"

## Explorační analýza
boxplot(krouzky$hodnoty)

# Data obsahují odlehlá pozorování. Pomoci f-ce boxplot je umíme vypsat.
pom = boxplot(krouzky$hodnoty, plot = FALSE)
pom$out
# rozhodli-li jsme se pro odstranění odlehlých hodnot, pak
krouzky$hodnoty.bez = krouzky$hodnoty
krouzky$hodnoty.bez[krouzky$hodnoty %in% pom$out] = NA

# Explorační analýza pro data bez odlehlých pozorování
summary(krouzky$hodnoty.bez,na.rm=TRUE)
boxplot(krouzky$hodnoty.bez)

length(na.omit(krouzky$hodnoty.bez))# sd zaokrouhlujeme na 3 platné cifry
sd(krouzky$hodnoty.bez,na.rm=TRUE)  # sd a míry polohy zaokr. na tisíciny

# Ověření normality - exploračně
moments::skewness(krouzky$hodnoty.bez,na.rm=TRUE)
moments::kurtosis(krouzky$hodnoty.bez,na.rm=TRUE)-3

par(mfrow = c(1, 2))          # matice grafů 1x2

qqnorm(krouzky$hodnoty.bez)
qqline(krouzky$hodnoty.bez)
hist(krouzky$hodnoty.bez)
# Šikmost i špičatost odpovídá norm. rozdělení.
# Pro konečné rozhodnutí o normalitě dat použijeme

# test normality.
# Předpoklad normality ověříme Shapirovovým . Wilkovovým testem.
shapiro.test(krouzky$hodnoty.bez)
# p-value > 0.05 -> Na hl. významnosti 0,05 nelze předpoklad norm. zamítnout

# test na míru variability -> test o rozptylu

# H0: sigma = 0,05 mm
# Ha: sigma < 0,05 mm
EnvStats::varTest(krouzky$hodnoty.bez, sigma.squared = 0.05^2,
                  alternative = "less")

# p-value < 0.05 -> Na hladině významnosti 0,05 zamítáme H0 ve prospěch Ha

# Jak najít 95% intervalový odhad směrodatné odchylky?
pom = EnvStats::varTest(krouzky$hodnoty.bez, sigma.squared = 0.05^2,
                        alternative = "less", conf.level=0.95)

sqrt(pom$conf.int)

# * Příklad 5. ####
# Firma TT udává, že 1% jejich rezistorů nesplňuje požadovaná kritéria. V testované
# dodávce 1000 ks bylo nalezeno 15 nevyhovujících rezistorů. Potvrzuje tento výsledek
# tvrzení TT? Ověřte čistým testem významnosti.

n = 1000   # rozsah výběru
x = 15     # počet "úspěchů"
p = x/n    # relativní četnost (bodový odhad pravděpodobnosti)
p

# Ověření předpokladů
9/(p*(1-p))
# Dále předpokládáme  n/N < 0.05, tj. že daná populace (rezistorů) má rozsah
# alespoň 1000/0.05 = 1000*20 = 20 000 rezistorů

## Clopperův - Pearsonův (exaktní) test
## H0: pi = 0.01
## Ha: pi <> 0.01

binom.test(x = x, n= n, p = 0.01, alternative="two.sided")

## Clopperův - Pearsonův (exaktní) test
## H0: pi = 0.01
## Ha: pi > 0.01

binom.test(x = x, n= n, p = 0.01, alternative="greater")

# Na hladině významnosti 0,05 nezamítáme H0
# Nelze očekávat, že podíl vadných rezistorů ve výrobě statisticky významně
# převyšuje 1 %.


#' Negative log likelihood function
#'
#' We're maximizing the likelihood function, so minimizing the negative log
#' likelihood (which is the default in optim)
#'
#' @param par  numeric vector of coefficients in ’x’ and theta
#' @param .x  design matrix of dimension ‘n * p’
#' @param .y  vector of observations of length ‘n’
#' @param weights  vector of weights of length ‘n’
#' @param offset  vector of coefficient offsets of length ‘n’
#' @param verbose  print debug messages
#' @return  negative log-likelihood of a set of paramters given the data
nll = function(par, .x, .y, weights=rep(1, nrow(.x)), offset=rep(0, nrow(.x)),
               .verbose=FALSE) {
    beta = par[-length(par)]
    theta = exp(par[length(par)])
    mu = .x %*% beta + offset

    if (.verbose)
        message(paste(sprintf("%.2f", par), collapse=", "))

    nb = suppressWarnings(stats::dnbinom(.y, mu=mu, size=theta, log=TRUE))
    nb[is.infinite(nb)] = sign(nb[is.infinite(nb)]) * 1000
    nb[is.na(nb)] = -mu[is.na(nb)] # penalize mu < 0
    -sum(weights * nb)
}


#CustomMath.r
#A collection of relatively basic functions.

MeanNA <- function(Vec) {
  #Replaces NA instances with their mean instead
  m <- mean(Vec, na.rm = TRUE)
  Vec[is.na(Vec)] <- m
  return(Vec)
}

GetWeight <- function(Vec,AddMean=FALSE) {
  #Takes a Vector, absolute value, then proportional linear deviance from 0.
  new <- abs(Vec)
  if(AddMean==1) new  <- new + mean(new)
  if(sum(new)==0) new <- new + 1
  new <- new/sum(new)
  return(new)
}

Catch <- function(X,Tolerance=0) {
  #x is the ConoutRAW numeric, Tolerance is the length of the midpoint corresponding to .5
  #The purpose here is to handle rounding for binary contracts
  if(X<(.5-(Tolerance/2))) return(0)
  else if(X>(.5+(Tolerance/2))) return(1)
  else return(.5)
}

Influence  <- function(Weight) {
  #Takes a normalized Vector (one that sums to 1), and computes relative strength of the indicators.
  #this is because by-default the conformity of each Author and Judge is expressed relatively.
  Expected <- rep(1/length(Weight),length(Weight))
  return( Weight / Expected)
}

ReWeight <- function(Vec,exclude=is.na(Vec)) {
  #Get the relative influence of numbers, treat NA as influence-less
  out <- Vec
  out[exclude] <- 0
  out <- out/sum(out)
  return(out)
}

ReverseMatrix <- function(Mat) {
  #Inverts a binary matrix
  return((Mat-1)*-1)
}

WeightedPrinComp <- function(X,Weights=ReWeight(rep(1,nrow(M))) ) {
  #Manually computes the statistical procedure known as Principal Components Analysis (PCA)
  #This version of the procedure is so basic, that it can also be thought of as merely a singular-value decomposition on a weighted covariance matrix.

  wCVM <- cov.wt(x=X,wt=Weights)

  L <- svd(wCVM$cov)$u[,1]
  S <- as.vector(scale(X,center=wCVM$center,scale= FALSE) %*% L)

  Out <- list("Scores"=S,"Loadings"=L)
  return(Out)
}


#### 일원 분산분석(One-way ANOVA) #####

# 01.데이터 불러오기
owa.df <- read.csv("Ch0903.교육역량분석.csv",
                   header=TRUE,
                   na.strings = ".")

owa.df$학년 <- factor(owa.df$학년,
                       levels = c(1:4),
                       labels = c("1학년","2학년","3학년","4학년"))

str(owa.df)
head(owa.df)

# 02.기본통계치 확인
library(psych)
describeBy(owa.df$비교과운영,
           owa.df$학년,
           mat=T) # 합쳐서 하나의 표로 보여줄지, 따로 그룹별로 보여줄지 나타내는 옵션

# 03.그래프 그리기(박스그래프,히스토그램)
# install.packages("ggplot2")

library(ggplot2)

ggplot(owa.df, aes(x = 학년, y = 비교과운영)) + #aes 축
  geom_boxplot(outlier.colour="red") + #이상치를 레드로 하라
  ggtitle("학년별 점수 차이") +
  theme_classic() + # ggplot2 테마
  theme(title = element_text(color="darkblue", size=20))

# facet_grid(); 그룹으로 구분- 범주형 변수
# facet_grid(.~); 수직
# facet_grid(~.); 가로

ggplot(owa.df, aes(x=비교과운영)) +
  geom_histogram(binwidth=10) +
  facet_grid(.~ 학년) +
  ggtitle("매장별 만족도") +
  theme_classic()

# 04.통계분석
# 등분산 검증
# 이분산일때는 하단의 부록(Welch's ANOVA test) 참조
bartlett.test(비교과운영 ~ 학년, data=owa.df)

# barlett test는 정규분포에 민감하기 때문에 leveneTest 많이 사용
# install.packages("car")
library(car)
car::leveneTest(비교과운영 ~ 학년, data=owa.df) # 레벤의 검증은 library(car)에 있다.

# 등분산일때 ANOVA분석
owa.result <- aov(비교과운영 ~ 학년, data=owa.df)

owa.result

summary(owa.result)

# 부록: 이분산일때 Welch's ANOVA test
oneway.test(owa.df$비교과운영 ~ owa.df$학년, data=owa.df,
            var.equal = FALSE)

# 사후검정(Multicamparison test )
# Fisher LSD
pairwise.t.test(owa.df$비교과운영,
                owa.df$학년,
                data=owa.df,
                p.adj="non") # 많이 않쓰임. 오차가 크기 때문에

# Bonferroni, Tukey HSD, Duncan LSR
pairwise.t.test(owa.df$비교과운영,
                owa.df$학년,
                data=owa.df,
                p.adj="bonf") # 여기서비교하는 방법을 알려줌. 이것은 유의확률을 보여줌. 강남-강동 차이 있음

# Tukey HSD, Duncan LSR
TukeyHSD(owa.result) # 결과값으로 바로 보여줌 (분산분석 결과치를 데이타프레임으로 저장하고 입력)

# 학년으로 표현
# install.packages("agricolae")
library(agricolae)

# console=TRUE: 결과를 화면에 표시
# 학년=TRUE: 그룹으로 묶어서 표시, FALSE: 1:1로 비교하여 다 보여줌, 다른 것끼리 구분되는 것
LSD.test(owa.result,
         "학년",
         console = T,
         p.adj="bonf")
duncan.test(owa.result,
            "학년",
            group=T,
            console = T)
scheffe.test(owa.result,
             "학년",
             group=T,
             console = T)

# 05.통계결과 그래프
tukeyPlot <- TukeyHSD(owa.result) # 그룹간 차이 비교
plot(tukeyPlot) # 0을 거치고 있다는 것은 차이가 없다는 뜻임

# 부록: 비모수통계분석 Kruskal Wallis H test
kruskal.test(owa.df$비교과운영 ~ owa.df$학년,
             data=owa.df)
# install.packages("userfriendlyscience")
library(userfriendlyscience)
posthocTGH(owa.df$비교과운영,
           owa.df$학년)

# install.packages("nparcomp")  # 비모수 검정에서 다중 비교 방식
library(nparcomp)
result = mctp(owa.df$비교과운영 ~ owa.df$학년,
              data=owa.df)
summary(result)


#' High-Dimensional Regularized Discriminant Analysis (HDRDA)
#'
#' Given a set of training data, this function builds the HDRDA classifier from
#' Ramey, Stein, and Young (2017). Specially designed for small-sample,
#' high-dimensional data, the HDRDA classifier incorporates dimension reduction
#' and covariance-matrix shrinkage to enable a computationally efficient
#' classifier.
#'
#' The HDRDA classifier utilizes a covariance-matrix estimator that is a convex
#' combination of the covariance-matrix estimators used in the Linear
#' Discriminant Analysis (LDA) and Quadratic Discriminant Analysis (QDA)
#' classifiers. For each of the `K` classes given in `y`,
#' \eqn{(k = 1, \ldots, K)}, we first define this convex combination as
#' \deqn{\hat{\Sigma}_k(\lambda) = (1 - \lambda) \hat{\Sigma}_k
#' + \lambda \hat{\Sigma},}
#' where \eqn{\lambda \in [0, 1]} is the _pooling_ parameter. We then
#' calculate the covariance-matrix estimator
#' \deqn{\tilde{\Sigma}_k = \alpha_k \hat{\Sigma}_k(\lambda) + \gamma I_p,}
#' where \eqn{I_p} is the \eqn{p \times p} identity matrix. The matrix
#' \eqn{\tilde{\Sigma}_k} is substituted into the HDRDA classifier. See Ramey et
#' al. (2017) for more details.
#'
#' The matrix of training observations are given in `x`. The rows of
#' `x` contain the sample observations, and the columns contain the features
#' for each training observation. The vector of class labels given in `y`
#' are coerced to a `factor`. The length of `y` should match the number
#' of rows in `x`.
#'
#' The vector `prior` contains the _a priori_ class membership for
#' each class. If `prior` is `NULL` (default), the class membership
#' probabilities are estimated as the sample proportion of observations
#' belonging to each class. Otherwise, `prior` should be a vector with the
#' same length as the number of classes in `y`. The `prior`
#' probabilities should be nonnegative and sum to one. The order of the prior
#' probabilities is assumed to match the levels of `factor(y)`.
#'
#' @export
#' @references Ramey, J. A., Stein, C. K., and Young, D. M. (2017),
#' "High-Dimensional Regularized Discriminant Analysis."
#' \url{https://arxiv.org/abs/1602.01182}.
#' @references Friedman, J. H. (1989), "Regularized Discriminant Analysis,"
#' Journal of American Statistical Association, 84, 405, 165-175.
#' \url{http://www.jstor.org/pss/2289860} (Requires full-text access).
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param lambda the HDRDA pooling parameter. Must be between 0 and 1,
#' inclusively.
#' @param gamma a numeric values used for the shrinkage parameter.
#' @param shrinkage_type the type of covariance-matrix shrinkage to apply. By
#' default, a ridge-like shrinkage is applied. If `convex` is given, then
#' shrinkage similar to Friedman (1989) is applied. See Ramey et al. (2017) for
#' details.
#' @param prior vector with prior probabilities for each class. If `NULL`
#' (default), then the sample proportion of observations belonging to each class
#' equal probabilities are used. See details.
#' @param tol a threshold for determining nonzero eigenvalues.
#' @return `rda_high_dim` object that contains the trained HDRDA classifier
rda_high_dim <- function(x, ...) {
  UseMethod("rda_high_dim")
}

#' @rdname rda_high_dim
#' @export
rda_high_dim.default <- function(x, y, lambda = 1, gamma = 0,
                                 shrinkage_type = c("ridge", "convex"), prior = NULL,
                                 tol = 1e-6, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]
  lambda <- as.numeric(lambda)
  gamma <- as.numeric(gamma)
  shrinkage_type <- match.arg(shrinkage_type)

  if (lambda < 0 || lambda > 1) {
    rlang::abort("The value for 'lambda' must be between 0 and 1, inclusively.")
  }

  if (gamma < 0) {
    rlang::abort("The value for 'gamma' must be nonnegative.")
  }

  obj <- regdiscrim_estimates(x = x, y = y, cov = FALSE, prior = prior, ...)
  x_centered <- center_data(x = x, y = y)
  K <- obj$num_groups

  # Computes the eigenvalue decomposition of the pooled sample covariance matrix
  # using the Fast SVD approach.
  cov_pool_eigen <- cov_eigen(x = x, y = y, pool = TRUE, fast = TRUE, tol = tol)

  obj$D_q <- cov_pool_eigen$values
  obj$U1 <- cov_pool_eigen$vectors
  obj$q <- length(obj$D_q)
  obj$shrinkage_type <- shrinkage_type
  obj$lambda <- lambda
  obj$gamma <- gamma

  if (shrinkage_type == "ridge") {
    alpha <- 1
  } else {
    # shinkage_family == "convex"
    alpha <- 1 - gamma
  }

  # Transforms the centered data
  XU <- x_centered %*% obj$U1

  # For each class, we calculate the following quantities necessary to train the
  # HDRDA classifier.
  #   1. \Gamma_k
  #   2. Q_k
  #   3. W_k^{-1}
  for (k in seq_len(K)) {
    X_k <- x_centered[y == levels(y)[k], , drop=FALSE]
    n_k <- nrow(X_k)

    # Extracts the transformed, centered data
    # No need to calculate it for the classes individually
    XU_k <- XU[y == levels(y)[k], , drop=FALSE]

    # Transforms the sample mean to the lower dimension
    xbar_U1 <- crossprod(obj$U1, obj$est[[k]]$xbar)

    # In the special case that (lambda, gamma) = (0, 0), the improvements to
    # HDRDA's speed via the Sherman-Woodbury formula are not applicable because
    # Gamma = 0. In this case, we calculate W_inv directly. If the matrix is
    # singular, a slight amount of shrinkage is applied.
    if (lambda == 0 && gamma == 0) {
      W_k <- cov_mle(XU_k)
      W_inv <- try(solve_chol(W_k), silent=TRUE)

      if (inherits(W_inv, "try-error")) {
        W_k <- W_k + diag(0.001, nrow=nrow(W_k), ncol=ncol(W_k))
        W_inv <- solve_chol(W_k)
      }

      Gamma <- matrix(0, nrow=obj$q, ncol=obj$q)
      Q <- diag(n_k)
    } else {
      # Although 'Gamma_k' is a diagonal matrix, we store only its diagonal
      # elements.
      Gamma <- alpha * lambda * obj$D_q + gamma
      Gamma_inv <- diag(Gamma^(-1))

      # X_k %*% U_1 %*% Gamma^{-1} is computed repeatedly in the equations.
      # We compute the matrix once and use it where necessary to avoid
      # unnecessary computations.
      XU_Gamma_inv <- XU_k %*% Gamma_inv
      Q <- diag(n_k) + alpha * (1 - lambda) / n_k * tcrossprod(XU_Gamma_inv, XU_k)
      W_inv <- alpha * (1 - lambda) / n_k * crossprod(XU_Gamma_inv, solve(Q, XU_Gamma_inv))
      W_inv <- Gamma_inv - W_inv
    }

    obj$est[[k]]$n_k <- n_k
    obj$est[[k]]$alpha <- alpha
    obj$est[[k]]$XU <- XU_k
    obj$est[[k]]$xbar_U1 <- xbar_U1
    obj$est[[k]]$Gamma <- Gamma
    obj$est[[k]]$Q <- Q
    obj$est[[k]]$W_inv <- W_inv
  }

  # Creates an object of type 'rda_high_dim'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "rda_high_dim")

  obj
}

#' @inheritParams lda_diag
#' @rdname rda_high_dim
#' @importFrom stats model.frame model.matrix model.response
#' @export
rda_high_dim.formula <- function(formula, data, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- rda_high_dim.default(x = x, y = y, ...)
  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a HDRDA classifier object.
#'
#' Summarizes the trained rda_high_dim classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.rda_high_dim <- function(x, ...) {
  cat("High-Dimensional Regularized Discriminant Analysis\n\n")
  print_basics(x, ...)
  cat("\nReduced dimension:", x$q, "\n")
  cat("Shrinkage type:", x$shrinkage_type, "\n")
  cat("Lambda:", signif(x$lambda, 3), "Gamma:", signif(x$gamma, 3), "\n")
  invisible(x)
}

#' Predicts the class membership of a matrix of unlabeled observations with a
#' trained HDRDA classifier.
#'
#' For a given `rda_high_dim` object, we predict the class of each observation
#' (row) of the the matrix given in `newdata`.
#'
#' @rdname rda_high_dim
#' @inheritParams predict.lda_diag
#' @export
#' @param object Object of type `rda_high_dim` that contains the trained HDRDA
#' classifier
#' @param projected logical indicating whether `newdata` have already been
#' projected to a q-dimensional subspace. This argument can yield large gains in
#' speed when the linear transformation has already been performed.
#' @return list with predicted class and discriminant scores for each of the K
#' classes
predict.rda_high_dim <- function(object, newdata, projected = FALSE, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- sapply(object$est, function(class_est) {
    if (object$lambda == 0 && object$gamma == 0) {
      # Want: log(det(W_k)) = -log(det(W_k_inv))
      log_det <- -log_determinant(class_est$W_inv)
    } else {
      log_det <- log_determinant(class_est$Q)
    }

    if (projected) {
      # The newdata have already been projected. Yay for speed!
      # Center the 'newdata' by the projected class sample mean
      U1_x <- scale(newdata, center = class_est$xbar_U1, scale = FALSE)

      quad_forms <- diag(drop(tcrossprod(U1_x %*% class_est$W_inv, U1_x)))
    } else {
      # Center the 'newdata' by the class sample mean
      x_centered <- scale(newdata, center = class_est$xbar, scale = FALSE)

      U1_x <- crossprod(object$U1, t(x_centered))

      quad_forms <- apply(U1_x, 2, function(z) {
        quadform(class_est$W_inv, z)
      })
    }

    quad_forms + log_det - 2 * log(class_est$prior)
  })

  if (is.vector(scores)) {
    # When sapply above returns a vector, the naming is thrown off.
    # Hence, we rename it to the groups.
    names(scores) <- object$groups

    min_scores <- min_index(scores)
    posterior <- exp(-(scores - min(scores)))
    posterior <- posterior / sum(posterior)
  } else {
    min_scores <- apply(scores, 1, min_index)
    # Grabbed code to calculate 'posterior' from MASS:::predict.qda, which
    # handles numerical overflow unlike the more direct:
    # exp(scores) / (1 + exp(sum(scores)))
    posterior <- exp(-(scores - apply(scores, 1, min)))
    posterior <- posterior / rowSums(posterior)
  }

  if (type == "prob") {
    if (is.vector(posterior)) {
      posterior <- matrix(posterior, nrow = 1)
      colnames(posterior) <- object$groups
    }
    res <- as.data.frame(posterior)
  } else if (type == "class") {
    res <- with(object, factor(groups[min_scores], levels = groups))
  } else {
    if (is.vector(scores)) {
      scores <- matrix(scores, nrow = 1)
      colnames(scores) <- object$groups
    }
    res <- as.data.frame(scores)
  }
  res
}

#' Helper function to optimize the HDRDA classifier via cross-validation
#'
#' For a given data set, we apply cross-validation (cv) to select the optimal
#' HDRDA tuning parameters.
#'
#' The number of cross-validation folds is given in `num_folds`.
#'
#' @export
#' @importFrom dplyr arrange
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param num_folds the number of cross-validation folds.
#' @param num_lambda The number of values of `lambda` to consider
#' @param num_gamma The number of values of `gamma` to consider
#' @param shrinkage_type the type of covariance-matrix shrinkage to apply. By
#' default, a ridge-like shrinkage is applied. If `convex` is given, then
#' shrinkage similar to Friedman (1989) is applied. See Ramey et al. (2017) for
#' details.
#' @param verbose If set to `TRUE`, summary information will be outputted
#' as the optimal model is being determined.
#' @param ... Options passed to [rda_high_dim()].
#' @return list containing the HDRDA model that minimizes cross-validation as
#' well as a `data.frame` that summarizes the cross-validation results.
rda_high_dim_cv <- function(x, y, num_folds = 10, num_lambda = 21, num_gamma = 8,
                            shrinkage_type=c("ridge", "convex"), verbose=FALSE, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]
  shrinkage_type <- match.arg(shrinkage_type)

  cv_folds <- cv_partition(y = y, num_folds = num_folds)

  # The grid of tuning parameters
  # We sort the grid by model preference. Models with lambda = 0 are most
  # preferred because they assume that the covariance matrices are equal. This
  # preference is further based on model parsimony.
  seq_lambda <- seq(0, 1, length = num_lambda)

  if (shrinkage_type == "ridge") {
    seq_gamma <- c(0, 10^seq.int(-2, num_gamma - 4))
  } else  {
    # shrinkage_type == "convex"
    seq_gamma <- seq(0, 1, length = num_gamma)
  }

  tuning_grid <- expand.grid(lambda = seq_lambda, gamma = seq_gamma)
  tuning_grid <- dplyr::arrange(tuning_grid, lambda, gamma)

  cv_errors <- sapply(seq_along(cv_folds), function(fold_i) {
    if (verbose) {
      cat("CV Fold: ", fold_i, " of ", num_folds, "\n")
    }
    fold <- cv_folds[[fold_i]]
    train_x <- x[fold$training, ]
    train_y <- y[fold$training]
    test_x <- x[fold$test, ]
    test_y <- y[fold$test]

    hdrda_out <- rda_high_dim(x = train_x, y = train_y, lambda = 1, gamma = 0, ...)

    # Projects the test data to the q-dimensional subspace.
    # No need to do this for each lambda/gamma pair.
    # NOTE: It's not centered yet.
    test_x <- test_x %*% hdrda_out$U1

    # For each value of lambda and gamma, we train the HDRDA classifier,
    # classify the test observations, and record the number of classification
    # errors.
    fold_errors <- mapply(function(lambda, gamma) {
      errors <- try({
        # Updates Gamma, Q, and W_inv for each class in hdrda_out
        # If an error is thrown, we return 'NA'.
        hdrda_updated <- update_rda_high_dim(hdrda_out, lambda, gamma)
        # Call to predict.rda_high_dim is explicit to pass R CMD CHECK.
        sum(predict.rda_high_dim(hdrda_updated, test_x, projected = TRUE)$class != test_y)
      }, silent = TRUE)

      errors
    }, tuning_grid$lambda, tuning_grid$gamma)
    fold_errors
  })
  cv_errors <- rowSums(cv_errors)
  error_rate <- cv_errors / nrow(x)

  cv_summary <- cbind(tuning_grid, cv_errors, error_rate)

  optimal <- which.min(cv_errors)
  lambda <- tuning_grid$lambda[optimal]
  gamma <- tuning_grid$gamma[optimal]

  # Trains a classifier based on optimal model
  hdrda_out <- rda_high_dim(x=x, y=y, lambda=lambda, gamma=gamma,
                            shrinkage_type=shrinkage_type)

  # Adds optimal parameters and cv_summary to classifier object
  hdrda_out$lambda <- lambda
  hdrda_out$gamma <- gamma
  hdrda_out$cv_summary <- cv_summary
  class(hdrda_out) <- c("hdrda_cv", "rda_high_dim")

  hdrda_out
}

#' Plots a heatmap of cross-validation error grid for a HDRDA classifier object.
#'
#' Uses [ggplot2::ggplot2()] to plot a heatmap of the training error
#' grid.
#'
#' @param x object to plot
#' @param ... unused
#' @export
#' @importFrom ggplot2 ggplot aes scale_fill_gradient labs scale_x_discrete
#' @importFrom ggplot2 scale_y_discrete theme labs geom_tile element_blank
plot.rda_high_dim_cv <- function(x, ...) {
  cv_summary <- x$cv_summary
  cv_summary <- within(cv_summary, {
    lambda <- round(lambda, 3)
    gamma <- round(gamma, 3)
  })

  # Fixes NOTE from R CMD CHECK
  # "no visible binding for global variable 'error_rate'"
  error_rate <- 1

  p <- ggplot(cv_summary, aes(factor(gamma), factor(lambda)))
  p <- p + geom_tile(aes(fill=error_rate), colour="white")
  p <- p + scale_fill_gradient(low="white",
                               high="steelblue",
                               name="CV Error Rate")
  p <- p + labs(x=expression(gamma), y=expression(lambda))
  p <- p + scale_x_discrete(expand=c(0, 0))
  p <- p + scale_y_discrete(expand=c(0, 0))
  p <- p + theme(axis.ticks=element_blank())
  p
}

#' Helper function to update tuning parameters for the HDRDA classifier
#'
#' This function updates some of the quantities in the HDRDA classifier based on
#' updated values of `lambda` and `gamma`. The update can greatly
#' expedite cross-validation to examine a large grid of values for `lambda`
#' and `gamma`.
#'
#' @param obj a `rda_high_dim` object
#' @param lambda a numeric value between 0 and 1, inclusively
#' @param gamma a numeric value (nonnegative)
#' @return a `rda_high_dim` object with updated estimates
update_rda_high_dim <- function(obj, lambda = 1, gamma = 0) {
  # In the special case that (lambda, gamma) = (0, 0), the improvements to
  # HDRDA's speed via the Sherman-Woodbury formula are not applicable because
  # Gamma = 0. In this case, we calculate W_inv directly.
  if (lambda == 0 && gamma == 0) {
    Gamma <- matrix(0, nrow=obj$q, ncol=obj$q)
  } else {
    # NOTE: alpha_k is constant across all classes, so that alpha_k = alpha_1
    # for all k. As a result, Gamma and Gamma_inv are constant across all k. We
    # compute both before looping through all K classes.
    Gamma <- obj$est[[1]]$alpha * lambda * obj$D_q + gamma
    Gamma_inv <- diag(Gamma^(-1))
  }

  for (k in seq_len(obj$num_groups)) {
    n_k <- obj$est[[k]]$n_k
    if (lambda == 0 && gamma == 0) {
      Q <- diag(n_k)

      W_k <- cov_mle(obj$est[[k]]$XU)
      W_inv <- try(solve_chol(W_k), silent=TRUE)
      if (inherits(W_inv, "try-error")) {
        W_k <- W_k + diag(0.001, nrow=nrow(W_k), ncol=ncol(W_k))
        W_inv <- solve_chol(W_k)
      }
    }
    else {
      # X_k %*% U_1 %*% Gamma^{-1} is computed repeatedly in the equations.
      # We compute the matrix once and use it where necessary to avoid
      # unnecessary computations.
      XU_Gamma_inv <- obj$est[[k]]$XU %*% Gamma_inv
      Q <- diag(n_k) +
        obj$est[[k]]$alpha * (1 - lambda) / n_k * tcrossprod(XU_Gamma_inv, obj$est[[k]]$XU)

      W_inv <- obj$est[[k]]$alpha * (1 - lambda) / n_k *
        crossprod(XU_Gamma_inv, solve(Q, XU_Gamma_inv))
      W_inv <- Gamma_inv - W_inv
    }
    obj$est[[k]]$Gamma <- Gamma
    obj$est[[k]]$Q <- Q
    obj$est[[k]]$W_inv <- W_inv
  }
  obj$lambda <- lambda
  obj$gamma <- gamma
  obj
}


library(FinancialMath)

# liczba dotad splaconych rat
lba_splaconych_rat <- 174

# wektor liczby dni w miesiacu: rok zwykly
dni_w_roku <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

# wektor liczby dni w miesiacu: rok przestepny
dni_w_roku_p <- replace(dni_w_roku, dni_w_roku==28, 29)

# wektor liczby dni w miesiacu dla kolejnej raty
wek_dni_w_mies <- c(dni_w_roku[7:12], rep(c(dni_w_roku, dni_w_roku_p, dni_w_roku, dni_w_roku), length.out=353))

# wektor liczby dni w roku dla kolejnej raty
wek_dni_w_roku <- c(rep(365, times=6), rep(rep(c(365,366,365,365), each=12), length.out=353))

# na podstawie § 11 ust 7 rok liczy zawsze 365 dni
dni_w_roku_sum <- sum(dni_w_roku)

# wektory z wysokoscia rat pobranych przez mBank
raty_pobrane <- rep(c(479.42, 334.69, 306.84, 306.83, 306.84, 318.53, 330.45, 342.35, 332.86, 327.42, 316.68, 290.48), times=c(1,1,1,1,1,2,6,20,10,6,55,70))

# wczytanie danych z kursami walut
kursy_walut <- read.csv('~/R/mBank/kursy_walut.csv', header = TRUE)

# daty ksiegowania rat
data_ksiegowania <- as.vector(kursy_walut$data)

##########################################
#
#               rata #1
#
##########################################
kapital_poczatkowy <- 72161.65
oprocentowanie <- 3.45
poz_lba_rat <- 359
dni_w_mcu <- c("cze" = 23, "lip" = 31)
##########################################
cat("-----------  rata #1  -----------\n")

# wyliczenie raty kapitalowo-odsetkowej wylacznie w miesiacu lipcu
oprocentowanie <- oprocentowanie / 100
rata_calkowita <- amort.period(Loan = kapital_poczatkowy, n = poz_lba_rat, i = oprocentowanie, ic = 12, pf = 12)
rata_calkowita <- round(rata_calkowita[2], digits = 2)

# wyliczenie raty odsetkowej: suma odsetek w miesiącach czerwiec oraz lipiec
rata_odsetkowa <- dni_w_mcu / dni_w_roku_sum * kapital_poczatkowy * oprocentowanie
cat("rata_odsetkowa[1] =", round(sum(rata_odsetkowa), digits = 2), "\n")

# wyliczenie raty kapitalowej
rata_kapitalowa <- rata_calkowita - round(as.vector(rata_odsetkowa["lip"]), digits = 2)
cat("rata_kapitalowa[1] =", rata_kapitalowa, "\n")

# kapital pozostajacy do splaty po racie #1
kapital <- kapital_poczatkowy - rata_kapitalowa
cat("kapital_do_splaty[1] =", kapital, "\n\n")

harmonogram <- data.frame(termin_splaty = data_ksiegowania[1],
                          kwota_kapitalu = as.vector(rata_kapitalowa),
                          kwota_odsetek = round(sum(rata_odsetkowa), digits = 2),
                          kwota_raty_lacznie = rata_calkowita + round(as.vector(rata_odsetkowa["cze"]), digits = 2),
                          saldo_zadluzenia_po_splacie_raty = kapital,
                          nadplata = 0)

##########################################
#
#               rata #2
#
##########################################
oprocentowanie <- c(3.45,2.45)
oprocentowanie_mB <- 3.75       # oprocentowanie ustalone przez mBank
dni_oprocentowania <- c(1,30)   # jeden dzień z oprocentowaniem 3,45% oraz 30 dni z oprocentowaniem 2,45%
poz_lba_rat <- 358
##########################################
cat("-----------  rata #2  -----------\n")

# wyliczenie raty calkowitej
oprocentowanie <- oprocentowanie / 100
dni_oprocentowania <- dni_oprocentowania / dni_w_roku_sum
rata_calkowita <- amort.period(Loan = kapital, n = poz_lba_rat, i = oprocentowanie[1], ic = 12, pf = 12)
rata_calkowita <- round(rata_calkowita[2], digits = 2)

# wyliczenie raty odsetkowej
rata_odsetkowa <- sum(kapital * oprocentowanie * dni_oprocentowania)
rata_odsetkowa <- round(rata_odsetkowa, digits = 2)
cat("rata_odsetkowa[2] =", rata_odsetkowa, "\n")

# wyliczenie raty kapitalowej
rata_kapitalowa <- rata_calkowita - rata_odsetkowa
cat("rata_kapitalowa[2] =", rata_kapitalowa, "\n")

# kapital pozostajacy do splaty po racie #2
kapital_mB <- kapital
kapital <- kapital - rata_kapitalowa
cat("kapital_do_splaty[2] =", kapital, "\n")

# wyliczenie nadplaty
oprocentowanie_mB <- oprocentowanie_mB / 100
rata_calkowita_mB <- amort.period(Loan = kapital_mB, n = poz_lba_rat, i = oprocentowanie_mB, ic = 12, pf = 12)
rata_calkowita_mB <- round(rata_calkowita_mB[2], digits = 2)
nadplata <- rata_calkowita_mB - rata_calkowita
cat("nadplata[2] =", nadplata, "\n\n")

harmonogram <- rbind(harmonogram, data.frame(termin_splaty = data_ksiegowania[2],
                                             kwota_kapitalu = rata_kapitalowa,
                                             kwota_odsetek = rata_odsetkowa,
                                             kwota_raty_lacznie = rata_calkowita,
                                             saldo_zadluzenia_po_splacie_raty = kapital,
                                             nadplata = nadplata))

##########################################
#
#           rata #3 i kolejne
#
##########################################
oprocentowanie = 2.45
poz_lba_rat <- 357
##########################################
cat("----------  rata #3 +  ----------\n")

# wyliczenie raty calkowitej
oprocentowanie <- oprocentowanie / 100
rata_calkowita <- amort.period(Loan = kapital, n = poz_lba_rat, i = oprocentowanie, ic = 12, pf = 12)
rata_calkowita <- round(rata_calkowita[2], digits = 2)
cat("rata_calkowita =", rata_calkowita, "\n\n")

# wyliczenie pozostalej czesci harmonogramu
for(rata in 3:359) {
  rata_odsetkowa <- round(kapital * oprocentowanie * wek_dni_w_mies[rata] / dni_w_roku_sum, digits = 2)
  rata_kapitalowa <- rata_calkowita - rata_odsetkowa
  kapital <- kapital - rata_kapitalowa

  harmonogram <- rbind(harmonogram, data.frame(termin_splaty = data_ksiegowania[rata],
                                               kwota_kapitalu = rata_kapitalowa,
                                               kwota_odsetek = rata_odsetkowa,
                                               kwota_raty_lacznie = rata_calkowita,
                                               saldo_zadluzenia_po_splacie_raty = kapital,
                                               nadplata = raty_pobrane[rata] - rata_calkowita))
}

cat("-----  stan na 01.01.2021  -----\n")
splacony_kapital <- sum(harmonogram$kwota_kapitalu[1:lba_splaconych_rat])
kapital_do_splaty <- kapital_poczatkowy - splacony_kapital
cat("splacony_kapital =", splacony_kapital, "\n")
cat("kapital_do_splaty =", kapital_do_splaty, "\n")

##########################################
#
#         wyliczenie nadplaty
#
##########################################
# raty 1 do 82 liczone po kursie mBanku
nadplata_PLN_mBank <- round(harmonogram$nadplata[1:82] * kursy_walut$kurs.mBank[1:82], digits = 2)

# od raty 83 splata bezposrednio w CHF, nadplata liczona po kursie srednim NBP
nadplata_PLN_NBP <- round(harmonogram$nadplata[83:lba_splaconych_rat] * kursy_walut$kurs.NBP[83:lba_splaconych_rat], digits = 2)

nadplata_PLN <- c(nadplata_PLN_mBank, nadplata_PLN_NBP)
cat("nadplata =", sum(nadplata_PLN, na.rm=TRUE), "PLN\n")


#' Global Distance Metric Learning
#'
#' Performs Global Distance Metric Learning (GDM) on the given data, learning a diagonal matrix.
#'
#' Put GdmDiag function details here.
#'
#' @param data \code{n * d} data matrix. \code{n} is the number of data points,
#'             \code{d} is the dimension of the data.
#'             Each data point is a row in the matrix.
#' @param simi \code{n * 2} matrix describing the similar constrains.
#'              Each row of matrix is serial number of a similar pair in the original data.
#'				For example, pair(1, 3) represents the first observation is similar the 3th observation in the original data.
#' @param dism \code{n * 2} matrix describing the dissimilar constrains as \code{simi}.
#'				Each row of matrix is serial number of a dissimilar pair in the original data.
#' @param C0 numeric, the bound of similar constrains.
#' @param threshold numeric, the threshold of stoping the learning iteration.
#'
#' @return list of the GdmDiag results:
#' \item{newData}{GdmDiag transformed data}
#' \item{diagonalA}{suggested Mahalanobis matrix}
#' \item{dmlA}{matrix to transform data, square root of diagonalA }
#' \item{error}{the precision of obtained distance metric by Newton-Raphson optimization }
#'
#' For every two original data points (x1, x2) in newData (y1, y2):
#'
#' \eqn{(x2 - x1)' * A * (x2 - x1) = || (x2 - x1) * B ||^2 = || y2 - y1 ||^2}
#'
#' @keywords GDM global distance metirc learning transformation mahalanobis metric
#'
#' @note Be sure to check whether the dimension of original data and constrains' format are valid for the function.
#'
#' @author Gao Tao <\url{http://www.gaotao.name}>
#'
#' @export GdmDiag
#' @import MASS
#'
#' @references
#' Steven C.H. Hoi, W. Liu, M.R. Lyu and W.Y. Ma (2003).
#' Distance metric learning, with application to clustering with side-information.
#  in \emph{Proc. NIPS}.
#'

#' @examples
#' \dontrun{
#' set.seed(602)
#' library(MASS)
#' library(scatterplot3d)
#'
#' # generate simulated Gaussian data
#' k = 100
#' m <- matrix(c(1, 0.5, 1, 0.5, 2, -1, 1, -1, 3), nrow =3, byrow = T)
#' x1 <- mvrnorm(k, mu = c(1, 1, 1), Sigma = m)
#' x2 <- mvrnorm(k, mu = c(-1, 0, 0), Sigma = m)
#' data <- rbind(x1, x2)
#'
#' # define similar constrains
#' simi <- rbind(t(combn(1:k, 2)), t(combn((k+1):(2*k), 2)))
#'
#' temp <-  as.data.frame(t(simi))
#' tol <- as.data.frame(combn(1:(2*k), 2))
#'
#' # define disimilar constrains
#' dism <- t(as.matrix(tol[!tol %in% simi]))
#'
#' # transform data using GdmDiag
#' result <- GdmDiag(data, simi, dism)
#' newData <- result$newData
#' # plot original data
#' color <- gl(2, k, labels = c("red", "blue"))
#' par(mfrow = c(2, 1), mar = rep(0, 4) + 0.1)
#' scatterplot3d(data, color = color, cex.symbols = 0.6,
#'			  xlim = range(data[, 1], newData[, 1]),
#'			  ylim = range(data[, 2], newData[, 2]),
#'			  zlim = range(data[, 3], newData[, 3]),
#'			  main = "Original Data")
#' # plot GdmDiag transformed data
#' scatterplot3d(newData, color = color, cex.symbols = 0.6,
#'			  xlim = range(data[, 1], newData[, 1]),
#'			  ylim = range(data[, 2], newData[, 2]),
#'			  zlim = range(data[, 3], newData[, 3]),
#'			  main = "Transformed Data")
#' }
#'
GdmDiag <- function(data, simi, dism, C0 = 1, threshold = 0.001) {
		fudge = 0.000001
		reduction = 2
		data <- as.matrix(data)
		simi <- as.matrix(simi)
		dism <- as.matrix(dism)
		N <- dim(data)[1]
		d <- dim(data)[2]
		a <- matrix(rep(1, d), nrow = d)# initial diagonal A in the form of column vector
		# dij <- mat.or.vec(1, d)

		new.simi <- unique(t(apply(simi, 1, sort)))
		new.dism <- unique(t(apply(dism, 1, sort)))

		######### contraints
		dist1.dism <- data[new.dism[, 1], ] - data[new.dism[, 2], ]
		dist.ij <- sqrt((dist1.dism^2) %*% a)
		sum.dist <- sum(dist.ij)
		temp <- cbind(dist1.dism^2, dist.ij)
		deri1.ij <-0.5 * temp[, 1:d]/(temp[, d + 1] + (temp[, d + 1] == 0) * fudge)
		sum.deri1 <- t(apply(deri1.ij, 2, sum))
		deri2.ij <- t(apply(dist1.dism, 1, function(x) outer(x, x)))
		temp1 <- cbind(deri2.ij, dist.ij^3)
		deri2.ij <- -0.25 * temp1[, 1:(d^2)]/(temp1[, d^2 + 1] + (temp1[, d^2 + 1] == 0) * fudge)
		sum.deri2 <- matrix(apply(deri2.ij, 2, sum), ncol = d, byrow = TRUE)

		fD <- log(sum.dist)
		fD.1d <- sum.deri1/sum.dist
		fD.2d <- sum.deri2/sum.dist - crossprod(sum.deri1, sum.deri1)/(sum.dist^2)

		####### objection is part of contraints
		# fD <- log(sum.dist)
		######################################
		dist1.dism <- data[new.dism[, 1], ] - data[new.dism[, 2], ]
		d.sum <- t(apply(dist1.dism^2, 2, sum))
		dist1.simi <- data[new.simi[, 1], ] - data[new.simi[, 2], ]
		s.sum <- t(apply(dist1.simi^2, 2, sum))

		# S1 <- mat.or.vec(N, N)
		# D1 <- mat.or.vec(N, N)

		# dism <- rbind(dism, dism[, c(2, 1)]) #
		# Dism <- rbind(Dism, Dism[, c(2, 1)])
		# S1[dism] <- 1
		# D1[Dism] <- 1

		error <- 1
		while (error > threshold) {
			obj.initial <- as.numeric(s.sum %*% a) + C0 * fD
			fS.1d <- s.sum

			gradient <- fS.1d - C0 * fD.1d
			hessian <- -C0 * fD.2d + fudge * diag(1, d)
			invhessian <- solve(hessian)
			cstep <- invhessian %*% t(gradient)

			lambda <- 1
			atemp <- a - lambda * cstep
			atemp[atemp < 0] <- 0

			fDo <- log(sum(sqrt((dist1.dism^2) %*% atemp)))
			obj <- as.numeric(s.sum %*% atemp) + C0 * fDo
			obj.previous <- obj * 1.1

			while (obj < obj.previous) {
				lambda.previous <- lambda
				obj.previous <- obj
				a.previous = atemp
				lambda <- lambda/reduction
				atemp <- a - lambda * cstep
				atemp[atemp < 0] <- 0
				fDo1 <- log(sum(sqrt((dist1.dism^2) %*% atemp)))
				obj <- as.numeric(s.sum %*% atemp) + C0 * fDo1
			}
		a <- a.previous
		error <- abs((obj.previous - obj.initial)/obj.previous)
		}
		diagonalA <- diag(as.numeric(a))
		dmlA <- sqrt(diagonalA)
		newData <- data %*% dmlA

		return(list("newData" = newData, "diagonalA" = diagonalA, "dmlA" = dmlA, "error" = error))
}


## 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.
library(xts)
library(Quandl)

# Read in spot fx rates
fxspot.tickers <- c("CURRFX/USDEUR", "CURRFX/USDJPY", "CURRFX/USDCHF")
fxspot.raw <- Quandl(fxspot.tickers[1], type="xts")
for (i in 2:length(fxspot.tickers)) {
  fxspot.temp <- Quandl(fxspot.tickers[i], type="xts")
  fxspot.raw <- merge(fxspot.raw, fxspot.temp)
}
colnames(fxspot.raw) <- c("USDEUR.spot", "USDJPY.spot", "USDCHF.spot")

# Read in future fx rates
fxfut.tickers <- c("CHRIS/CME_EC1", "CHRIS/CME_JY1", "CHRIS/CME_SF1")
fxfut.raw <- Quandl(fxfut.tickers[1], type="xts")
for (i in 2:length(fxfut.tickers)) {
  fxfut.temp <- Quandl(fxfut.tickers[i], type="xts")
  fxfut.raw <- merge(fxfut.raw, fxfut.temp)
}
colnames(fxfut.raw) <- c("USDEUR.fut", "USDJPY.fut", "USDCHF.fut")

# Read in 3M USD deposit futures
usd.3m.raw <- Quandl("CHRIS/CME_ED1", type="xts")[,"Settle"]
eur.3m.raw <- Quandl("CHRIS/LIFFE_I1", type="xts")[,"Settle"]
jpy.3m.raw <- Quandl("CHRIS/CME_EY1", type="xts")[,"Settle"]
chf.3m.raw <- Quandl("CHRIS/LIFFE_S1", type="xts")[,"Settle"]
chf.3m.raw["20150122"] <- 101.08  # Fix 1st data error
chf.3m.raw["20150508"] <- 100.83  # Fix 2nd data error
deposits3m.raw <- cbind(usd.3m.raw, eur.3m.raw, jpy.3m.raw, chf.3m.raw)
deposits3m <- (100-deposits3m.raw)/100  # convert futures prices to yield
colnames(deposits3m) <- c("3MUSDLIBOR", "3MCHFLIBOR", "3MJPYTIBOR", "3MEURIBOR")

alldata.full <- cbind(fxspot.raw, deposits3m, fxfut.raw)
alldata <- alldata.full["2013/"]

# here some calculations have to happen...


#' Calculate the Jaccard statistic for two sets of intervals.
#'
#' Quantifies the extent of overlap between to sets of intervals in terms of
#' base-pairs. Groups that are shared between input are used to calculate the statistic
#' for subsets of data.
#'
#' @details The Jaccard statistic takes values of `[0,1]` and is measured as:
#'
#' \deqn{ J(x,y) = \frac{\mid x \bigcap y \mid}
#'                      {\mid x \bigcup y \mid} =
#'                 \frac{\mid x \bigcap y \mid}
#'                      {\mid x \mid + \mid y \mid -
#'                       \mid x \bigcap y \mid} }
#'
#' @param x [ivl_df]
#' @param y [ivl_df]
#'
#' @template stats
#'
#' @family interval statistics
#'
#' @return
#' tibble with the following columns:
#'
#'   - `len_i` length of the intersection in base-pairs
#'   - `len_u` length of the union in base-pairs
#'   - `jaccard` value of jaccard statistic
#'   - `n_int` number of intersecting intervals between `x` and `y`
#'
#' If inputs are grouped, the return value will contain one set of values per group.
#'
#' @seealso
#'   \url{http://bedtools.readthedocs.org/en/latest/content/tools/jaccard.html}
#'
#' @examples
#' genome <- read_genome(valr_example('hg19.chrom.sizes.gz'))
#'
#' x <- bed_random(genome, seed = 1010486)
#' y <- bed_random(genome, seed = 9203911)
#'
#' bed_jaccard(x, y)
#'
#' # calculate jaccard per chromosome
#' bed_jaccard(dplyr::group_by(x, chrom),
#'             dplyr::group_by(y, chrom))
#'
#' @export
bed_jaccard <- function(x, y) {
  x <- check_interval(x)
  y <- check_interval(y)

  groups_shared <- shared_groups(x, y)

  x <- bed_merge(x)
  y <- bed_merge(y)

  res_intersect <- bed_intersect(x, y)

  if (!is.null(groups_shared)) {
    x <- group_by(x, !!! syms(groups_shared))
    y <- group_by(y, !!! syms(groups_shared))

    res_intersect <- group_by(res_intersect, !!! syms(groups_shared))
  }

  res_intersect <- summarize(
    res_intersect,
    sum_overlap = sum(as.numeric(.overlap)),
    n_int = as.numeric(n())
  )

  res_x <- mutate(x, .size = end - start)
  res_x <- summarize(res_x, sum_x = sum(as.numeric(.size)))

  res_y <- mutate(y, .size = end - start)
  res_y <- summarize(res_y, sum_y = sum(as.numeric(.size)))

  if (!is.null(groups_shared)) {
    res <- left_join(res_intersect, res_x, by = as.character(groups_shared))
    res <- left_join(res, res_y, by = as.character(groups_shared))

    res <- mutate(res, sum_xy = sum_x + sum_y)
    group_cols <- select(res, !!! syms(groups_shared))

    res <- transmute(
      res,
      len_i = sum_overlap,
      len_u = sum_xy,
      jaccard = sum_overlap / (sum_xy - sum_overlap),
      n = n_int
    )

    res <- bind_cols(group_cols, res)
  } else {
    n_i <- res_intersect$sum_overlap
    n_u <- res_x$sum_x + res_y$sum_y

    jaccard <- n_i / (n_u - n_i)

    res <- tibble(
      len_i = n_i,
      len_u = n_u,
      jaccard = jaccard,
      n = res_intersect$n_int
    )
  }

  res
}


#' @title
#' Generate simulation data
#'
#' @description
#' This function generates simulation data for the nested reduced-rank
#' regression under the multivariate functional regression scenario.
#' With user-specified model dimensions and ranks,
#' this function first generates functional multivariate predictors and
#' responses and then transform the functional regression problem into a
#' conventional finite-dimensional regression problem through basis expansion
#' and truncation. The B-spline basis is used to conduct basis expansion.
#'
#' @usage
#' NRRR.sim(n, ns, nt, r, rx, ry, jx, jy, p, d,
#'          s2n, rho_X, rho_E, Sigma = "CorrAR")
#'
#' @param n sample size.
#' @param ns number of time points at which the predictor trajectory is observed.
#' @param nt number of time points at which the response trajectory is observed.
#' @param r rank of the local reduced-rank structure.
#' @param rx number of latent predictors.
#' @param ry number of latent responses.
#' @param jx number of basis functions to expand the predictor trajectory.
#' @param jy number of basis functions to expand the response trajectory.
#' @param p number of predictors.
#' @param d number of responses.
#' @param s2n a positive number to specify the signal to noise ratio.
#' @param rho_X a scalar between 0 and 1 to specify the correlation strength among covariates.
#' @param rho_E a scalar between 0 and 1 to specify the correlation strength among random errors.
#' @param Sigma the correlation structure. Two options are available,
#'              "CorrAR": autoregressive,
#'              "CorrCS": compound symmetry.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the matrix U.}
#'   \item{Bg}{the matrix V.}
#'   \item{Al}{the matrix A.}
#'   \item{Bl}{the matrix B.}
#'   \item{C}{the coefficient matrix C.}
#'   \item{Alstar}{A* in equation (7) of the NRRR paper.}
#'   \item{Blstar}{B* in equation (7) of the NRRR paper.}
#'   \item{Cstar}{\eqn{(U \otimes I_jy)A* B*^T(V \otimes I_jx)^T} in equation (7) of the NRRR paper.}
#'   \item{tseq}{a sequence of time points at which the response trajectory is observed.}
#'   \item{psi}{the set of basis functions to expand the response trajectory.}
#'   \item{Jpsi}{the correlation matrix of psi. Jpsihalf is (Jpsi)^(1/2).}
#'   \item{sseq}{a sequence of time points at which the predictor trajectory is observed.}
#'   \item{phi}{the set of basis functions to expand the predictor trajectory.}
#'   \item{Jphi}{the correlation matrix of phi.}
#'   \item{E}{the random error matrix.}
#'   \item{Y}{an array of dimension \code{(n, d, nt)}, i.e., the generated response observations.}
#'   \item{X}{an array of dimension \code{(n, p, ns)}, i.e., the generated predictor observations.}
#'   \item{Ytrue}{an array of dimension \code{(n, d, nt)}. The response observations without random errors.}
#'   \item{Yest}{the response matrix used in NRRR estimation, and is of dimension n-by-jy*d.}
#'   \item{Xest}{the design matrix used in NRRR estimation, and is of dimension n-by-jx*p.}
#' @examples
#' library(NRRR)
#' simDat <- NRRR.sim(n = 100, ns = 200, nt = 200, r = 5, rx = 3, ry = 3,
#'                    jx = 15, jy = 15, p = 10, d = 6, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' simDat$Ag
#' @importFrom stats runif rnorm sd
#' @importFrom splines bs
#' @importFrom MASS mvrnorm
#' @export
NRRR.sim <- function(n,ns,nt,r,rx,ry,jx,jy,p,d,s2n,rho_X,rho_E,Sigma="CorrAR"){

  #require(MASS)
  #require(splines)
  if(p < rx) stop("rx cannot be greater than p")
  if(d < ry) stop("ry cannot be greater than d")

  ### generate X(s) and Y(t)
  # generate uniformly distributed time points for x(s)
  sseq <- sort(stats::runif(ns,0,1))
  # generate basis functions
  phi <- splines::bs(c(0,sseq),df = jx)[-1,]
  # compute Jphi
  Jphi <- matrix(nrow=jx,ncol=jx,0)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(s in 1:ns) Jphi <- Jphi + phi[s,]%*%t(phi[s,])*sdiff[s]

  # generate X(s)
  if (Sigma == "CorrAR") {
      Sigma <- CorrAR
    } else {
      Sigma <- CorrCS
    }
  Xsigma <- Sigma(p*jx,rho_X)
  Xi <- MASS::mvrnorm(n,rep(0,p*jx),Xsigma)
  X <- array(dim=c(n,p,ns),NA)
  for(s in 1:ns){
    Phis <- kronecker(diag(nrow=p,ncol=p),t(phi[s,]))
    for(i in 1:n){
      X[i,,s] <-  Phis%*%Xi[i,]
    }
  }

  #####Bg (V) matrix, p times rx
  Bg <- qr.Q(qr(matrix(nrow=p,ncol=rx,stats::rnorm(p*rx))))
  #####Ag (U) matrix, d times ry
  Ag <- qr.Q(qr(matrix(nrow=d,ncol=ry,stats::rnorm(d*ry))))
  #####Blstar (B^*) matrix, jx*rx times r
  Blstar <- matrix(nrow=jx*rx, ncol=r, stats::rnorm(jx*rx*r))
  #####Alstar (A^*) matrix, jy*ry times r
  Alstar <- matrix(nrow=jy*ry, ncol=r, stats::rnorm(jy*ry*r))
  #####The coefficient matrix to generate Y(t)
  Cstar <- kronecker(Ag,diag(jy))%*%Alstar%*%t(Blstar)%*%kronecker(t(Bg),diag(jx))

  # Integrated X
  Xint <- matrix(nrow=p*jx,ncol=n,0)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(s in 1:ns){
    Xint <- Xint + kronecker(diag(nrow=p,ncol=p),phi[s,])%*%t(X[,,s])*sdiff[s]
  }

  # True signal Ytrue(t)
  # generate uniformly distributed time points for y(t)
  tseq <- sort(stats::runif(nt,0,1))
  # generate basis function
  psi <- splines::bs(c(0,tseq),df = jy)[-1,]
  Ytrue <- array(dim=c(n,d,nt),NA)
  Y0 <- Cstar%*%Xint
  for(t in 1:nt){
    Psit <- kronecker(diag(nrow=d,ncol=d),t(psi[t,]))
    Ytrue[,,t] <- t(Psit%*%Y0)
  }

  # The error matrix, n times d*jy
  sigma <- stats::sd(as.vector(Y0))/s2n
  E <- matrix(nrow=n,ncol=d*jy, stats::rnorm(n*d*jy,0,sigma))

  # The response matrix Y(t)
  Y <- array(dim=c(n,d,nt),NA)
  for(t in 1:nt){
    Psit <- kronecker(diag(nrow=d,ncol=d),t(psi[t,]))
    for(i in 1:n){
      Y[i,,t] <- Ytrue[i,,t]+Psit%*%E[i,]
    }
  }

  # compute Jpsi
  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)

  ### Process the data for estimation
  Xa <- array(dim=c(n,p,jx),NA)
  sdiff <- (sseq - c(0,sseq[-ns]))
  for(i in 1:n){
    for(l in 1:p){
      for(j in 1:jx){
        Xa[i,l,j] <- sum(phi[,j]*X[i,l,]*sdiff)    # integrate over s
      }
    }
  }

  Ya <- array(dim=c(n,d,jy),NA)
  tdiff <- (tseq - c(0,tseq[-nt]))
  psistar <- psi%*%Jpsihalfinv
  for(k in 1:d){
    for(i in 1:n){
      for(j in 1:jy){
        Ya[i,k,j] <- sum(psistar[,j]*Y[i,k,]*tdiff) # integrate over t
      }
    }
  }

  # Y and X matrices for estimation
  Yest <- Ya[,,1]
  for(j in 2:jy) Yest <- cbind(Yest,Ya[,,j])
  Xest <- Xa[,,1]
  for(j in 2:jx) Xest <- cbind(Xest,Xa[,,j])

  # C matrix in estimation
  Alstaradj <-  kronecker(diag(ry),Jpsihalf)%*%Alstar
  alindex <- rep(1:jy,ry)
  Al <- Alstaradj[order(alindex),]
  blindex <- rep(1:jx,rx)
  Bl <- Blstar[order(blindex),]
  C <- kronecker(diag(jx),Bg)%*%Bl%*%t(Al)%*%kronecker(diag(jy),t(Ag))

  list(Ag=Ag,Bg=Bg,Alstar=Alstar,Blstar=Blstar,Cstar=Cstar,
       Al=Al, Bl=Bl, C=C,
       sseq=sseq,psi=psi,Jpsi=Jpsi,Jpsihalf=Jpsihalf,
       tseq=tseq,phi=phi,Jphi=Jphi,
       E=E,
       Y=Y,X=X,Ytrue=Ytrue,
       Yest=Yest,Xest=Xest)

}


# cod North Sea

firstAge<-1
maxAge<-20
nSeasons<-4
FbarAge<-c(2,4)  # expanded relative to normal

dicardLength<-40   # Knife edge selection for discard

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

f.season<-1
l.season<-nSeasons

#### Natural moratlity
M<-c(0.8,0.35,0.25,rep(0.2,maxAge-firstAge))                  # annual values
M<-rep(M/nSeasons,each=nSeasons)                              # quarterly values, assume equaly split
propMat<-c(0.01,0.05,0.23,0.62,0.86,rep(1,maxAge-firstAge))   # annual values
propMat<-rep(propMat,each=nSeasons)

####  von Bertalanffy growth  parameters
K<-0.219
loo<-126
CV<-0.15  # CV of length distribution within an age

vonBertalanffy<-function(tid,loo,K,t0=0) {
  return(loo*(1-exp(-K*(tid-t0))))
}

#### length weight relation.  Fishbase North Sea Netherlands
a<-0.0068E-3
b<-3.101
lw<-function(len){a*len^b}
#########

# first try, No fishing
age<-seq(firstAge,maxAge,1/nSeasons)
age<-age[1:(length(age)-1)]
age
M<-M[1:length(age)]
propMat<-propMat[1:length(age)]

len<-vonBertalanffy(tid=age,loo=loo,K=K)
W<-lw(len)
N<-M #copy structure
N[1]<-1
for (i in 2:length(N)) N[i]<-N[i-1]*exp(-M[i])
biomass<-N*W
SSB<-biomass*propMat

nox<-2; noy<-2;
  newplot(dev='screen',nox,noy);
optAge<-age[which(biomass==max(biomass))]

plot(age,len,ylab="cm",main='Length at age')
abline(v=optAge)
plot(age,W,ylab="kg", main="Weight at age")
abline(v=optAge)
plot(age,N,ylab=" ", main="Stock number at age")
abline(v=optAge)

plot(age,biomass,ylab="kg", main="TSB and SSB at age")
lines(age,SSB)
abline(v=optAge)

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

# "North Sea Cod" data from Niels Madsen
mesh<-c(70,80,90,100,110,120,130,140,150)
L50<-c(21.22,24.99,28.75,32.52,36.28,40.05,43.81,47.58,51.35)
SR<-c(3.98,4.69,5.40,6.10,6.81,7.52,8.22,8.93,9.64)
selection<-data.frame(mesh=mesh,L50=L50,SR=SR)
# plot(mesh,L50); abline(lm(L50~mesh))
# plot(mesh,SR); abline(lm(SR~mesh))
L50par<-lm(L50~mesh,  data=selection)
SRpar<-lm(SR~mesh,  data=selection)
selection<-data.frame(L50a=L50par$coefficients[1],L50b=L50par$coefficients[2],SRa=SRpar$coefficients[1],SRb=SRpar$coefficients[2])

meshSelection<-function(mesh,len) {
  L50<-selection$L50a[1]+mesh*selection$L50b[1]
  SR<- selection$SRa[1]+mesh*selection$SRb[1]
  S1<-L50*log(3)/(SR/2)
  S2<-S1/L50
  SL<-1/(1+exp(S1-S2*len))
  return (list(SL,L50))
}

l<-seq(10,100)  # fish length in cm
col<-1
firstMesh<-70
a<- meshSelection(mesh=firstMesh,len=l)
plot(l,a[[1]],type='l',col=col,xlab="length (cm)",ylab="selection")
abline(h=0.5)
abline(v=a[[2]],col=col)
text(a[[2]],0.55,formatC(firstMesh,width=3,digits=3),col=col)
for (mesh in (seq(firstMesh+20,200,20))) {
  col<-col+1
  a<-meshSelection(mesh=mesh,len=l)
  lines(l,a[[1]],col=col)
  text(a[[2]],0.55,formatC(mesh,width=3,digits=3),col=col)
  abline(v=a[[2]],col=col)
}

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

 YPR<-function(EffortMult=1,len=len, mesh=mesh,minSize=40)
# Yield Per Recruit function using size dependent F, where F(a,length)=SL(length)*effort
# effortMult is effort multiplier
# len is length at age vector
# mesh is mesh size of trawl
# minSize is minimum landing size, Knife edge select: below means discard, above means landed
# Return values:
#  yield: landed weigth per recruir
#  discard: discarded weight per recruit
#  meanWLanded: mean weight of landed fish
#  Fbar: average F over specified ages
 {
      Fmort<-meshSelection(mesh,len)[[1]]*EffortMult

      N<-Fmort # copy structure
      N[]<-0
      N[1]<-1

      Z<-M+Fmort

      Z[is.na(Z)]<-0
      C<-Z  #copy structure
      for (t in (2:length(Z))) {
        N[t]<-N[t-1]*exp(-Z[t])     # exponential decay
      }
      #plot(age,N)
      Nbar<-N*(1-exp(-Z))/Z   # average N within time step
      #lines(age,Nbar)
      C<-Nbar*Fmort       # total catch numbers
      Clanded<-C          # copy structure
      Clanded[len<minSize]<-0;        # extract landed (length>minimum size)
      mw<-sum(Clanded*W)/sum(Clanded)
      Cdiscard<-C         # copy structure
      Cdiscard[len>=minSize]<-0;

      deadM<-Nbar*M     # number dead of natural causes
      dead<-deadM+C     # total number dead

      yield<-sum(Clanded*W)    # yield weight
      discard<-sum(Cdiscard*W) # discarded weight

      # TSB and SSB in start of the first season
      TSB<-matrix(N,nrow=nSeasons)[1,]*matrix(W,nrow=nSeasons)[1,]
      SSB<-sum(TSB*matrix(propMat,nrow=nSeasons)[1,])
      TSB<-sum(TSB)

      C<-apply(matrix(C,nrow=nSeasons),2,sum) #sum into C at age
      dead<-apply(matrix(dead,nrow=nSeasons),2,sum) # sum total dead at age
      Z<-apply(matrix(Z,nrow=nSeasons),2,sum) #age Z
      Fmort<-Z*C/dead  # annual F at age
      #print(Fmort)
      Fbar<-mean(Fmort[FbarAge[1]:FbarAge[2]])
      return(list(yield=yield,meanWLanded=mw,discard=discard,Fbar=Fbar,TSB=TSB,SSB=SSB))
 }

 YPR(EffortMult=0.1,len=len, mesh=90,minSize=dicardLength)

 # the next exercise is to check the model and to define the range of effort multiplier (myMult)
 myMult<-seq(0.0,0.5,0.001)
 myMesh<-seq(40,180,20)
 design<-data.frame(myMesh=rep(myMesh,length(myMult)),myMult=rep(myMult,each=length(myMesh)))

a<- by(design,list(design$myMesh,design$myMult),function(x) {
      YPR(EffortMult=x$myMult,len=len, mesh=x$myMesh,minSize=dicardLength)
 })

b<-data.frame(as.matrix(design),matrix(unlist(a),ncol=6,byrow = T))
names(b)<-list("myMesh", "myMult", "Yield" ,    "meanWLanded" ,    "discard" ,    "Fbar", "TSB","SSB"  )

#b<-b[order(b$myMesh,b$myMult),]

levelplot(Yield~myMesh*myMult, data=b,xlab="Mesh size (mm)",ylab="effort multiplier",main="Yield per recruit",contour=T)

levelplot(Yield~myMesh*Fbar, data=b,xlab="Mesh size (mm)",ylab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''),main="Yield per recruit",contour=T)

xyplot( Yield~Fbar|as.factor(paste (formatC(myMesh,,wid=3,flag="0"),'mm')), data=b,ylab='Yield (kg)', xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''),xlim=c(0,1))

xyplot( Yield~Fbar, data=b, xlim=c(0,1),ylab='Yield (kg) per recruit', xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( discard~Fbar, data=b,  xlim=c(0,1),ylab='Discard (kg) per recruit',xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( SSB~Fbar, data=b,  xlim=c(0,1),ylab='SSB (kg) per recruit',xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( TSB~Fbar, data=b,  xlim=c(0,1),ylab='TSB (kg) per recruit',xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))

xyplot( meanWLanded~Fbar, data=b, xlim=c(0,1),ylab="mean landings weight (kg)",xlab=paste("Fbar( ",FbarAge[1],"-",FbarAge[2],")",sep=''))


# rho_xy.r
# computes correlation between events;
# r stands for response and R for reinforcer
# ==========================================================================
# Inputs:
#   t_ev: matrix of 2x2 with [time,event]
#   R: id of first event (e.g., reinforcer)
#   r: id of second event (e.g., response)
#   sec_mult: resolution of the correlation. For example, if tvec
#     is in seconds and we want to compute correlation in milliseconds,
#     we must put sec_mult = 1000.
#   bin_res: resolution of bin. If we want to compute correlation in bins of
#     200 millisenconds, put bin_res = 200
# NOTE:
# This function depends on get_bins
# ==========================================================================

rho.rR <- function(t_ev,r,R,sec_mult,bin_res){

  # The max time at which subject get a reinforfer
  max_t <- max(t_ev[t_ev[,2] == R,1]) * sec_mult

  # vector of events
  v_events <- c(r,R)

  # Matrix of 3 columns for bins and frecuencies of events in those bins
  m_rR <-
    seq(0, max_t, bin_res) %>%
    seq_along() %>%
    data.frame(bin_r = .,
               r = NA,
               R = NA)

  for(j in 1:2){

    e <- v_events[j]
    event_bins <- t_ev[which(t_ev[ ,2] == e), 1] * sec_mult %>%
      get_bins(.,1,max_t,bin_res)

    for(i in 1:nrow(m_rR)){

      sum    <-  sum(m_rR[i,1] == event_bins)
      m_rR[i, j + 1] <- sum # j + 1 because m_rR have 3 columns

    }
  }

  cor(m_rR[ ,2],m_rR[ ,3])
}


## 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.

principal.start <- 30e6  # pool principal
n.peryr <- 12  # monthly = 12 payments per year
T <- 30   # 30-year mortgage
r <- 0.0625  # 6.25%
t <- 1:(n.peryr*T)

## tranche info
attach.pts <- list(a=0.22, b=0.14, c=0.05, z=0)
principal <- list(a=24e6,b=3e6,c=3e6,z=0)
interestbase <- list(a=(1-attach.pts$a)*principal.start,
                     b=(attach.pts$a-attach.pts$b)*principal.start,
                     c=(attach.pts$b-attach.pts$c)*principal.start,
                     z=(attach.pts$c-attach.pts$z)*principal.start)

## calculate level monthly payment
pmt.level <- principal.start*r/(n.peryr*(1-1/(1+r/n.peryr)^(n.peryr*T)))

## 100% PSA prepayment: rate up to 6% annual at 30 months
psa.speed <- 100  # 100% PSA
max.rate <- psa.speed/100*0.06
seasoned.month <- 30  # at 30 months, PSA says mortgages are seasoned
prepay.rate <- c(seq(max.rate/seasoned.month, max.rate, max.rate/seasoned.month),
                 rep(max.rate, n.peryr*T-seasoned.month))
prepay.monthly.survival <- (1-prepay.rate)^(1/n.peryr)
prepay.monthly.rate <- 1-prepay.monthly.survival

## In production code, this would be more elegant; however,
## a for loop shows the intuition better than other approaches
### Use fullword.variables for pool payments...
num.pmts <- n.peryr*T
principal.left <- c(principal.start, rep(0,num.pmts-1))
pmt.perperiod <- c(pmt.level, rep(0,num.pmts-1))
pmt.interest <- rep(0, num.pmts)
pmt.principal <- rep(0, num.pmts)
pmt.prepays <- rep(0, num.pmts)
### ... and use abbr.vars (abbreviated) for tranche payments
pmt.prin.a <- pmt.prin.b <- pmt.prin.c <- rep(0, num.pmts)
pmt.int.a <- pmt.int.b <- pmt.int.c <- pmt.int.z <- rep(0, num.pmts)
stop.loop <- FALSE
for (i in 1:num.pmts) {
    ## determine pool cashflows
    pmt.interest[i] <- principal.left[i]*r/n.peryr
    pmt.principal[i] <- pmt.perperiod[i] - pmt.interest[i]
    if (pmt.principal[i] > principal.left[i]) {
        ## do not repay more than principal remaining
        pmt.principal[i] <- principal.left[i]
        ## stop the loop; pool is paid off!
        stop.loop <- TRUE
    } else {
        ## do not prepay more than principal remaining after normal payment
        pmt.prepays[i] <- (principal.left[i]-pmt.principal[i])*prepay.monthly.rate[i]
        if ((pmt.principal[i] + pmt.prepays[i]) > principal.left[i]) {
            pmt.prepays[i] <- principal.left[i] - pmt.principal[i]
            ## stop the loop; pool is paid off!
            stop.loop <- TRUE
        }
    }
    ## allocate payments to tranches
    prin.to.allocate <- pmt.principal[i]+pmt.prepays[i]
    prinleft.a <- principal$a - sum(pmt.prin.a)
    prinleft.b <- principal$b - sum(pmt.prin.b)
    prinleft.c <- principal$c - sum(pmt.prin.c)
    ## Scale interest payments by fraction not repaid*interestbase
    ## Remaining interest will get allocated to principal repayment
    ## and then deferrred interest on the z tranche
    pmt.int.a[i] <- prinleft.a/principal$a*interestbase$a*r/n.peryr
    pmt.int.b[i] <- prinleft.b/principal$b*interestbase$b*r/n.peryr
    pmt.int.c[i] <- prinleft.c/principal$c*interestbase$c*r/n.peryr
    prin.to.allocate <- prin.to.allocate + pmt.interest[i] -
        pmt.int.a[i] - pmt.int.b[i] - pmt.int.c[i]
    ## A is first in line for principal (Andropov is the name to say)
    if (prinleft.a > 0) {
        pmt.prin.a[i] <- min(prinleft.a, prin.to.allocate)
        prin.to.allocate <- prin.to.allocate - pmt.prin.a[i]
    }
    ## The letter B is next in line (for principal, Brezhnev's dead so he'll do just fine)
    if (prinleft.b > 0 & prin.to.allocate > 0) {
        pmt.prin.b[i] <- min(prinleft.b, prin.to.allocate)
        prin.to.allocate <- prin.to.allocate - pmt.prin.b[i]
    }
    ## The letter C is next for principal (C is for Chernenko)
    if (prinleft.c > 0 & prin.to.allocate > 0) {
        pmt.prin.c[i] <- min(prinleft.c, prin.to.allocate)
        prin.to.allocate <- prin.to.allocate - pmt.prin.c[i]
    }
    ## Finally, if any cashflows are left, they go to the Z tranche
    if (prin.to.allocate > 0)
        pmt.int.z[i] <- prin.to.allocate

    ## prepare for next iteration of loop
    if (i < num.pmts) {
        principal.left[i+1] <- principal.left[i] - pmt.principal[i] - pmt.prepays[i]
        pmt.perperiod[i+1] <- pmt.perperiod[i]*prepay.monthly.survival[i]
    }

    if (stop.loop)
        break
}

areaplot(t,data.frame(pmt.int.c,pmt.int.b,pmt.int.a,
                      pmt.prin.a,pmt.prin.b,pmt.prin.c,pmt.int.z),
         col=c("green","yellow","lightblue","blue","orange","darkgreen","red"),
         ylab="", border=FALSE)
text(100, 150000, "A", cex=2, col="white")
text(210, 60000, "B", cex=2)
text(255, 40000, "C", cex=2, col="white")
text(310, 20000, "Z", cex=2)


S30AAJ Example Program Results

Black-Scholes-Merton formula
European Call :
  Spot       =  55.0000
  Volatility =  0.3000
  Rate       =  0.1000
  Dividend   =  0.0000

    Strike      Expiry  Option Price
    58.0000     0.7000  5.9198
    58.0000     0.8000  6.5506
    60.0000     0.7000  5.0809
    60.0000     0.8000  5.6992
    62.0000     0.7000  4.3389
    62.0000     0.8000  4.9379


library(dplyr)
library(readr)
library(forcats)
library(ggplot2)
library(causaleffect)
library(igraph)
library(tensorA)
source(glue::glue("{here::here()}/helper_functions.r"))
source(glue::glue("{here::here()}/get_expression.r"))
library(data.tree)
library(latex2exp)

g <- graph.formula(
  y -+ x
, y -+ z
, x -+ z
)
plot(g)

effect <- causal.effect(
  y = "y"
, x = "z"
, G = g
, primes = TRUE
, simp = TRUE
, prune = TRUE
, expr = FALSE
)
cat(get.expression(effect), "\n")

cat(get.operation(effect), "\n")
TeX(glue::glue("${get.expression(effect)}$"))

g <- graph.formula(
  smoke -+ tar
, tar -+ cancer
, hidden -+ smoke
, hidden -+ cancer
)
plot(g)

effect <- causal.effect(
  y = "cancer"
, x = "smoke"
, G = g
, primes = TRUE
, simp = TRUE
, prune = TRUE
, expr = FALSE
)
cat(get.expression(effect, primes = TRUE), "\n")

effect_tree <- convert_probability_to_data_tree(effect)

# UC Berkeley data

g <- graph.formula(
  Gender -+ Admit
, Dept -+ Gender
, Dept -+ Admit
)
plot(g)

effect <- causal.effect(
  y = "Admit"
, x = c("Gender")
, G = g
, primes = TRUE
, simp = TRUE
, prune = TRUE
, expr = FALSE
)
get.expression(effect)
effect_tree <- convert_probability_to_data_tree(effect)

data(UCBAdmissions)

UCBAdmissions_tensor <- UCBAdmissions %>% {
  out <- to.tensor(as.vector(.), dim(.), ndimnames = dimnames(.))
  dimnames(out) <- dimnames(.)
  return(out)
}
UCBAdmissions_tensor

UCBAdmissions_tensor %>% {
term_1 <- conditional_probability.tensor(
  .
, var_set = "Admit"
, cond_set = c("Gender", "Dept")
)
term_2 <- conditional_probability.tensor(
  .
, var_set = "Dept"
)
term_1 %e% term_2
}

margin.tensor(UCBAdmissions_tensor, i = c("Admit", "Gender", "Dept"))
UCBAdmissions_tensor %>% ftable

# Adapt the get.expression function to tensor operations
# Write tests for each of the possibilities:
# Just a single probability statement
# A single conditional probability statement
# A product of two distributions
# A einstien summation
# A division
# A remaining do() (throws error; unidentifiable)
# Something with primes in it
# An initial test to make sure it returns a function which acts on tensors, and
# throws a warning when the input tensor has the wrong indices


## --------------------
## --------------------
## --------------------
## This file contains the functions for implementing the Lee-Carter Model.
## --------------------
## --------------------
## --------------------

LC <- function(X, n.pc) {

    ## this function adopt codes from the demorgraphy package, X is the data matrix
    ## row is age group
    ## column is year

    ax <- apply(X, 1, mean, na.rm = TRUE) # ax is mean of X by column

    cX <- sweep(X, 1, ax) ## make sum(kt) = 0

    svd.mx <- svd(cX)

    kt <- matrix(NA, nrow = n.pc, ncol = ncol(X))

    bx <- matrix(NA, nrow = nrow(X), ncol = n.pc)

    for (i in seq(1, n.pc)) {
        sumu <- sum(svd.mx$u[, i])

        ## to make sum(bx)=1

        bx[, i] <- svd.mx$u[, i] / sumu

        kt[i, ] <- svd.mx$d[i] * svd.mx$v[, i] * sumu
    }

    fitted <- sweep(bx %*% kt, 1, -ax)
    svd_d <- svd(X)$d
    return(list(bx = bx, kt = kt, rowmean = ax, fitted = fitted, d = svd_d))
}

# predict the Lee-Carter model, Using RWWD (random walk with drift) model

LC.predict <- function(X, n.pred, n.pc) {
    tmp <- LC(X, n.pc = n.pc)

    kt.pred <- matrix(NA, nrow = n.pc, ncol = n.pred)

    for (i in seq(1, n.pc)) {
        rw.fit <- forecast::rwf(tmp$kt[i, ], drift = TRUE)

        kt.pred[i, ] <- tmp$kt[i, length(tmp$kt[i, ])] + seq(1, n.pred) * rw.fit$model$par$drift
    }

    return(sweep(tmp$bx %*% kt.pred, 1, -tmp$rowmean))
}

LC.forecast <- function(tnsr, n.pred, n.pc, year) {
    cs1 <- LC.predict(tnsr[1, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    c1 <- LC.predict(tnsr[2, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    rs1 <- LC.predict(tnsr[3, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    inf1 <- LC.predict(tnsr[4, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    ext1 <- LC.predict(tnsr[5, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    oth1 <- LC.predict(tnsr[6, , 1:(dim(tnsr)[3] - year)]@data, n.pred, n.pc)
    m_tensor <- array(NA, dim = c(6, 19, n.pred))

    m_tensor[1, , ] <- cs1
    m_tensor[2, , ] <- c1
    m_tensor[3, , ] <- rs1
    m_tensor[4, , ] <- inf1
    m_tensor[5, , ] <- ext1
    m_tensor[6, , ] <- oth1
    ###

    return(as.tensor(m_tensor))
}

LC.fit <- function(tnsr, n.pc, year) {
    cs1 <- LC(tnsr[1, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    c1 <- LC(tnsr[2, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    rs1 <- LC(tnsr[3, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    inf1 <- LC(tnsr[4, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    ext1 <- LC(tnsr[5, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    oth1 <- LC(tnsr[6, , 1:(dim(tnsr)[3] - year)]@data, n.pc)$fitted
    m_tensor <- array(NA, dim = c(6, 19, dim(tnsr)[3] - year))

    m_tensor[1, , ] <- cs1
    m_tensor[2, , ] <- c1
    m_tensor[3, , ] <- rs1
    m_tensor[4, , ] <- inf1
    m_tensor[5, , ] <- ext1
    m_tensor[6, , ] <- oth1
    ###

    return(as.tensor(m_tensor))
}

################# cross_validation

LC.cv <- function(tnsr, year, k = 5, leave_test = TRUE) {
    if (leave_test) {
        tnsr <- tnsr[, , 1:(dim(tnsr)[3] - year)]
    }
    ### training data
    train_ls <- list()
    for (i in 1:k) {
        train_ls[[i]] <- tnsr[, , 1:(dim(tnsr)[3] - i + 1 - year)]
    }
    ### validating data
    validate_ls <- list()
    for (i in 1:k) {
        validate_ls[[i]] <- tnsr[, , (dim(tnsr)[3] - i + 2 - year):(dim(tnsr)[3] - i + 1)]
    }
    ### record minMSE
    minMSE <- 999999
    mincomponent <- 1
    for (i in 1:19) {
        ### record each component statistics
        temp <- NULL
        for (j in 1:k) {
            temp <- c(temp, fnorm(lcforecast(train_ls[[j]], n.pred = year, n.pc = i, year = 0) - validate_ls[[j]]))
        }
        if (mean(temp) < minMSE) {
            minMSE <- mean(temp)
            mincomponent <- i
        }
    }
    return(list(optimal_component = mincomponent, min_MSE = minMSE))
}


# Calculate SD of monthly mean temperatures from CMIP5
# For 1986-2005 and 2081-2100

source('analysis/image.scale.r') # for plotting color bar on image
require(ncdf4)
require(RColorBrewer)
require(raster)

# read in rcp85 temperatures
infile <- nc_open('data/cmip5/tas_Amon_modmean_rcp85_ave.nc') # multi-model mean for each month 1861-2100. near-surface air.
	#print(infile)
	lst <- ncvar_get(infile, 'tas') # lst lon  x lat x time (144x72x2880)
	dim(lst)
	dimnames(lst) <- list(lon=1:144, lat=1:72, time=1:2880)
	dimnames(lst)[[1]] <- infile$var[['tas']]$dim[[1]]$vals # add lon
	dimnames(lst)[[2]] <- infile$var[['tas']]$dim[[2]]$vals # add lat
	dimnames(lst)[[3]] <- infile$var[['tas']]$dim[[4]]$vals # add time
	nc_close(infile)

infile <- nc_open('data/cmip5/tos_Omon_modmean_rcp85_ave.nc') # multi-model mean for each month 1861-2100. sea.
	#print(infile)
	sst <- ncvar_get(infile, 'tos') # lon  x lat x time (288x144x2880)
	dim(sst)
	dimnames(sst) <- list(lon=1:288, lat=1:144, time=1:2880)
	dimnames(sst)[[1]] <- infile$var[['tos']]$dim[[1]]$vals # add lon
	dimnames(sst)[[2]] <- infile$var[['tos']]$dim[[2]]$vals # add lat
	dimnames(sst)[[3]] <- infile$var[['tos']]$dim[[4]]$vals # add time
	nc_close(infile)

# Mask out ocean from tas
searast <- raster(t(!is.na(sst[,,1]))[ncol(sst):1,], xmn=0, xmx=360, ymn=-90, ymx=90)
landrast <- raster(t(!is.na(lst[,,1]))[ncol(lst):1,], xmn=0, xmx=360, ymn=-90, ymx=90)
seamask <- round(resample(searast, landrast, method='bilinear')) # includes areas 50% land as land (floor): 0 is land, 1 is ocean
seamask <- t(as.matrix(seamask)) # rearrange again to match lst
seamask <- seamask[,ncol(seamask):1]
seamask[seamask==1] <- NA # turn ocean to NA

lst2 <- lst
for(i in 1:dim(lst)[3]){
	lst2[,,i] <- lst[,,i] + seamask # turns ocean to NAs
}

# Detrend historical and future time-periods within each grid cell
dt <- function(x){
	if(all(!is.na(x))){
		resid(lm(x ~ I(1:length(x))))
	} else {
		return(rep(NA, length(x)))
	}
}
mohist1 <- (1986-1861)*12
mohist2 <- (2005-1861)*12+11
lstdthist <- apply(lst2[,,mohist1:mohist2], MARGIN=c(1,2), FUN=dt) # dimensions now time x lon x lat
sstdthist <- apply(sst[,,mohist1:mohist2], MARGIN=c(1,2), FUN=dt)

mofut1 <- (2081-1861)*12
mofut2 <- (2100-1861)*12+11
lstdtfut <- apply(lst2[,,mofut1:mofut2], MARGIN=c(1,2), FUN=dt)
sstdtfut <- apply(sst[,,mofut1:mofut2], MARGIN=c(1,2), FUN=dt)

# SD (seasonality)
lst_sdhist <- apply(lstdthist, MARGIN=c(2,3), FUN=sd)
sst_sdhist <- apply(sstdthist, MARGIN=c(2,3), FUN=sd)

lst_sdfut <- apply(lstdtfut, MARGIN=c(2,3), FUN=sd)
sst_sdfut <- apply(sstdtfut, MARGIN=c(2,3), FUN=sd)

# Plot of SD historical, SD future, and difference of SDs (tas)
zlims1 <- range(c(lst_sdhist, lst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
zlims2 <- range(lst_sdfut - lst_sdhist, na.rm=TRUE)
bks2 <- seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=1)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tas_cmip5_hist&fut_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdfut-lst_sdhist, col=cols2, breaks=bks2, main='(2081-2100) minus (1986-2005)')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()

# Plot of SD historical, SD future, and difference of SDs (tos)
zlims1 <- range(c(sst_sdhist, sst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
zlims2 <- range(sst_sdfut - sst_sdhist, na.rm=TRUE)
bks2 <- seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=1)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tos_cmip5_hist&fut_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdfut-sst_sdhist, col=cols2, breaks=bks2, main='(2081-2100) minus (1986-2005)')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()

# Plot of SD historical, SD future, and ratio of SDs (tas)
zlims1 <- range(c(lst_sdhist, lst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
zlims2 <- range(log(lst_sdfut/lst_sdhist), na.rm=TRUE)
bks2 <- seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=0.1)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tas_cmip5_hist-futratio_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), lst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(lst)[[1]]), y=as.numeric(dimnames(lst)[[2]]), log(lst_sdfut/lst_sdhist), col=cols2, breaks=bks2, main='log((2081-2100) / (1986-2005))')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()

# Plot of SD historical, SD future, and ratio of SDs (tos)
zlims1 <- range(c(sst_sdhist, sst_sdfut), na.rm=TRUE)
bks1 <- seq(floor(zlims1[1]), ceiling(zlims1[2]),by=1)
cols1 <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks1)-1)
#zlims2 <- range(log(sst_sdfut/sst_sdhist), na.rm=TRUE)
zlims2 <- c(-3,3) # force narrow
bks2 <- c(-30, seq(-ceiling(max(abs(zlims2))),ceiling(max(abs(zlims2))),by=0.1), 30)
cols2 <- colorRampPalette(brewer.pal(9, "RdBu"))(length(bks2)-1)
mais <- c(0.2, 0.3, 0.3, 0.1)

quartz(height=4, width=10)
# pdf(height=4, width=10, file='figures/seasonality_tos_cmip5_hist-futratio_map_rcp85.pdf')
layout(matrix(c(1,2,3,6,4,5), nrow=2, ncol=3, byrow=FALSE), heights=c(3,1))
par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdhist, col=cols1, breaks=bks1, main='1986-2005')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims1, col=cols1, breaks=bks1, horiz=TRUE, xlab='SD historical')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), sst_sdfut, col=cols1, breaks=bks1, main='2081-2100')

par(mai=mais)
image(x=as.numeric(dimnames(sst)[[1]]), y=as.numeric(dimnames(sst)[[2]]), log(sst_sdfut/sst_sdhist), col=cols2, breaks=bks2, main='(2081-2100) minus (1986-2005)')
	par(mar=c(3,1,1,1))
	image.scale(zlim=zlims2, col=cols2, breaks=bks2, horiz=TRUE, xlab='SD difference')

dev.off()


#' Shrinkage-mean-based Diagonal Linear Discriminant Analysis (SmDLDA) from
#' Tong, Chen, and Zhao (2012)
#'
#' Given a set of training data, this function builds the Shrinkage-mean-based
#' Diagonal Linear Discriminant Analysis (SmDLDA) classifier from Tong, Chen,
#' and Zhao (2012). The SmDLDA classifier incorporates a Lindley-type shrunken
#' mean estimator into the DLDA classifier from Dudoit et al. (2002). For more
#' about the DLDA classifier, see [lda_diag()].
#'
#' The DLDA classifier belongs to the family of Naive Bayes classifiers, where
#' the distributions of each class are assumed to be multivariate normal and to
#' share a common covariance matrix.
#'
#' The DLDA classifier is a modification to the well-known LDA classifier, where
#' the off-diagonal elements of the pooled sample covariance matrix are assumed
#' to be zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of `x`
#' contain the sample observations, and the columns contain the features for each
#' training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations belonging
#' to each class. Otherwise, `prior` should be a vector with the same length
#' as the number of classes in `y`. The `prior` probabilities should be
#' nonnegative and sum to one.
#'
#' @export
#'
#' @inheritParams lda_diag
#' @return `lda_shrink_mean` object that contains the trained SmDLDA classifier
#'
#' @references Tong, T., Chen, L., and Zhao, H. (2012), "Improved Mean
#' Estimation and Its Application to Diagonal Discriminant Analysis,"
#' Bioinformatics, 28, 4, 531-537.
#' \url{http://bioinformatics.oxfordjournals.org/content/28/4/531.long}
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]
#' smdlda_out <- lda_shrink_mean(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(smdlda_out, penguins[pred_rows, -1], type = "class")
#'
#' smdlda_out2 <- lda_shrink_mean(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(smdlda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
lda_shrink_mean <- function(x, ...) {
  UseMethod("lda_shrink_mean")
}

#' @rdname lda_shrink_mean
#' @export
lda_shrink_mean.default <- function(x, y, prior = NULL, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x = x, y = y, prior = prior, pool = TRUE,
                        est_mean = "tong")

  # Creates an object of type 'lda_shrink_mean'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "lda_shrink_mean")

  obj
}

#' @inheritParams lda_diag
#' @rdname lda_shrink_mean
#' @importFrom stats model.frame model.matrix model.response
#' @export
lda_shrink_mean.formula <- function(formula, data, prior = NULL, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- lda_shrink_mean.default(x = x, y = y, prior = prior)
  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a SmDLDA classifier object.
#'
#' Summarizes the trained SmDLDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.lda_shrink_mean <- function(x, ...) {
  cat("Shrinkage-Mean-Based Diagonal LDA\n\n")
  print_basics(x, ...)
  invisible(x)
}

#' SmDLDA prediction of the class membership of a matrix of new observations.
#'
#' The SmDLDA classifier is a modification to LDA, where the off-diagonal
#' elements of the pooled sample covariance matrix are set to zero.
#'
#' @rdname lda_shrink_mean
#' @export
#' @inheritParams predict.lda_diag

predict.lda_shrink_mean <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / object$var_pool) + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- replicate(n=object$num_groups, object$var_pool, simplify=FALSE)
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)

  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}