# ......................................................................................
# .................... Cvičení 9. Intervalové odhady (jednoho výběru)...................
# ............... Michal Béreš, Martina Litschmannová, Veronika Kubíčková...............
# ......................................................................................

# 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

#  Demonstrace na úvod - co je to intervalový odhad? ####
# Uvažujme náhodnou veličinu z normálního rozdělení se střední hodnotou $\mu$ a
# směrodatnou odchylkou $\sigma$. Budeme pracovat s výběry z této náhodné veličiny a
# pomoci jich se budeme snažit odhadnout střední hodnutu rozdělení (zde známe její
# skutečnou hodnotu, ale v praxi je její hodnota neznámá).

n = 30        # velikost výběru
mu = 100      # střední hodnota
sigma = 10    # směr. odchylka

# simulace náhodného výběru ze zadané náhodné veličiny
vyber = rnorm(n = n, mean = mu, sd = sigma)

X = mean(vyber) # výběrový průměr jako bodový odhad
S = sd(vyber)   # výběrová směr. odch.
X
S

# Pro přehlednost si můžeme výběr vizualizovat.

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

hist(vyber)
boxplot(vyber)

# ** Samotné sestrojení Intervalového odhadu pomocí výběrové charakteristiky ####
# Použijeme tuto výběrovou charakteristiku: (předpokládáme, že neznáme žádné skutečné
# parametry rozdělení, pouze to, že je normální)
# $Y=\frac{\bar X - \mu}{S}\sqrt{n} \sim t_{n-1}$
# Jelikož, známe rozdělení Y jsme schopni napočítat $a$ a $b$ v následujícím výrazu:
# $P(a<Y<b)\geq 1 - \alpha$
# - $\alpha$ nazýváme hladinou významnosti (pravděpodobnost, že hledaná hodnota leží
# mimo náš interval)
# - $1-\alpha$ nazýváme spolehlivost intervalového odhadu

# $a$ a $b$ zvolíme tak aby byly v pravděpodobnosti symetrické, tzn.:
# - $P(Y<a)\leq \alpha / 2 \rightarrow a=t_{\alpha / 2;n-1}$
# - $P(b<Y)\leq \alpha / 2 \rightarrow P(Y\leq b)\geq 1 - \alpha / 2 \rightarrow
# b=t_{1-\alpha / 2;n-1}$

# maximální pravděpodobnost s jakou připouštíme aby
# skutečná st. hod. ležela mimo sestrojený interval
alpha = 0.05

# příslušné kvantily studentova rozdělení
t_low = qt(alpha/2, df = n-1)
t_high = qt(1 - alpha/2, df = n-1)

t_low
t_high

# Dále jen doplníme do výrazu a upravíme:
# $P(t_{\alpha / 2;n-1}<\frac{\bar X - \mu}{S}\sqrt{n}<t_{1-\alpha / 2;n-1})\geq 1 -
# \alpha$
# $P(\bar X - t_{1-\alpha / 2;n-1}\frac{S}{\sqrt{n}}<\mu<\bar X - t_{\alpha /
# 2;n-1}\frac{S}{\sqrt{n}})\geq 1 - \alpha$

I_dolni = X - t_high*S/sqrt(n)
I_horni = X - t_low*S/sqrt(n)
paste("P(", I_dolni, " < µ < ", I_horni, ") ≥ ", 1-alpha)

# Tento konkrétní odhad, můžeme dostat také pomocí Rkovské funkce t.test:

t.test(vyber, alternative = 'two.sided', conf.level = 1-alpha)$conf.int

# ** Otestování intervalového odhadu na více výběrech ####

pocet_pokusu = 10000 # počet výběrů

n = 30             # velikost výběru
mu = 100           # střední hodnota
sigma = 10         # směrodat. odchyl.

alpha = 0.05        # hladina významnosti

# příslušné kvantily studentova rozdělení
t_low = qt(alpha/2, df = n-1)
t_high = qt(1 - alpha/2, df = n-1)

# vykreslení skutečné střední hodnoty
plot(c(1, pocet_pokusu), c(mu, mu), type = 'l', ylim = c(90,110))

pocet_neuspesnych = 0
# cyklus přes jednotlivé výběry
for(i in 1:pocet_pokusu){
    vyber = rnorm(n = n, mean = mu, sd = sigma)
    X = mean(vyber)
    S = sd(vyber)
    I_dolni = X - t_high*S/sqrt(n)
    I_horni = X - t_low*S/sqrt(n)

    # zvolíme barvu vykreslení, podle toho zda IO obsahuje stř. hod.
    if( I_dolni<mu & mu<I_horni){
        barva = "blue"
    }else{
        barva = "red"
        pocet_neuspesnych = pocet_neuspesnych + 1
    }
    # vykreslíme IO jako vertikální čáru
    lines(c(i, i), c(I_dolni, I_horni), col=barva)
}
paste('alpha = ', alpha, ', relativní četnost něúspěšných IO = ',
      pocet_neuspesnych/pocet_pokusu)

# vrátím šířku na standardní velikost
options(repr.plot.width = 8) # šířka grafů v Jupyteru

#  Typy intervalových odhadů ####
# (Ukázky na odhadu střední hodnoty dat z normálního rozdělení.)
# * Dolní/Levostranný IO ####
# - $P(M_D^* < \mu) = 1-\alpha$
# - v Rku **alternative="greater"**

vyber = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05
t.test(vyber, alternative = 'greater', conf.level = 1-alpha)$conf.int

# * Horní/Pravostranný IO ####
# - $P(\mu < M_H^*) = 1-\alpha$
# - v Rku **alternative="less"**

vyber = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05
t.test(vyber, alternative = 'less', conf.level = 1-alpha)$conf.int

# * Oboustranný IO ####
# - $P(M_D < \mu < M_H) = 1-\alpha$
# - v Rku **alternative="two.sided"**

vyber = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05
t.test(vyber, alternative = 'two.sided', conf.level = 1-alpha)$conf.int

#  Přehled parametrů výběru a jejich bodových/intervalových odhadů ####
# Běžně máme k dispozici více konstrukcí IO (funkcí v Rku které to za nás udělají), ale
# každá konstrukce má jiné požadavky na data a vytváří různě "kvalitní" (ve smyslu
# velikosti IO) odhady. My budeme vždy vybírat "nejkvalitnější" IO, který **má splněny**
# předpoklady použití.
# Pořadí různých IO níže bude vždy od "nejlepšího" po nejrobustnější.
# * Míry polohy jednoho výběru ####
# 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 IO ####
# - odhadujeme střední hodnotu - bodový odhad je výběrový průměr
# - 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))

vyber = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05

# exploračně test normality
# library(moments) - tomuto se můžeme vyhnout voláním moments::
# je to bezpečnější - máme jistotu, že voláme funkci z tohoto balíčku
moments::skewness(vyber)
moments::kurtosis(vyber) - 3
qqnorm(vyber)
qqline(vyber)

# exaktně test normality dat
shapiro.test(vyber)$p.value
# vysledná p-hodnota musím být větší než hl. výz. (př. 0.05)

# bodový odhad
mean(vyber)
# IO
t.test(vyber, alternative = 'two.sided', conf.level = 1-alpha)$conf.int

# *** b) Wilcoxnův test IO ####
# - odhadujeme medián - bodový odhad je výběrový 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)"
# - funkce v Rku vyžaduje dodatečný parametr (conf.int = TRUE)

vyber = runif(n = 30, min = 80, max = 120)
alpha = 0.05

# exploračně
moments::skewness(vyber)
hist(vyber, breaks = 5)

# exaktně: test symetrie
#install.packages("lawstat")
library(lawstat)
symmetry.test(vyber,boot=FALSE)$p.value
# vysledná p-hodnota musím být větší než hl. výz. (př. 0.05)

# bodový odhad
quantile(vyber, probs = 0.5)
median(vyber)
# IO
wilcox.test(vyber, alternative = 'two.sided', conf.level = 1-alpha,
            conf.int = TRUE)$conf.int

# *** c) znaménkový test test IO ####
# - odhadujeme medián - bodový odhad je výběrový medián
# - výběr většího rozsahu (>10)
# - funkce v Rku vyžaduje dodatečný parametr (conf.int = TRUE)
# - 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

vyber = rexp(n = 30, rate = 1/100)
alpha = 0.05

# skutečný medián
qexp(p = 0.5, rate = 1/100)

# bodový odhad
# quantile(vyber, probs = 0.5)
median(vyber)
# IO
# install.packages("BSDA")
library(BSDA)
SIGN.test(vyber, alternative = 'two.sided', conf.level = 1-alpha,
          conf.int = TRUE)$conf.int

# * Míry variability jednoho výběru ####
# 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.
# *** IO směrodatné odchylky ####
# - odhadujeme směrodatnou odchylku - bodovým odhadem je výběrový směrodatná odchylka
# - 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, dává výpočet rozptylu - nutná odmocnina výsledku

vyber = rnorm(n = 30, mean = 100, sd = 10)
alpha = 0.05

# exploračně test normality
moments::skewness(vyber)
moments::kurtosis(vyber) - 3
qqnorm(vyber)
qqline(vyber)

# exaktně test normality dat
shapiro.test(vyber)$p.value
# vysledná p-hodnota musím být větší než hl. výz. (př. 0.05)

# bodový odhad
sd(vyber)
# IO
#install.packages("EnvStats")
library(EnvStats)
sqrt(varTest(vyber, alternative = 'two.sided', conf.level = 1-alpha)$conf.int)

# Přidáme si ruční výpočet:
# - vycházíme ze statistiky: $\frac{S^2}{\sigma^2}(n-1) \sim \chi^2_{n-1}$
# - Horní mez:
#     - $P(\frac{S^2}{\sigma^2}(n-1) < \chi^2_{\alpha /2, n-1}) = \alpha /2$
#     - $P(\frac{S^2}{\chi^2_{\alpha /2, n-1}}(n-1) < \sigma^2 ) = \alpha /2$
# - Dolní mez:
#     - $P(\frac{S^2}{\sigma^2}(n-1) > \chi^2_{1-\alpha /2, n-1}) = \alpha /2$
#     - $P(\frac{S^2}{\chi^2_{1-\alpha /2, n-1}}(n-1) > \sigma^2 ) = \alpha /2$
# - Dohromady: $P(\frac{S^2}{\chi^2_{1-\alpha /2, n-1}}(n-1) < \sigma^2
# <\frac{S^2}{\chi^2_{\alpha /2, n-1}}(n-1)) = 1 - \alpha$

# ruční výpočet
alpha = 0.05
n = 30
S = sd(vyber)

hor_q = qchisq(1 - alpha/2, n-1)
dol_q = qchisq(alpha/2, n-1)
hor_q
dol_q

sqrt(S^2*(n-1)/dol_q)
sqrt(S^2*(n-1)/hor_q)

# * Pravděpodobnost výskytu u jednoho výběru ####
# *** IO pravděpodobnosti ####
# - odhadujeme pravděpodobnost - bodový odhad je relativní četnost
# - 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í
# - Waldův - z výběrových charakteristik

pi = 0.3
n = 60
alpha = 0.05
vyber = runif(n = n, min = 0, max = 1) < pi

# ověření předpokladů
p = mean(vyber)
p
9/(p*(1-p))

# bodový odhad
p
# intervalový odhad Clopperův - Pearsonův
celk_pocet = length(vyber)
pocet_poz = sum(vyber)
binom.test(x = pocet_poz, n = celk_pocet, alternative = 'two.sided',
           conf.level = 1 - alpha)$conf.int

# Intervalový odhad Waldův
dol_q = qnorm(alpha/2)
hor_q = qnorm(1-alpha/2)

p - hor_q*sqrt(p*(1-p)/n)   # dolní mez IO
p - dol_q*sqrt(p*(1-p)/n)       # horní mez IO

# Výpočet 11 nejčastěji používaných intervalů spolehlivosti param. bin. rozdělení
# pomocí balíčku binom
# install.packages("binom")
library(binom)
binom.confint(n = celk_pocet, x = pocet_poz)

#  Příklady ####
# * Příklad 1. ####
# Při kontrolních zkouškách 16 žárovek byl stanoven odhad střední hodnoty $\bar x$ = 3
# 000 hodin a směrodatné odchylky s = 20 hodin jejich životnosti. Za předpokladu,že
# životnost žárovky má normální rozdělení, určete 90% intervalový odhad pro parametry µ
# a σ

# Odhadujeme stř.hodnotu a směr.odchylku životnosti žárovek
# Součástí zadání je informace o normalitě dat

n = 16         # rozsah souboru
x.bar = 3000   # hodin.... průměr (bodový odhad střední hodnoty)
s = 20         # hodin.... výběrová směrodatná odchylka (bodový odhad sm. odchylky)
alpha = 0.1    # hladina významnosti (spolehlivost 1-alpha = 0.9)

# Oboustranný intervalový odhad střední hodnoty
dol_q = qt(alpha/2,n-1)
hor_q = qt(1 - alpha/2,n-1)

x.bar - hor_q*s/sqrt(n)   # dolní mez IO
x.bar - dol_q*s/sqrt(n)   # horní mez IO

# Oboustranný intervalový odhad směrodatné odchylky
dol_q = qchisq(alpha/2,n-1)
hor_q =  qchisq(1 - alpha/2,n-1)

sqrt((n-1)*s^2/hor_q)      # dolní mez IO
sqrt((n-1)*s^2/dol_q)      # horní mez IO

# * Příklad 2. ####
# Hloubka moře se měří přístrojem, jehož systematická chyba je rovna nule a náhodné
# chyby mají normální rozdělení se směrodatnou odchylkou 20 m. Kolik nezávislých měření
# je třeba provést,aby s pravděpodobností 95 % stanovila hloubku s chybou menší než 10
# m?

# Určujeme odhad potřebného rozsahu výběru (počtu potřebnych měření)

# Předpokládáme normalitu dat, se známým rozpylem (dle zadání)

sigma = 20   # metrů .... známá směrodatná odchylka
alpha = 0.05 # hladina významnosti (spolehlivost 1-alpha = 0.95)
delta = 10   # metrů ... přípustná chyba měření

# Odhad rozsahu výběru
# Y = delta/sigma*sqrt(n) ~ N(0,1), delta = X-mu
# P(Y > Z_(1-alpha/2)) = alpha/2

(qnorm(1 - alpha/2)*sigma/delta)^2

# * Příklad 3. ####
# Úkolem je určit průměrnou hladinu cholesterolu v séru v určité populaci mužů. V
# náhodném výběru (pocházejícím z normálního rozdělení ) 25 mužů je výběrový průměr 6,3
# mmol/l a výběrová směrodatná odchylka 1,3 mmol/l.

# Odhadujeme střední hladinu cholesterolu v séru
# Předpokládáme normalitu dat (dle zadání)

n = 25        # rozsah souboru
x.bar = 6.3   # mmol/l .... průměr (bodový odhad střední hodnoty)
s = 1.3       # mmol/l .... výběrová směr. odchylka (bodový odhad sm. odchylky)
alpha = 0.05  # hladina významnosti (spolehlivost 1-alpha = 0.95)

# Oboustranný intervalový odhad střední hodnoty
dol_q = qt(alpha/2, n-1)
hor_q = qt(1 -alpha/2, n-1)

x.bar - hor_q*s/sqrt(n)   # dolní mez IO
x.bar - dol_q*s/sqrt(n)   # horní mez IO

# * Příklad 4. ####
# Předpokládejme, že v náhodném výběru 200 mladých mužů má 120 z nich vyšší než
# doporučenou hladinu cholesterolu v séru. Určete 95% interval spolehlivosti pro
# procento mladých mužů
# s vyšší hladinou cholesterolu v populaci.

# Odhadujeme podíl mužů s vyšší hladinou cholesterolu v celé populaci,
# tj. pravděpodobnost,že náhodně vybraný muž bude mít vyšší hladinu cholesterolu

n = 200  # rozsah souboru
x = 120  # počet "úspěchů"
p = x/n  # relativní četnost (bodový odhad pravděpodobnosti)
p
alpha = 0.05 # hladina významnosti (spolehlivost 1-alpha = 0.95)

# Ověření předpokladů
9/(p*(1-p))

# Oboustranný Clopperův - Pearsonův (exaktní) int.ý odhad param. binom. rozdělení
binom.test(x,n,alternative="two.sided",conf.level=0.95)$conf.int

## Waldův (asymptotický) odhad (z-statistika) - aprox. normálním rozdělením dle CLV
dol_q = qnorm(alpha/2)
hor_q = qnorm(1-alpha/2)

p - hor_q*sqrt(p*(1-p)/n)   # dolní mez IO
p - dol_q*sqrt(p*(1-p)/n)       # horní mez IO

# * Příklad 5. ####
# V rámci výzkumné studie pracujeme s náhodným výběrem 70 žen z české populace. U každé
# z žen byl změřen hemoglobin s přesností 0,1 g/100 ml. Naměřené hodnoty jsou v uvedeny
# v souboru Hemoglobin.xls. Nalezněte 95% intervalové odhady směrodatné odchylky a
# střední hodnoty hemoglobinu v populaci českých žen. (Normalitu ověřte na základě
# exploračních grafů.)

## Odhadujeme střední hodnotu a směrodatnou odchylku hemoglobinu v séru

## Načtení dat z xlsx souboru (pomoci balíčku readxl)
library(readxl)
hem = read_excel("data/intervalove_odhady.xlsx",
                  sheet = "Hemoglobin")
colnames(hem) = "hodnoty"
head(hem)

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

# Data neobsahují odlehlá pozorování.
summary(hem$hodnoty)
sd(hem$hodnoty)

# Ověření normality - exploračně
qqnorm(hem$hodnoty)
qqline(hem$hodnoty)

moments::skewness(hem$hodnoty)
moments::kurtosis(hem$hodnoty) - 3
# Šikmost i špičatost odpovídá norm. rozdělení.

# ověření normality: exaktně - test normality.
# Známe-li testování hypotéz, ověříme Shapirovým . Wilkovým testem.
shapiro.test(hem$hodnoty)$p.value
# Na hl. významnosti 0.05

# 95% oboustranný intervalový odhad střední hodnoty
mean(hem$hodnoty)
t.test(hem$hodnoty, altarnative="two.sided", conf.level=0.95)$conf.int

## 95% oboustranný intervalový odhad směrodatné odchylky
library(EnvStats)
sd(hem$hodnoty)

sqrt(varTest(hem$hodnoty, alternative = "two.sided", conf.level = 0.95)$conf.int)

# * Příklad 6. ####
# Jaký musí být počet pozorování, jestliže chceme s pravděpodobností 0,95 stanovit
# průměrnou hodnotu hemoglobinu u novorozenců s chybou nejvýše 1,0 $g/l$. Populační
# rozptyl hodnot se
# odhaduje hodnotou 46,0 $g^2/l^2$.

# Určujeme odhad potřebného rozsahu výb. (počtu novorozenců, které musíme testovat)

# Předpokládáme normalitu dat, bez tohoto předpokladu je příklad neřešitelný

sigma = sqrt(46)  # g/l .... známá směrodatná odchylka
alpha = 0.05      # hladina významnosti (spolehlivost 1-alpha = 0.95)
delta = 1         # g/l ... přípustná chyba měření

# Odhad rozsahu výběru
# Y = delta/sigma*sqrt(n) ~ N(0,1), delta = X-mu
# P(Y > Z_(1-alpha/2)) = alpha/2

(qnorm(1 - alpha/2)*sigma/delta)^2

# * Příklad 7. ####
# V datovém souboru pr7.xlsx naleznete měření hluku způsobeného větrákem počítače [dB].
# Spočtěte 95% intervalový odhad průměrného hluku a 95% intervalový odhad variability
# hluku.

library(readxl)
# načtení dat
data = read_excel("data/pr7.xlsx")
head(data)

length(data$dB)

# vizualizace
pom = boxplot(data$dB)

# odstranění OP
data_op = data
data_op$dB[data_op$dB %in% pom$out] = NA
data_op = na.omit(data_op)
boxplot(data_op$dB)

# test normality dat exploračně
moments::skewness(data_op$dB)
moments::kurtosis(data_op$dB) - 3

qqnorm(data_op$dB)
qqline(data_op$dB)

# test normality exaktně
shapiro.test(data_op$dB)$p.value

# bodový a intervalový odhad střední hodnoty
mean(data_op$dB)

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

# bodový a intervalový odhad směrodatné odchylky
sd(data_op$dB)

sqrt(varTest(data_op$dB,alternative = "two.sided", conf.level = 0.95)$conf.int)

# * Příklad 8. ####
# V datovém souboru pr8.xlsx naleznete měření doby do poruchy elektrické součástky [h].
# Spočtěte 99% intervalový odhad průměrné životnosti daného typu součastky.

library(readxl)
# načtení dat
data = read_excel("data/pr8.xlsx")
head(data)

length(data$cas_h)

# vizualizace a ověření OP
boxplot(data$cas_h)

hist(data$cas_h)

# test normality dat exploračně
moments::skewness(data$cas_h)
moments::kurtosis(data$cas_h) - 3

qqnorm(data$cas_h)
qqline(data$cas_h)

# test normality exaktně
shapiro.test(data$cas_h)$p.value

# test symetrie exploračně
moments::skewness(data$cas_h)
hist(data$cas_h)

# exaktně: test symetrie
# install.packages("lawstat")
library(lawstat)
symmetry.test(data$cas_h,boot=FALSE)$p.value
# vysledná p-hodnota musím být větší než hl. výz. (př. 0.05)

# bodový a intervalový odhad mediánu
median(data$cas_h)
# IO
# install.packages("BSDA")
alpha = 0.01
library(BSDA)
SIGN.test(data$cas_h, alternative = 'two.sided', conf.level = 1-alpha,
          conf.int = TRUE)$conf.int

sd(data$cas_h)


compute_π <- function(trials) {
    inside <- 0.0
    for (i in 1:trials) {
        point <- runif(2)
        inside <- inside + (sum(point^2) <= 1.0)
    }
    return(4.0*inside/trials)
}

args = commandArgs(trailingOnly=TRUE)
if(length(args) < 1) {
    error("must provide number of trials")
}
trials = as.integer(args[1])
set.seed(2018)

start.time <- Sys.time()
invisible(compute_π(trials))
stop.time <- Sys.time()
cat("First invocation: ", stop.time - start.time, "s\n")

start.time <- Sys.time()
π <- compute_π(trials)
stop.time <- Sys.time()
cat("Second invocation:", stop.time - start.time, "s\n")

cat("π ≈ ", π, "\n")


#############################################
# Part i
n = 200
p = 0.3
rho = -0.3

# subfunction needed to generate data
calcbij = function(rho,i){
  a = ((1-4*rho*rho)^0.5-1)/(2*rho)
  j = i-1
  bi = (a^(1:j) - a^(-(1:j)))/(a^-i - a^(i))
  return(bi)
}

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataPW = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    bi = calcbij(rho,i)
    prob = p + sum(bi*(dat[1:j]-p))
    if(prob < 0) prob = 0.0001
    if(prob > 1) prob = 0.9999
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataPW(n,p,rho)
}
write(t(x),"p.30_pair.neg30_n200_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part ii
n = 600
p = 0.3
rho = -0.3

# subfunction needed to generate data
calcbij = function(rho,i){
  a = ((1-4*rho*rho)^0.5-1)/(2*rho)
  j = i-1
  bi = (a^(1:j) - a^(-(1:j)))/(a^-i - a^(i))
  return(bi)
}

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataPW = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    bi = calcbij(rho,i)
    prob = p + sum(bi*(dat[1:j]-p))
    if(prob < 0) prob = 0.0001
    if(prob > 1) prob = 0.9999
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataPW(n,p,rho)
}
write(t(x),"p.30_pair.neg30_n600_r100.txt",ncol=n)   # each row in this file is a different simulated song


"
Написать формулу получения 10 случайных целых чисел из диапазона (min = -7, max = 28
с помощью функции runif(),
не используя при ее вызове задания минимального и максимального значений.
"
{
checker <- function(n,min,max){
  return(floor((runif(n) * ((max - min) + 1)) + min))
}

n <- 10
min <- -7
max <- 28
print(checker(n,min,max))

}


#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Full Investment Constraints
cset.sum <- function(returns, sum=1){
  p = ncol(returns)
  constaint.sum <- rep(1,p)
  A = cbind(constaint.sum) # Constraint matrix
  colnames(A) <- "c.sum"
  b = sum                  # Constraint bound
  meq = 1
  # cset.lo = constraints(A,b,meq)
  return(list(A=A,b=b,meq=meq,cname="cset.sum"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Long-Only Constraints
cset.lo <- function(returns){
p = ncol(returns)
A = diag(rep(1,p)) # Constraint matrix
colnames(A) <- paste("c.long.only",1:ncol(A),sep="")
b = c(rep(0,p))                   # Constraint bound
meq = 0
# cset.lo = constraints(A,b,meq)
return(list(A=A,b=b,meq=meq,cname="cset.lo"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Box Constraints
cset.box <- function(returns,upper,lower){
p = ncol(returns)

if(length(upper)==1)
  upper <- rep(upper, p)

if(length(lower)==1)
  lower <- rep(lower, p)

constraint.box <-cbind(diag(rep(1,p)),diag(rep(-1,p)))
A = cbind(constraint.box)
colnames(A) <- paste("c.box",
                     c(paste(".low",rep(1:(ncol(constraint.box)/2)),sep=""),
                     paste(".up",rep(1:(ncol(constraint.box)/2)),sep="")),sep="")
b = c(lower,-upper)
meq = 0
# cset.box = constraints(A,b,meq)
return(list(A=A,b=b,meq=meq,cname="cset.box"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Group Constraints
cset.groups <- function(returns=returns8,
                        group=c(1,1,1,2,3,3,4,4),
                        upper.group=rep(0.2,4),
                        lower.group=rep(-0.2,4)){
p = ncol(returns)

if(length(upper.group)==1)
  upper.group <- rep(upper.group, length(unique(group)))

if(length(lower.group)==1)
  lower.group <- rep(lower.group, length(unique(group)))

if(!all(length(group)==p,length(upper.group)==length(unique(group)), length(lower.group)==length(unique(group))))
  stop("any of the length of group/upper/lower bounds is not equal to the number of assets")

if(length(upper.group)==1)
  rep(upper.group, length(group))

if(length(lower.group)==1)
  rep(lower.group, length(group))

gnum <- length(unique(group))
glist <- lapply(unique(group),function(x) which(x == group))
names(glist) <- unique(group)
Ag <- t(sapply(glist, function(x) {
  re <- rep(0,p)
  re[x] <- 1
  re}))
Atp = rbind(Ag,-Ag)
constraint.groups = t(Atp)
A <- cbind(constraint.groups)
colnames(A) <-  paste("c.groups",
                      c(paste(".low",rep(1:(ncol(constraint.groups)/2)),sep=""),
                      paste(".up",rep(1:(ncol(constraint.groups)/2)),sep="")),sep="")
bglo = c(lower.group)
bgup = c(upper.group)
b = c(bglo,-bgup)
meq = 0
# cset.groups = constraints(A,b,meq)
return(list(A=A,b=b,meq=meq,cname="cset.groups"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Turnover Constraints

cset.turnover <- function(returns,toc,w.initial){
	p = ncol(returns)
	constraint.turnover <- c(rep(0,p),rep(-1,p),rep(1,p))
#	constraint.weights.initial <- rbind(diag(p),matrix(0,ncol=p,nrow=p*2))
#	constraint.weights.finalsum <- c(rep(1,p),rep(0,2*p))
	constraint.weights.initial <- rbind(diag(1,p),diag(-1,p),diag(-1,p))
	constraint.weights.positive <-
			rbind(matrix(0,ncol=2*p,nrow=p),diag(2*p))
	temp.index <- (p*3-p+1):(p*3)
	#need to flip sign for w_sell
	constraint.weights.positive[temp.index,]<-
			constraint.weights.positive[temp.index,]*-1

	A <- cbind(constraint.weights.initial,
			constraint.turnover, constraint.weights.positive)
	colnames(A) <- c(paste("c.winit",1:p,sep=""),
			"c.turnover",
			paste("c.wpos",1:ncol(constraint.weights.positive),sep=""))
	b <- c(w.initial,-toc,rep(0,2*p))
	meq <- p+1
	return(list(A=A,b=b,meq=meq,cname="cset.turnover"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Turnover Constraints made by hobbs
cset.turnover.hobbs <- function(returns,toc,w.initial){
	p = ncol(returns)
	constraint.turnover <- c(rep(0,p),rep(-1,p),rep(1,p))
	constraint.weights.initial <- rbind(diag(p),matrix(0,ncol=p,nrow=p*2))
	constraint.weights.positive <-
			rbind(matrix(0,ncol=2*p,nrow=p),diag(2*p))
	temp.index <- (p*3-p+1):(p*3)
	#need to flip sign for w_sell
	constraint.weights.positive[temp.index,]<-
			constraint.weights.positive[temp.index,]*-1

	A <- cbind(constraint.weights.initial,
			constraint.turnover, constraint.weights.positive)
	colnames(A) <- c( paste("c.winit",1:ncol(constraint.weights.initial),sep=""),
			"c.turnover",
			paste("c.wpos",1:ncol(constraint.weights.positive),sep=""))
	b <- c(w.initial,-toc,rep(0,2*p))
	meq <- p

	return(list(A=A,b=b,meq=meq,cname="cset.turnover"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

#Proportional Cost Constraints
cset.propcost<- function(returns, ptc,w.initial){
  p = ncol(returns)
  dvec <- rep(0,p*3) #no linear part in this problem
  #left hand side of constraints
  if(length(ptc)==1){
    ptc = rep(ptc,p)
  }
  if(length(ptc)!=p){
    stop("ptc must either be a single value, or the same length as the number of assets")
  }

  constraint.sum.prop <- c(rep(1,p),1+ptc,(1-ptc))
  constraint.weights.initial <- rbind(diag(p),matrix(0,ncol=p,nrow=p*2))
  constraint.weights.positive <-
    rbind(matrix(0,ncol=2*p,nrow=p),diag(2*p))
  temp.index <- (p*3-p+1):(p*3)
  #need to flip sign for w_sell
  constraint.weights.positive[temp.index,]<-
  constraint.weights.positive[temp.index,]*-1
  #put left hand side of constraints into constraint matrix
  A <- cbind(constraint.sum.prop, constraint.weights.initial,
             constraint.weights.positive)
  colnames(A) <- c("c.sum.prop",
                   paste("c.winit",1:ncol(constraint.weights.initial),sep=""),
                   paste("c.wpos",1:ncol(constraint.weights.positive),sep=""))
  #right hand side of constraints in this vector
  b <- c(1, w.initial,rep(0,2*p))
  n.eq = 1+ p
  return(list(A=A,b=b,meq=n.eq,cname="cset.propcost"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Target MU Constraints
cset.mu.target <- function(returns, mu.target){
  p = ncol(returns)
  mu = apply(returns,2, mean)
  A = cbind(mu)
  colnames(A) <- "c.mu.target"
  b = mu.target
  meq = 1
  return(list(A=A,b=b,meq=meq,cname="cset.mu.target"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

cset.fixed <- function(returns, fixed.cost, wmax, wmin){

  # TBA
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Modify constaints when turnover kicks in
turnover.hobbs.modify <- function(cset=cset.i){
  switch(cset$cname,
          "cset.sum" = {
            cset.new <- cset
            cset.new$A <- rbind(cset$A,cset$A,cset$A)
            colnames(cset.new$A) <- colnames(cset$A)
            cset.new$b <- cset$b
            cset.new$meq <- cset$meq
            cset.new
          },

         "cset.lo" = { #may not be needed
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.box" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.groups" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

        "cset.mu.target" = {
          cset.new <- cset
          cset.new$A <- rbind(cset$A,cset$A,cset$A)
          colnames(cset.new$A) <- colnames(cset$A)
          cset.new$b <- cset$b
          cset.new$meq <- cset$meq
          cset.new
        }
      )

}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Modify constaints when turnover kicks in
turnover.modify <- function(cset=cset.i){

	makenullmat <- function(A){matrix(0,nrow=nrow(A),ncol=ncol(A))}

	switch(cset$cname,
			"cset.sum" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.lo" = { #may not be needed
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.box" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.groups" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.mu.target" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			}
	)

}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Modify constaints when propcost kicks in
propcost.modify <- function(cset=cset.i){
  switch(cset$cname,
         "cset.sum" = {
           stop("sum constraint are not combinable with propcost constraint")
         },

         "cset.lo" = { #may not be needed
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.box" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.groups" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.mu.target" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)+1
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b+1
           cset.new$meq <- cset$meq
           cset.new
         }
  )

}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Combine multiple constraints
combine.cset <- function(clist=c(  "sum",
                                   "lo",
                                   "box",
                                   "groups",
                                   "mu.target",
                                   "turnover.hobbs",
								   								 "turnover",
                                   "propcost"),
                         returns=returns,
                         list.arg=
                           list(sum=NULL,
                                mu.target=NULL,
                                w.initial=NULL,
                                toc=NULL,
                                upper=NULL,
                                lower=NULL,
                                group=NULL,
                                upper.group=NULL,
                                lower.group=NULL,
                                ptc=NULL),
						verbose=T
                                ){

  clist <- unique(clist)

  if("turnover.hobbs" %in% clist)
    is.turnover.hobbs <- TRUE else is.turnover.hobbs <- FALSE
  if("propcost" %in% clist)
    is.propcost <- TRUE else is.propcost <- FALSE
  if("turnover" %in% clist)
	is.turnover <- TRUE else is.turnover <- FALSE

  clist.names <- clist
  arg.sum.list <- list.arg
  arg.sum.list$returns <- returns
  cset <- list(NA)

	if(!any(c("sum","propcost")%in% clist.names )){
		clist.names <- c("sum",clist.names)
		arg.sum.list$sum = 1
	}

  # loop through each constraint
  for ( i in 1:length(clist.names)){
	if(verbose)
    cat(clist.names[i],"\n")
    clist.names.i <- paste("cset.",clist.names[i],sep="")
    args.names <- names(formals(clist.names.i))

    # loop through each argument
    for (ii in 1:length(args.names))    {
      if(is.null(eval(parse(text=paste("arg.sum.list$",args.names[ii],sep="")))))
        stop(paste("you need to specify argument ",args.names[ii]," in order to use constraint ",clist.names[i],sep="" ))
    }

    cset.i <- do.call(clist.names.i,arg.sum.list[args.names])

	# these three constraints cannot be together
    if (is.turnover.hobbs & !(clist.names.i %in% c("cset.turnover.hobbs","cset.turnover","cset.propcost"))){
     cset[[i]] <- turnover.hobbs.modify (cset.i)
    }
	else if(is.turnover & !(clist.names.i %in% c("cset.turnover.hobbs","cset.turnover","cset.propcost")))
	cset[[i]] <- turnover.modify (cset.i)
	else if(is.propcost & !(clist.names.i %in% c("cset.turnover.hobbs","cset.turnover","cset.propcost")))
    {
     cset[[i]] <- propcost.modify(cset.i)
    } else
    cset[[i]] <- cset.i
  }

  # remove warning case
  index.rem <- which(sapply(cset, length)!=4)
  if(length(index.rem))
  cset[[index.rem]] <- NULL

  #   dimnames(Amat) <- NULL
  A.all <- do.call(cbind,lapply(cset,function(x)x$A))
  colnames(A.all) <- unlist(lapply(cset,function(x)colnames(x$A)))
  b.all <- do.call(c,lapply(cset,function(x)x$b))
  names(b.all) <- colnames(A.all)
  meq.all <- do.call(c,lapply(cset,function(x)x$meq))

  if(sum(meq.all)!=meq.all[1]){
  # shift meq in front
  meq.pos <- sapply(cset,function(x)ncol(x$A))
  a <- NULL
  a[1] <- 1
  for (k in 2:length(meq.pos))
  a[k] <- a[k-1]+meq.pos[k-1]
  sequ <- NULL
  for (kk in 1:length(meq.pos)){
    if(meq.all[kk]!=0)
      sequ <- c(sequ, a[kk]:(a[kk]+meq.all[kk]-1))
  }

  A.temp <- A.all
  b.temp <- b.all
  A.all <- cbind(A.temp[,c(sequ)],A.temp[,-c(sequ)])
  b.all <- c(b.temp[c(sequ)],b.temp[-c(sequ)])

  # delete duplicated constraints not implemented
  INDEX <- NULL
  for (i in 1:ncol(A.all)){
  index <- which(apply(A.all, 2, function(x)all.equal(x,A.all[,i]))=="TRUE")
  if(length(index)>1){
  index <- index[-which(index==i)]
  INDEX <- c(INDEX,index[index>i])
  }
  }
  if(length(INDEX)){
  A.all <- A.all[,-INDEX]
  b.all <- b.all[-INDEX]}
  meq.all <- sum(meq.all)} else{
    meq.all <- sum(meq.all)
  }

  return(list(A=A.all,
              b=b.all,
              meq=meq.all,
              clist.names= clist.names))
}


# Team Rython, Dainius Masiliunas and Tim Weerman
# Date: 11 January, 2016
# Apache License 2.0

# Calculate the Root Mean Squared Error
RMSE = function(truth, prediction)
{
    return(sqrt(mean((truth-prediction)^2, na.rm=TRUE)))
}

# Calculate partial RMSE for different zones by generating squared difference rasters.
GetDifferenceRaster = function(former, latter, filename=paste("data/", names(latter), ".grd", sep=""), force=FALSE)
{
    # Figure out a reasonable output name
    if (filename == "data/layer.grd")
        warning("Please pass filename or assign meaningful names to input rasters! Else the loaded data may not match expectations.")

    # Create one or load one
    if (!file.exists(filename) || force)
    {
        return(overlay(former, latter, fun=function(truth, prediction){(truth-prediction)^2},
            filename=filename))
    }
    else
        return(raster(filename))
}

# Calculate RMSE per zone
StratifiedRMSE = function(truth, prediction, zones, zonenames = "", ...)
{
    # Unfortunately, zonal() just passes a vector of numbers, not a matrix.
    # So we have to calclate RMSE manually from a difference raster.
    differenceRaster = GetDifferenceRaster(truth, prediction, ...)

    # Get a mean from the zones in the difference raster
    zonestats = zonal(differenceRaster, zones, fun="mean")
    zonestats[,2] = sqrt(zonestats[,2])

    # Add nice labels, if we have them
    if (length(zonenames) > 1)
        rownames(zonestats) = zonenames

    return(zonestats)
}


randN = function(N) sample.int(N, 1) == 1

unbiased = function(f)
   {while ((x <- f()) == f()) {}
    x}

samples = 10000
print(t(round(d = 2, sapply(3:6, function(N) c(
    N = N,
    biased = mean(replicate(samples, randN(N))),
    unbiased = mean(replicate(samples, unbiased(function() randN(N)))))))))


####### SECTION 2 ####
####################
CD4.data <- read.table("Data/cd4.data",
                       col.names=c("Time","CD4","Age","Packs",
                         "Drugs","Sex","Cesd","ID")) #READ IN DATA
attach(CD4.data) ##attach data frame, now you can use just the names

###Figure 1
postscript("Plots/plot-02-01.ps")
par(mfrow=c(1,1)) ##makes a 1,1 grid for the figure
plot(Time,CD4,pch=".",main="CD4 counts vs Time",xlab="Time since zeroconversion",ylab="CD4")##plots CD4 vs. Time
dev.off()

###Figures 2
postscript("Plots/plot-02-02.ps",horizontal=T)
plot(Time,CD4,main="Regression Lines",pch=".")
abline(lm(CD4~Time))
o <- order(Time)
lines(Time[o],lm(CD4~poly(Time,2))$fitted[o],lty=2)
lines(Time[o],lm(CD4~poly(Time,3))$fitted[o],lty=4)
legend(3.75,3000,legend=c("line","parabola","cubic poly"),lty=c(1,2,4))
dev.off()

###Figure 3
###BIN SMOOTHER
postscript("Plots/plot-02-03.ps",horizontal=T)
cs <- c(-Inf,quantile(Time,probs=c(1/5,2/5,3/5,4/5)),Inf)
R <- cut(Time,cs)
plot(Time,CD4,main="Bin Smoother",pch=".")
lines(Time[o],lm(CD4~R)$fitted[o])
dev.off()
###Figure 4
###Running-mean and running-line
library("modreg") ##this library contains the function ksmooth
postscript("Plots/plot-02-04.ps",horizontal=T)
o <- sample(1:length(Time),400) ##to make it fast for example look at only 400
 plot(Time[o],CD4[o],pch=".",main="Running Mean")
b <- c(-2,1,3) - 0.5
e <- b + 1
for(i in 1:length(b)){
  abline(v=c(b[i],e[i]),pch=2)
  oo <- o[Time[o]>=b[i] & Time[o]<=e[i]]
sapply(oo,function(i) points(Time[oo],CD4[oo],pch=1))
lines(range(Time[oo]),rep(mean(CD4[oo]),2))
}
aux <- ksmooth(Time[o],CD4[o],kernel="box",bandwidth=1,x.points=unique(Time[o])) ##box is default!
lines(aux$x,aux$y)
dev.off()
###Figures 5
##kernel smoother
postscript("Plots/plot-02-05.ps",horizontal=T)
plot(Time[o],CD4[o],main="Kernel Smoother",pch=".")
aux <- ksmooth(Time[o],CD4[o],kernel="normal",bandwidth=1,x.points=unique(Time[o]))
lines(aux$x,aux$y)
dev.off()

###Figure 6
postscript("Plots/plot-02-06.ps",horizontal=T)
o <- sample(1:length(Time),400) ##to make it fast for example look at only 400
xx <- sort(Time[o])
aux11 <- ksmooth(xx,c(1,rep(0,length(o)-1)),kernel="normal",bandwidth=1,x.points=unique(xx))
plot(aux11$x,aux11$y,type="l",xlab="Time",ylab="Weights",main="Kernels",col=2)
rug(xx)
oo<- aux11$y>6.030458e-06
points(aux11$x[oo],aux11$y[oo],lty=2,pch="x",cex=0.5)
aux12 <- ksmooth(xx,c(1,rep(0,length(o)-1)),kernel="box",bandwidth=1,x.points=unique(xx))
lines(aux12$x,aux12$y,lty=2,col=2)
oo <- aux12$y>6.030458e-06
points(aux12$x[oo],aux12$y[oo],lty=2,pch="x",cex=0.5)
##
aux21 <- ksmooth(xx,c(rep(0,round(length(o)/2)),1,rep(0,length(o)-round(length(o)/2)-1)),kernel="normal",bandwidth=1,x.points=unique(xx))
lines(aux21$x,aux21$y,type="l",col=3)
oo<- aux21$y>6.030458e-06
points(aux21$x[oo],aux21$y[oo],lty=2,pch="x",cex=0.5)
aux22 <- ksmooth(xx,c(rep(0,round(length(o)/2)),1,rep(0,length(o)-round(length(o)/2)-1)),kernel="box",bandwidth=1,x.points=unique(xx))
lines(aux22$x,aux22$y,lty=2,col=3)
oo<- aux22$y>6.030458e-06
points(aux22$x[oo],aux22$y[oo],lty=2,pch="x",cex=0.5)
##
aux31 <- ksmooth(xx,c(rep(0,round(length(o)*.9)),1,rep(0,length(o)-round(length(o)*.9)-1)),kernel="normal",bandwidth=1,x.points=unique(xx))
lines(aux31$x,aux31$y,type="l",col=4)
oo<- aux31$y>6.030458e-06
points(aux31$x[oo],aux31$y[oo],lty=2,pch="x",cex=0.5)
aux32 <- ksmooth(xx,c(rep(0,round(length(o)*.9)),1,rep(0,length(o)-round(length(o)*.9)-1)),kernel="box",bandwidth=1,x.points=unique(xx))
lines(aux32$x,aux32$y,lty=2,col=4)
oo<- aux32$y>6.030458e-06
points(aux32$x[oo],aux32$y[oo],lty=2,pch="x",cex=0.5)
dev.off()

detach("CD4.data")


# Reference: "Robust Principal Component Analysis?" https://arxiv.org/pdf/0912.3599.pdf

# sum(abs(X))
one_norm = function(X)
{
  if (is.ddmatrix(X))
  {
    ret = .Call(R_one_norm, X@Data)
    allreduce(ret)
  }
  else
    .Call(R_one_norm, X)
}

## \mathcal{S} from the paper - sign(X) * pmax(abs(X) - tau, 0)
shrink_op = function(X, tau)
{
  # NOTE: this modifies the memory in place, which is potentially very dangerous
  if (is.ddmatrix(X))
    .Call(R_shrink_op, X@Data, tau)
  else
    .Call(R_shrink_op, X, tau)
}

## \mathcal{D} from the paper
sv_thresh = function(X, tau)
{
  decomp = La.svd(X)

  sigma = decomp$d
  shrink_op(sigma, tau)
  U = decomp$u
  Vt = decomp$vt

  U %*% (sigma * Vt)
}

#' robpca
#'
#' Implementation of the robust pca algorithm.
#'
#' @description
#' The optimization problem is solved by an alternating directions technique.
#'
#' @param M
#' The input data, stored as a numeric matrix or ddmatrix.
#' @param delta
#' Numeric termination criteria. A smaller (closer to 0) value will require more
#' iterations. See the summary following the Algorithm 1 listing in the
#' referenced paper for details.
#' @param maxiter
#' Maximum number of iterations. Should at least be a few hundred.
#'
#' @references
#' Candes, E.J., Li, X., Ma, Y. and Wright, J., 2011. Robust principal component
#' analysis?. Journal of the ACM (JACM), 58(3), p.11.
#'
#' @examples
#' \dontrun{
#' m = 10
#' n = 3
#' M = matrix(rnorm(m*n), m)
#' robsvd(M)
#' }
#'
#' @author
#' Drew Schmidt
#'
#' @export
robpca = function(M, delta=1e-7, maxiter=1000)
{
  ### I love dynamic typing
  assert.type(delta, "numeric")
  assert.posint(maxiter)

  if (class(M) != "ddmatrix")
  {
    M <- as.matrix(M)

    if (!is.double(M))
      storage.mode(M) <- "double"
  }

  ### the actual work
  n1 = nrow(M)
  n2 = ncol(M)

  lambda = 1/sqrt(max(n1, n2))

  mu = 0.25 * n1*n2 / one_norm(M)

  if (is.ddmatrix(M))
  {
    ictxt = ICTXT(M)
    S = pbdDMAT::ddmatrix(0, n1, n2, ICTXT=ictxt)
    Y = pbdDMAT::ddmatrix(0, n1, n2, ICTXT=ictxt)
  }
  else
  {
    S = matrix(0, n1, n2)
    Y = matrix(0, n1, n2)
  }

  conv = FALSE
  iter = 0L

  ub = delta * norm(M, "F")

  while (!conv && iter < maxiter)
  {
    if (iter == 0)
      L = sv_thresh(M, 1/mu)
    else
      L = sv_thresh(M - S + Y, 1/mu)

    tmp = M - L
    S = tmp + Y
    shrink_op(S, lambda/mu)

    tmp = tmp - S
    Y = Y + tmp

    term = norm(tmp, "F")
    conv = (term <= ub)
    iter = iter + 1L
  }

  info = list(iterations=iter, converged=iter<maxiter, term=term)
  list(L=L, S=S, info=info)
}


next.perm <- function(a) {
  n <- length(a)
  i <- n
  while (i > 1 && a[i - 1] >= a[i]) i <- i - 1
  if (i == 1) {
    NULL
  } else {
    j <- i
    k <- n
    while (j < k) {
      s <- a[j]
      a[j] <- a[k]
      a[k] <- s
      j <- j + 1
      k <- k - 1
    }
    s <- a[i - 1]
    j <- i
    while (a[j] <= s) j <- j + 1
    a[i - 1] <- a[j]
    a[j] <- s
    a
  }
}

perm <- function(n) {
  e <- NULL
  a <- 1:n
  repeat {
    e <- cbind(e, a)
    a <- next.perm(a)
    if (is.null(a)) break
  }
  unname(e)
}


#' Calculation of theortical quantile (Quantile-Quantile Plot)
#'
#' @param y data sample
#' @export
#' @return Part of the qqnorm generic function
#' @examples
#' set.seed(123)
#' test=lm(rnorm(100)~rnorm(100)+100)
#' qq.function(test$residuals)

qq.function=function(y){
  n=length(y)
  r=order(order(y))
  if(n>10){p=(r-1/2)/n}else{p=(r-3/8)/(n+1/4)}
  qqnorm.val=qnorm(p)
  return(qqnorm.val)
}


curve(expr = dnorm(x, mean= 0,sd = 1), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')
curve(expr = dt(x, df = 1), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')

#a mixture
myvar = 1
curve(expr = 0.25*dnorm(x, mean= 0,sd = sqrt(0.01*myvar)), ylim=c(0,1.8),from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')
curve(expr = 0.25*dnorm(x, mean= 0,sd = sqrt(0.1*myvar)), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n',add=TRUE)
curve(expr = 0.25*dnorm(x, mean= 0,sd = myvar), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n',add=TRUE)
curve(1+x*4000, from = 0.0, to = 0.01, xname = "x", col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n',add=TRUE)

library(nimble)
curve(expr = ddexp(x), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')

library(EnvStats)
curve(expr =   dnormMix(x, mean1 = 0, sd1 = 10, mean2 = 0, sd2 = 1, p.mix = 0.5), from = -4, to = 20, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')

curve(expr =   dnormMix(x, mean1 = 0, sd1 = 10, mean2 = 0, sd2 = 1, mean3 = 0, sd3 = 1, p.mix = 0.5), from = -4, to = 20, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')


################################################################################
#
#'
#' Function to calculate the design effect of a stepped wedge cluster randomised
#' study.
#'
#' @param k Number of steps in the stepped wedge study
#' @param b Number of baseline measurements
#' @param t Number of measurements after each step
#' @param icc Intracluster correlation coefficient (\code{ICC})
#' @param size cluster size
#'
#' @return A numeric value of the design effect of a stepped wedge cluster
#'     ranomised study
#'
#' @examples
#'
#'   get_deff_swedge(k = 2, b = 1, t = 1, icc = 0.034, size = 192)
#'
#' @export
#'
#
################################################################################

get_deff_swedge <- function(k, b, t, icc, size) {

  deff <- ((1 + icc * (k * t * size + b * size - 1)) / (1 + icc * (0.5 * (k * t * size) + b * size - 1))) * ((3 * (1 - icc)) / ((2 * t) * (k - 1 / k)))

  return(deff)
}

################################################################################
#
#'
#' Function to calculate sample size requirements for a stepped wedge cluster
#' randomised study.
#'
#' @param z1 The z-score indicating level of significance (confidence interval).
#'     Default at 1.96 for 95\% confidence interval.
#' @param z2 desired power. Default at 0.84 for 80\% power.
#' @param p1 Expected proportion for control group.
#' @param p2 Expected proportion for intervention group
#' @param deff Design effect of a stepped wedge cluster randomised study
#'
#' @return A numeric value of sample size needed for a stepped wedge cluster
#'     ranomised study
#'
#' @examples
#'
#'  get_ss_swedge(z1 = 1.96, z2 = 0.84,
#'                p1 = 0.2, p2 = 0.15,
#'                deff = get_deff_swedge(k = 2, b = 1, t = 1,
#'                                       icc = 0.034, size = 192))
#'
#' @export
#'
#
################################################################################

get_ss_swedge <- function(z1 = 1.96, z2 = 0.84, p1, p2, deff) {

  n1 <- ((z1 + z2) ^ 2) * ((p1 * (1 - p1)) + (p2 * (1 - p2))) / (p1 - p2) ^ 2

  n <- n1 * 2 * deff

  return(n)
}


R version 3.0.0 (2013-04-03) -- "Masked Marvel"
Copyright (C) 2013 The R Foundation for Statistical Computing
Platform: i386-w64-mingw32/i386 (32-bit)

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

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

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

#formulas, equations and notation from http://homeweb2.unifr.ch/hungerbu/pub/sonnenuhr/sundial.ps
# and by the paper of C. Blatter (http://dz-srv1.sub.uni-goettingen.de/sub/digbib/loader?did=D241775)

epsilon=23.45*2*pi/360
alpha  =78.5 *2*pi/360
kappa  =0.016722

mu<-function(t,epsilon,alpha,kappa) {
zaehl= -sin(delta(t,kappa))+tan(epsilon/2)^2*sin(2*(t-alpha)+delta(t,kappa))
nenn =  cos(delta(t,kappa))+tan(epsilon/2)^2*cos(2*(t-alpha)+delta(t,kappa))
return( atan(zaehl/nenn) )
}

# approximation by Blatter
psi<-function(t) {
   return(t+delta(t))
 }

 delta<-function(t,kappa) {
   return( 2*sin(t)*kappa+5/4*sin(2*t)*kappa^2 )
 }

 png(filename="Equation of time.jpg", width=1024, height=768, pointsize=12)
 par(bg="whitesmoke")
 time=seq(-0.6,2*pi+0.4,length=365+(0.6+0.4)/(2*pi)*365)
 da<-paste("1.",as.character(seq(1,12,by=2)),".07",sep="")
 da<-as.Date(c(da,"1.1.08"),"%d.%m.%y")
 #umrechungsfaktor: 24h=2*pi
 plot(time,mu(time,epsilon,alpha,kappa)*24*60/(2*pi),type="l",col="red",xlab="Tag",ylab="Time in Minutes",main="Equation of time: true solar time  -  mean solar time",cex.main=1.5,lwd=3,xaxt="n",xaxs="i",xlim=range(time))
 lines(time,mu(time,epsilon=0,alpha,kappa)*24*60/(2*pi),lwd=2,col="navy",lty="dotdash")
 lines(time,mu(time,epsilon,alpha,kappa=0)*24*60/(2*pi),lwd=2,col="purple",lty="dashed")
 #grid
 abline(h=c(-15,-10,-5,5,10,15),lty="dotted",col="grey")
 abline(h=0,lty="solid",col="grey33")
 tage=cumsum(c(0,31,28,31,30,31,30,31,31,30,31,30,31))/365-3/365
 abline(v=tage*2*pi,lty="dotted",col="grey")
 axis(1,at=seq(0,2*pi,length=7)-3*2*pi/365,labels=as.character(da,"1. %b"))
 legend(x=5.5,y=-10.9,legend=c("Equation of time","Ecliptic","Earth Orbit"),col=c("red","navy","purple"),lwd=c(3,2,2),lty=c("solid","dotdash","dashed"))
 dev.off()


euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

kNN <- function(dataset, points, k, dist = euclidean) {
  answer <- array(dim=c(length(points[,1])))

  for (i in 1:length(points[,1])) {
    distance <- array(dim=dim(dataset)[1])
    for (j in 1:dim(dataset)[1]) {
      distance[j] <- dist(dataset[j, 3:4], points[i,])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- c(0, 0, 0)
    names(classesCount) = unique(iris$Species)
    for (j in 1:k) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1
    }
    answer[i] = names(which.max(classesCount))[1]
  }

  return (answer)
}

fast_cvloo_knn <- function() {
  maxK <- length(iris[,1]) - 1
  classes = unique(iris$Species)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(iris[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:4], iris[i, 1:4])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == iris$Species[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  # for (i in 1:length(ans)) {
  #
  #   ans[i] = ans[i] / length(iris[,1] - 1)
  # }

  return (ans)
}

fast_cvloo_kwnn <- function() {
  maxK <- 149
  classes = unique(iris$Species)
  qs <- seq(from = 0.0, to = 1.0, by = 0.05)

  ans <- array(0L, dim = c(maxK, length(qs)))
  for (i in 1:length(iris[,1])) { # samples
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:4], iris[i, 1:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    classesCount <- array(0L, dim = c(length(classes), length(qs)))
    dimnames(classesCount) = list(classes)
    for (j in 1:maxK) { # k's
      index <- 1
      for (q in qs) {
        classesCount[sortedDataset$Species[j],index] <- classesCount[sortedDataset$Species[j],index] + (q ^ j)
        classForCurrentK = names(which.max(classesCount[,index]))[1]

        if (classForCurrentK == paste(iris$Species[i])) {
          ans[j,index] = ans[j,index] + 1
        }
        index <- index + 1
      }
    }
    index <- index + 1
  }
  cat("\n")

  # for (i in 1:length(ans)) {
  #
  #   ans[i] = ans[i] / (length(iris[,1]) - 1)
  # }

  return (ans)
}

knn_accuracy = fast_cvloo_knn()
kwnn_accuracy = fast_cvloo_kwnn()

cat("Best accuracy for knn: ", max(knn_accuracy) / length(iris[,1]), ";\nBest accuracy for weighted knn:", max(kwnn_accuracy) / length(iris[,1]))

1 - Nearest neighbors algorithm/knn-vs-kwnn.r


## 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(MASS)
library(xts)
library(quantmod)
library(Quandl)
library(PortfolioAnalytics)
library(ROI)
library(ROI.plugin.glpk)
library(ROI.plugin.quadprog)

## risk-free rate (for example purposes)
rf <- 0.01

etf.symbols <- c("SPY", "IWM", "AGG", "FEZ", "ACWI", "IYR")
adj.close <- 6  # 6th field is adjusted close
etf.prices <- getSymbols(etf.symbols[1], source="yahoo",
                         auto.assign=FALSE, return.class="xts")[,adj.close]
for (i in 2:length(etf.symbols)) {
    etf.tmp <- getSymbols(etf.symbols[i], source="yahoo",
                          auto.assign=FALSE, return.class="xts")[,adj.close]
    etf.prices <- cbind(etf.prices, etf.tmp)
}
colnames(etf.prices) <- etf.symbols
etf.rets <- diff(log(etf.prices))["2012/"]

commodity.symbols <- c("WTI", "Natgas", "AU", "CU", "Corn")
settle <- "Settle"  # settle field is labeled
commodity.tickers <- c("CHRIS/CME_CL1", "CHRIS/CME_NG1", "CHRIS/CME_GC1",
                       "CHRIS/CME_HG1", "CHRIS/CME_C1")
commodity.prices <- Quandl(commodity.tickers[1], type="xts")[,settle]
for (i in 2:length(commodity.symbols)) {
    commodity.tmp <- Quandl(commodity.tickers[i], type="xts")[,settle]
    commodity.prices <- cbind(commodity.prices, commodity.tmp)
}
colnames(commodity.prices) <- commodity.symbols

all.returns.tmp <- diff(log(cbind(etf.prices,commodity.prices)))["2012/"]
all.returns <- na.omit(all.returns.tmp)

## set up portfolio with objective and constraints
n.assets <- length(colnames(all.returns))
port.spec <- portfolio.spec(assets = colnames(all.returns))
port.spec <- add.objective(portfolio=port.spec, type="risk", name="StdDev")
port.spec <- add.objective(portfolio=port.spec, type="return", name="mean")
port.spec <- add.constraint(portfolio=port.spec, type="full_investment")
port.spec <- add.constraint(portfolio=port.spec, type="box", min=-1, max=1)

## map out the efficient frontier (for variance risk)
eff.frontier <- create.EfficientFrontier(R=all.returns, portfolio=port.spec,
                                         n.portfolios=100, type="mean-StdDev")

## daily Sharpe ratio
sharpe.ratios <- (eff.frontier$frontier[,"mean"]-rf/250)/eff.frontier$frontier[,"StdDev"]
max.sharpe.ratio <- sharpe.ratios[sharpe.ratios == max(sharpe.ratios)]
optimal.port.name <- names(max.sharpe.ratio)
optimal.mean <- eff.frontier$frontier[optimal.port.name,"mean"]
optimal.sd <- eff.frontier$frontier[optimal.port.name,"StdDev"]

n.trading.days.per.year <- 252
print(sprintf("Optimal Sharpe Ratio: %f", max.sharpe.ratio*sqrt(n.trading.days.per.year)))
print(sprintf("Optimal E(port return): %f", optimal.mean*n.trading.days.per.year))
print(sprintf("Optimal sd(port return): %f", optimal.sd*sqrt(n.trading.days.per.year)))
print("Optimal weights")
print(eff.frontier$frontier[optimal.port.name,(1:n.assets)+3])


## 2. Combine Vectors ##

harvard <- c(1,1,1,1,3)
stanford <- c(2,9,3,4,10)
MIT <- c(3,3,2,2,1)
cambridge <- c(4,2,6,13,48)
oxford <- c(5,7,12,9,15)
columbia <- c(6,13,13,12,4)

uni_vector <- c(harvard, stanford, MIT, cambridge, oxford, columbia)

## 3. Creating a Matrix ##

uni_vector <- c(harvard, stanford, MIT, cambridge, oxford, columbia)

uni_matrix <- matrix(uni_vector, nrow=6, ncol=5, byrow = TRUE)
print(uni_matrix)

## 4. Vector & Matrix Data Types ##

columbia_types <- c("columbia",6,13,13,12,4)
type <- class(columbia_types)
print(type)

## 5. Naming Rows And Columns ##

categories <- c("world_rank","quality_of_education","influence","broad_impact","patents")
universities <- c("Harvard","Stanford","MIT","Cambridge","Oxford","Columbia")

rownames(uni_matrix) <- universities
colnames(uni_matrix) <- categories
named_uni_matrix <- uni_matrix
print(named_uni_matrix)

## 6. Finding the dimensions of the matrix ##

tuition <- c(43280,45000,45016,49350,28450,55161)

print(dim(uni_matrix))
print(length(tuition))
equality <-  dim(uni_matrix)[1] == length(tuition)
print(equality)

## 7. Creating new columns and rows ##

tuition <- c(43280,45000,45016,49350,28450,55161)

uni_matrix <- cbind(uni_matrix, tuition)
print(uni_matrix)

## 8. Subsetting And Indexing A Matrix By Element ##

oxford_influence <- uni_matrix["Oxford","influence"]
stanford_impact <- uni_matrix["Stanford","broad_impact"]
cambridge_patents <- uni_matrix["Cambridge","patents"]
MIT_world_rank <- uni_matrix["MIT","world_rank"]

## 9. Subsetting a Matrix by Rows & Columns ##

world_rank <- uni_matrix[,"world_rank"]
columbia <- uni_matrix["Columbia",]
patents <- uni_matrix[,"patents"]

## 10. Sorting a Matrix ##

top_edu <- sort(uni_matrix[,"quality_of_education"])
low_cost <- sort(uni_matrix[,"tuition"])

## 11. Sorting Then Previewing Data ##

top_edu <- sort(uni_matrix[,"quality_of_education"])
low_cost <- sort(uni_matrix[,"tuition"])

top_two_edu <- head(top_edu, 2)
two_low_cost <- head(low_cost, 2)

R Fundamentals/Introduction to Matrices-312.r


## Exercício 10
## Prof. James Hunter
## from: https://rstudio.cloud/project/1181172
## 28 de maio de 2020
##
## Simulação das Camisetas de Sustentare -- Uma Vez
## Todos os dados totalmente inventados
## Similaridade entre esta versão da Sustentare e a verdadeiro é 100% por acaso

library(tidyverse)
library(summarytools)

## Variáveis Básicas (repetido da ex. 9)

publico_ano1 <- 4000 #número total dos alunos/ex-alunos
novo_publico <- 250 #número novo de alunos por ano
custo_ano1 <- 32 #custo da camiseta estampada com logo e nome em reais
inflacao <- .05 #aumento de custos anual (inflação)com
markup <- 1 #fator para adicionar ao custo para determinar preço de venda
#ex. 1 = 100%
desenv_ano1 <- 20000 # cobrança em ano 1 para desenvolver produto, mktg, etc.
anos <- 5L #número de anos para julgar se programa vale a pena
min_prop <- 0.15 # min e max proporções do público que vai comprar
max_prop <- 0.40

# Número de Iterações

n_sims <- 1000

# Repositório dos Resultados
# Guardar vazio

total_camis <- tibble(sim = integer(n_sims),
                      media_prop = double(n_sims),
                      tot_compras = double(n_sims),
                      tot_renda = double(n_sims),
                      tot_lucro = double(n_sims))

# Funcao do Modelo - Simulação Individual

camis_modelo <- function() {
  # colocar as variáveis num tibble

  camis <- tibble(desenv = numeric(length = anos),
                  publico =  numeric(length = anos),
                  custo = numeric(length = anos),
                  preco = numeric(length = anos),
                  compras = numeric(length = anos),
                  renda = numeric(length = anos),
                  lucro = numeric(length = anos))

  # Carregar camis com os valores

   camis$desenv[1] <- desenv_ano1

  ## Outras precisam loop

  for (i in 1:anos) {
    camis$publico[i] <- publico_ano1 + (i - 1) * novo_publico
    camis$custo[i] <- custo_ano1 * (1 + inflacao)^(i-1)
    camis$preco[i] <- camis$custo[i] * (1 + markup)
  }

  # variável probabilística -- qual proporção do público vai comprar
  # aleatórico entre 15% e 40%
  # usar distribuição uniforme -- runif()
  # premissa: que pode comprar mais de uma vez

  prop_compras <- runif(5, min = min_prop, max = max_prop)

  camis <- camis %>%
    mutate(compras = publico * prop_compras,
           renda = compras * preco,
           lucro = renda - desenv - custo * compras)

  # Calcular os Totais

  sum_camis <- camis %>%
    summarise(media_prop = mean(prop_compras),
              tot_compras = sum(compras),
              tot_renda = sum(renda),
              tot_lucro = sum(lucro))

  # Salvar os resultados

  return(sum_camis)
}

## Executar a Simulação

# set.seed() para tudo mundo tem o mesmo resultado

set.seed(42)

# iniciar sum_camis para receber dados da função

sum_camis <- tibble(sim = integer(n_sims),
                    media_prop = double(n_sims),
                    tot_compras = double(n_sims),
                    tot_renda = double(n_sims),
                    tot_lucro = double(n_sims))

# Loop

inicio_loop = Sys.time()

for (n in 1:n_sims){
  sum_camis <- camis_modelo()

  # Carregar resultados

  total_camis$sim[n] = n
  total_camis$media_prop[n] = sum_camis$media_prop
  total_camis$tot_compras[n] = sum_camis$tot_compras
  total_camis$tot_renda[n] = sum_camis$tot_renda
  total_camis$tot_lucro[n] = sum_camis$tot_lucro
}

termino_loop = Sys.time()

print(glue::glue("Tempo de execução = ", round(termino_loop - inicio_loop, 2), " segundos"))

## Analisar Resultados

summarytools::descr(total_camis[, 2:5], stats = c("mean", "sd", "min", "med",
                                           "max", "iqr", "cv"))


#'@title calcCb
#'
#'@description Calculates the maximum block coefficient (\code{Cb})
#'(dimensionless) based on a ship's maximum displacement and and maximum draft.
#'
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'
#'@details
#'The block coefficient is the ratio of the vessel's displacement and its
#'volume, defined by its waterline length (\code{lwl}), breadth, and draft:
#'\deqn{Cb=\frac{displacement}{lwl*breadth*draft}}{Cb=displacement/(lwl*breadth*draft)}
#'
#'This function returns the maximum block coefficient (\code{Cb}), which is the
#'ratio of the vessel's maximum displacement and it's maximum volume, defined by
#'its waterline length (\code{lwl}), breadth, and maximum draft:
#'\deqn{Cb=\frac{maxDisplacement}{lwl*breadth*maxDraft}}{Cb=maxDisplacement/(lwl*breadth*maxDraft)}
#'
#'@return \code{Cb} (vector of numericals, dimensionless)
#'
#'@references
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'}
#'
#'@examples
#'calcCb(c(80097.00,52382.04), c(218.75,209.25), c(32.25,32.2), c(13.6,11.5))
#'
#'@export

calcCb<- function(maxDisplacement, lwl, breadth, maxDraft){

  Cb <- pmin(1,
             maxDisplacement/(lwl*breadth*maxDraft)
  )
  return(Cb)

}


# Do growth accounting and prepare figures of results

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

#########################################################################
# Accounting calculation
#########################################################################
p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$ky <- round(p$rnna/p$rgdpna,digits=2) # create K/Y ratio
p$acctky <- (.3/(1-.3))*log(p$ky) # just the K/Y part
p$accthc <- log(p$hc) + log(p$emp/p$emp) # just the labor/HC part
p$accttfp <- p$lngdppc - p$acctky - p$accthc # just the TFP part

s <- p # save initial dataset for use later

# Get initial values of TFP, HC, and KY terms from 1960
p <- p[which(p$year>1959),]
p$inittfp <- with(p, accttfp[year == "1960"][match(isocode, isocode[year == "1960"])])
p$inithc <- with(p, accthc[year == "1960"][match(isocode, isocode[year == "1960"])])
p$initky <- with(p, acctky[year == "1960"][match(isocode, isocode[year == "1960"])])

# Calcualte the counterfactual series of GDP p.c. with KY only, TFP only, HC only
p$kyonly <- round(p$inittfp + p$inithc + p$acctky,digits=2)
p$hconly <- round(p$inittfp + p$accthc + p$initky,digits=2)
p$tfponly <- round(p$accttfp + p$inithc + p$initky,digits=2)
p$input <- round(p$inittfp + p$accthc + p$acctky,digits=2)

# Grab data for only specific countries
usa <- p[which(p$isocode %in% c("USA")),]
deu <- p[which(p$isocode %in% c("DEU")),]
kor <- p[which(p$isocode %in% c("KOR")),]
jpn <- p[which(p$isocode %in% c("JPN")),]
chn <- p[which(p$isocode %in% c("CHN")),]

#########################################################################
# Figure for USA and KOR accounting showing CF log GDP per capita
#########################################################################
#,color = I('black'),
#color_discrete_sequence= px.colors.sequential.Plasma_r

fig <- plot_ly(usa, x = ~year, y = ~kyonly, name = 'K/Y only', type = 'scatter',
               mode = 'lines'
               )
fig <- fig %>% add_trace(y = ~hconly, name = 'HC only',mode = 'lines')
fig <- fig %>% add_trace(y = ~tfponly, name = 'Prod only',mode = 'lines')
fig <- fig %>% add_trace(y = ~lngdppc, name = 'Actual GDP p.c.',mode = 'lines')
fig <- layout(fig, title = list(text = 'Accounting for United States', x=0),
               xaxis = list(title = 'Year', tick0=1950, dtick=10),
               yaxis = list (title = 'Log GDP per capita',range=c(9,11)),
               hovermode="x unified")
api_create(fig, filename = "pwt-account-usa")

fig <- plot_ly(kor, x = ~year, y = ~kyonly, name = 'K/Y only', type = 'scatter', mode = 'lines')
fig <- fig %>% add_trace(y = ~hconly, name = 'HC only',mode = 'lines')
fig <- fig %>% add_trace(y = ~tfponly, name = 'Prod only',mode = 'lines')
fig <- fig %>% add_trace(y = ~lngdppc, name = 'Actual GDP p.c.',mode = 'lines')
fig <- layout(fig, title = list(text = 'Accounting for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "pwt-account-kor")

#########################################################################
# Create alternative figure with breakdown of growth rate by 10-year period
#########################################################################

# Get 10-year lags for accounting terms
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.acctky = dplyr::lag(acctky, n = 10, default = NA))
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.accthc = dplyr::lag(accthc, n = 10, default = NA))
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.accttfp = dplyr::lag(accttfp, n = 10, default = NA))
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.lngdppc = dplyr::lag(lngdppc, n = 10, default = NA))

# Calculate 10-year growth rate of accounting terms
s$g10.acctky <- round((s$acctky - s$lag10.acctky)/10,digits=4)
s$g10.accthc <- round((s$accthc - s$lag10.accthc)/10,digits=4)
s$g10.accttfp <- round((s$accttfp - s$lag10.accttfp)/10,digits=4)
s$g10.lngdppc <- round((s$lngdppc - s$lag10.lngdppc)/10,digits=4)

comp <- s[which(s$isocode %in% c("USA","CHN","KOR","JPN","DEU","GBR")),]
s <- s[which(s$isocode %in% c("USA")),]

#########################################################################
# Figure for US growth rate breakdown
#########################################################################
fig <- plot_ly(s, x = ~year, y = ~g10.acctky, type = 'bar', name = 'K/Y growth')
fig <- fig %>% add_trace(y = ~g10.accthc, name = 'HC growth')
fig <- fig %>% add_trace(y = ~g10.accttfp, name = 'Prod growth')
fig <- fig %>% layout(yaxis = list(title = '10-year growth contribution'),
                      barmode = 'stack',
                      xaxis = list(title = 'Year', tick0=1960, dtick=10),
                      title = list(text = 'Growth accounting', x=0),
                      hovermode="x unified"
                      )
api_create(fig, filename = "pwt-growth-acct-usa")

#########################################################################
# Figure of growth rate of productivity for set of countries
#########################################################################
fig <- plot_ly(comp, x = ~year, y = ~g10.accttfp, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Productivity growth', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = '10-year productivity growth rate'),
              hovermode="x unified")
api_create(fig, filename = "pwt-growth-tfp-comp")

#########################################################################
# Merge OECD R&D data with productivity growth data
#########################################################################
# Pull OECD into dataframe
work <- get_dataset("PERS_FUNC")

# Get log of R&D workers
fte <- work
fte <- fte[which(fte$SECTPERF %in% c("_T")),]
fte <- fte[which(fte$FUNCTION %in% c("RSE")),]
fte <- fte[which(fte$GENDER %in% c("_T")),]
fte <- fte[which(fte$MEASURE %in% c("FTE")),]
fte <- fte[which(fte$COUNTRY %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]
fte$lnrdworker <- log(fte$obsValue)

# Calculate 10-year growth rate of R&D workers
fte <-
  fte %>%
  group_by(COUNTRY) %>%
  mutate(lag10.lnrdworker = dplyr::lag(lnrdworker, n = 10, default = NA))
fte$g10.lnrdworker <- (fte$lnrdworker - fte$lag10.lnrdworker)/10

# Join the R&D worker data to the productivity growth data for set of countries
match <- data.frame(comp$isocode,comp$g10.accttfp,comp$year,comp$pop,comp$accttfp)
colnames(match) <- c("COUNTRY","g10.accttfp","obsTime","pop","accttfp")
match$lnpop <- log(match$pop)
joined <- merge(match,fte,by=c('COUNTRY','obsTime'))

#########################################################################
# Figure for R&D workers and growth in productivity
#########################################################################
pal <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00','#ffff33')
pal <- setNames(pal, c("USA","JPN","KOR","CHN","DEU","GBR"))
fig <- plot_ly(joined, x = ~lnrdworker, y = ~g10.accttfp, color = ~COUNTRY,
               type = 'scatter', mode = 'markers',colors = pal,
               hovertemplate = paste("
",
                                     "%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of R&D work and prod growth', x=0),
              xaxis = list(title = 'Log R&D FTE workers'),
              yaxis = list(title = '10-year productivity growth rate'),
              hovermode="x unified")
api_create(fig, filename = "pwt-oecd-rd-tfp")

#########################################################################
# Figure for growth in R&D workers and growth in productivity
#########################################################################
fig <- plot_ly(joined, x = ~g10.lnrdworker, y = ~g10.accttfp, color = ~COUNTRY,
               type = 'scatter', mode = 'markers',colors = pal,
               hovertemplate = paste("
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of R&D growth and prod growth', x=0),
              xaxis = list(title = '10-year growth rate of R&D FTE'),
              yaxis = list(title = '10-year productivity growth rate'),
              hovermode="x unified")
api_create(fig, filename = "pwt-oecd-rd-gtfp")

#########################################################################
# Figure for level of R&D workers and level of productivity
#########################################################################
fig <- plot_ly(joined, x = ~lnrdworker, y = ~accttfp, color = ~COUNTRY,
               type = 'scatter', mode = 'markers',colors = pal,
               hovertemplate = paste("
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of R&D level and prod level', x=0),
              xaxis = list(title = 'Log R&D FTE'),
              yaxis = list(title = 'Log productivity'),
              hovermode="x unified")
api_create(fig, filename = "pwt-oecd-level-rd")


#!/usr/bin/Rscript

# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

rsurf = function(dim=3) {
    # Generate random vector components.
    x = rnorm(dim)

    # Normalize by the radius.
    r = sqrt(sum(x^2))
    y = x / r

    return(y)
}

rbulk = function(dim=3) {
    # Generate random vector components.
    x = rnorm(dim)

    # Normalize by the radius.
    r = sqrt(sum(x^2))
    x_normalized = x / r

    # Sample a new radius and adjust it for the Jacobian on that dimension.
    r_new = runif(1)^(1/dim)
    y = r_new * x_normalized

    return(y)
}

# Generate points and show them in a sensible fashion.

# 2D Surface.
samples_2d_surf = replicate(100, rsurf(2))
plot(samples_2d_surf[1,], samples_2d_surf[2,])

# 3D Surface.
samples_3d_surf = replicate(2000, rsurf(3))
x = samples_3d_surf[1,]
y = samples_3d_surf[2,]
z = samples_3d_surf[3,]

plot(x, y)

lambda = atan2(y, x)
r = sqrt(x^2 + y^2)
phi = atan2(z, r)

px = 2 * sqrt(2) * cos(phi) * sin(lambda/2) / sqrt(1 + cos(phi) * cos(lambda/2))
py = sqrt(2) * sin(phi) / sqrt(1 + cos(phi) * cos(lambda/2))

plot(px, py)

# 2D Bulk
samples_2d_bulk = replicate(2000, rbulk(2))
plot(samples_2d_bulk[1,], samples_2d_bulk[2,])

# 3D Bulk
samples_3d_bulk = replicate(2000, rbulk(3))
plot(samples_3d_bulk[1,], samples_3d_bulk[2,])


# Program to check if
# the input number is
# prime or not

# take input from the user
num = as.integer(readline(prompt="Enter a number: "))

flag = 0
# prime numbers are greater than 1
if(num > 1) {
    # check for factors
    flag = 1
    for(i in 2:(num-1)) {
        if ((num %% i) == 0) {
            flag = 0
            break
        }
    }
}

if(num == 2)    flag = 1
if(flag == 1) {
    print(paste(num,"is a prime number"))
} else {
    print(paste(num,"is not a prime number"))
}


TernarySearch  <- function(left, right, f, eps=1e-4){
  while(TRUE){
    if (abs(left - right) < eps) return((left + right) / 2)

    leftThird  <- left + (right - left) / 3
    rightThird <- right - (right - left) / 3

    if (f(leftThird) > f(rightThird))
      left <- leftThird
    else
      right <- rightThird
  }

}


# Example : 1   Chapter : 10.2     Page No: 502
# Orthogonal Complex vectors
i<-complex(real=0,imaginary=1)
u<-matrix(c(1,i),ncol=1)
ut<-t(u)
#take conjugate of ut
ut[1,2]<-Conj(ut[1,2])
v<-matrix(c(i,1),ncol=1)
print("inner product of u and v is conj(u tanspose )* v is  ")
innerproduct<-ut%*%v
print(innerproduct)
print("As innerproduct is zero , they are orthogonal complex vectors")


#' Function to calculate weighted standard deviation
#'
#' Calculates the standard deviation of a weighted sample set
#' while propagating sample weights through the calculation.
#' @param x Vector containing the values in the set
#' @param w Vector containing the weights to each value (in
#' the same order as \code{x}
#' the optimized growth model
#' @param na.rm Should NA values be removed from the set prior
#' to calculation? \code{TRUE/FALSE}
#' @return The standard deviation of the weighted set of \code{x} values
#' @examples
#' # Create dummy data
#' x <- seq(1, 10, 0.5)
#' w <- c(seq(0.1, 1, 0.1), seq(0.9, 0.1, -0.1))
#' SDw <- sd_wt(x, w, na.rm = TRUE) # Run the function
#' @export
sd_wt<-function(x, w, na.rm = FALSE){ # Formula for weighted standard deviation
    if(na.rm == TRUE){ # Remove NA containing x/w pairs
        x<-x[!(is.na(x) | is.na(w))]
        w<-w[!(is.na(x) | is.na(w))]
    }
    mean.wt <- mean(x * w, na.rm = TRUE) / mean(w) # Calculate weighted mean
    stdev <- sqrt(sum(w * (x - mean.wt) ^ 2) / ((length(w) - 1) / length(w) * sum(w)))
    return(stdev)
}


#####################################################################################################################################
#ABCDE model2: Model 2 is the model to be run in order to spin up the models initial states
ABCDE_SCE_CALIBRATE <- function(parameters,P,PE,T,Qobs,calib_num) {

	#parameters = a vector with a,b,c,d
	#P	= a vector with precip time series for current station
	#PE	= a vector with potential evapotranspiration time series for current station
	#P	= a vector with tavg time series for current statio
	#Qobs	= a vector with observed streamflow time series for current station			#Sint = initial soil moisture
	#Gint = initial groundwater storage
	#Aint = initial snow accumulation

	parm <- parameters
	Peff <- array(0,calib_num)   	#snow storage
	ETeff <- array(0,calib_num)   	#snow storage
	A <- array(0,calib_num)   	#snow storage
	W <- array(0,calib_num)   	#available water
	Y <- array(0,calib_num)   	#evapotranspiration opportunity
	S <- array(0,calib_num)  	#soil moisture
	E <- array(0,calib_num)  	#actual evaporation
	G <- array(0,calib_num)  	#groundwater storage
	Qest <- array(0,calib_num)   #estimated runoff
	S[1] <- parm[7]
	G[1] <- parm[8]
	A[1] <- parm[9]

	for (i in 2:calib_num) {
		#Begin snow component
		if (T[i] > parm[6]) {
			mt <- min(parm[5]*(T[i]-parm[6])*A[i-1],A[i-1])
			Peff[i] <- P[i]+mt
			ETeff[i] <- PE[i]
			A[i] <- A[i-1] - mt
		} else {
			mt <- 0
			Peff[i] <- 0
			ETeff[i] <- 0
			A[i] <- A[i-1]+P[i]
		}

		W[i] <- Peff[i] + S[i-1]
		#w1 and w2 are intermediate values used to calculate Y
		w1 <- (W[i]+parm[2])/(2*parm[1])
		w2 <- W[i]*parm[2]/parm[1]
		Y[i] <- w1 - sqrt((w1^2)-w2)
		S[i] <- Y[i]*exp(-1*ETeff[i]/parm[2])
		E[i] <- Y[i]*(1-exp(-1*(ETeff[i]/parm[2])))
		G[i] <- (G[i-1] + parm[3]*round((W[i]-Y[i]),2))/(1+parm[4])
		Qest[i] <- (1-parm[3])*round((W[i]-Y[i]),2)+parm[4]*G[i]
	}
	SSE <- (sum(((Qobs) - (Qest))^2))
	return(SSE)
}
#################################################################################################################


# Chaper 5 Lab: Cross-Validation and the Bootstrap

# This code is quoted from
# http://faculty.marshall.usc.edu/gareth-james/ISL/code.html

# The Validation Set Approach

library(ISLR)
set.seed(1)
train=sample(392,196)
lm.fit=lm(mpg~horsepower,data=Auto,subset=train)
attach(Auto)
mean((mpg-predict(lm.fit,Auto))[-train]^2)
lm.fit2=lm(mpg~poly(horsepower,2),data=Auto,subset=train)
mean((mpg-predict(lm.fit2,Auto))[-train]^2)
lm.fit3=lm(mpg~poly(horsepower,3),data=Auto,subset=train)
mean((mpg-predict(lm.fit3,Auto))[-train]^2)
set.seed(2)
train=sample(392,196)
lm.fit=lm(mpg~horsepower,subset=train)
mean((mpg-predict(lm.fit,Auto))[-train]^2)
lm.fit2=lm(mpg~poly(horsepower,2),data=Auto,subset=train)
mean((mpg-predict(lm.fit2,Auto))[-train]^2)
lm.fit3=lm(mpg~poly(horsepower,3),data=Auto,subset=train)
mean((mpg-predict(lm.fit3,Auto))[-train]^2)

# Leave-One-Out Cross-Validation

glm.fit=glm(mpg~horsepower,data=Auto)
coef(glm.fit)
lm.fit=lm(mpg~horsepower,data=Auto)
coef(lm.fit)
library(boot)
glm.fit=glm(mpg~horsepower,data=Auto)
cv.err=cv.glm(Auto,glm.fit)
cv.err$delta
cv.error=rep(0,5)
for (i in 1:5){
 glm.fit=glm(mpg~poly(horsepower,i),data=Auto)
 cv.error[i]=cv.glm(Auto,glm.fit)$delta[1]
 }
cv.error

# k-Fold Cross-Validation

set.seed(17)
cv.error.10=rep(0,10)
for (i in 1:10){
 glm.fit=glm(mpg~poly(horsepower,i),data=Auto)
 cv.error.10[i]=cv.glm(Auto,glm.fit,K=10)$delta[1]
 }
cv.error.10

# The Bootstrap

alpha.fn=function(data,index){
 X=data$X[index]
 Y=data$Y[index]
 return((var(Y)-cov(X,Y))/(var(X)+var(Y)-2*cov(X,Y)))
 }
alpha.fn(Portfolio,1:100)
set.seed(1)
alpha.fn(Portfolio,sample(100,100,replace=T))
boot(Portfolio,alpha.fn,R=1000)

# Estimating the Accuracy of a Linear Regression Model

boot.fn=function(data,index)
 return(coef(lm(mpg~horsepower,data=data,subset=index)))
boot.fn(Auto,1:392)
set.seed(1)
boot.fn(Auto,sample(392,392,replace=T))
boot.fn(Auto,sample(392,392,replace=T))
boot(Auto,boot.fn,1000)
summary(lm(mpg~horsepower,data=Auto))$coef
boot.fn=function(data,index)
 coefficients(lm(mpg~horsepower+I(horsepower^2),data=data,subset=index))
set.seed(1)
boot(Auto,boot.fn,1000)
summary(lm(mpg~horsepower+I(horsepower^2),data=Auto))$coef


x <- c(1,2,3,4,5,6)   # Create ordered collection (vector)
y <- x^2              # Square the elements of x
print(y)              # print (vector) y
mean(y)               # Calculate average (arithmetic mean) of (vector) y; result is scalar
var(y)                # Calculate sample variance
lm_1<- lm(y ~ x)     # Fit a linear regression model "y = f(x)" or "y = B0 + (B1 * x)"
# store the results as lm_1
print(lm_1)           # Print the model from the (linear model object) lm_1


library("ggplot2")
heights <- c(170, 151, 174, 197, 177, 194, 173, 180, 186, 185, 175, 163, 160, 178, 190, 170, 169, 183, 182, 180, 176, 176, 164, 180, 166, 168, 167, 186, 165)

getmode <- function(v) {
   uniqv <- unique(v)
   uniqv[which.max(tabulate(match(v, uniqv)))]
}

result.mean <- mean(heights)
print(result.mean)

result.med <- median(heights)
print(result.med)

result.mode <- getmode(heights)
print(result.mode)

result.var <- sd(heights)
print(result.var)

result.gm_mean <- prod(heights)^(1/(length(heights)))
print(result.gm_mean)

result.hm_mean <- 1/mean(1/heights)
print(result.hm_mean)

hist(heights, plot=TRUE, xlab="Students' heights")

boxplot(heights, xlab="Students' heights", horizontal=TRUE)

n <- length(heights)
p <- (1 : n) / n - 0.5 / n

PP = data.frame(emp=(1:n)/n, theor=pnorm(sort(heights), result.mean, result.var))
ggplot(PP,aes(x=emp, y=theor)) + geom_abline(intercept=0, slope=1, colour="blue") + geom_point() + labs(y="", x="", title="P-P plot")

QQ = data.frame(emp=sort(heights), theor=qnorm((1:n)/n, result.mean, result.var))
QQ_plot <- ggplot(QQ, aes(x = emp, y = theor), colour = "blue")
QQ_plot + geom_abline(intercept=0, slope=1, colour="red") + geom_point() + labs(y="", x="", title="Q-Q plot")


library(signal)

# CIC filter parameters
R <- 5                         # Decimation factor
M <- 1                         # Differential delay
N <- 6                         # Number of stages

Fo <- 0.22                     # Pass band edge

# fir2 parameters
k <- kaiserord(c(Fo, Fo+0.02), c(1, 0), 1/(2^16), 1)
L <- k$n                       # Filter order
Beta <- k$beta                 # Kaiser window parameter

# FIR filter design using fir2
s <- 0.001                     # Step size
fp <- seq(0.0, Fo, by=s)       # Pass band frequency samples
fs <- seq(Fo+0.02, 0.5, by=s)  # Stop band frequency samples
f <- c(fp, fs)*2               # Normalized frequency samples; 0<=f<=1

Mp <- matrix(1, 1, length(fp)) # Pass band response; Mp[1]=1
Mp[-1] <- abs(M*R*sin(pi*fp[-1]/R)/sin(pi*M*fp[-1]))^N
Mf <- c(Mp, matrix(0, 1, length(fs)))

h <- fir2(L, f, Mf, window=kaiser(L+1, Beta))

# Print filter coefficients
paste(as.character(h), collapse=", ")

fh <- freqz(h)

op <- par(mfrow = c(1, 2))

plot(f, Mf, type = "b", ylab = "magnitude", xlab = "Frequency", xlim = c(0, 0.5))
lines(fh$f / pi, abs(fh$h), col = "blue")

plot(f, 20*log10(Mf+1e-5), type = "b", ylab = "dB", xlab = "Frequency", xlim = c(0, 0.5))
lines(fh$f / pi, 20*log10(abs(fh$h)), col = "blue")

par(op)


#' Compress lpo using Haar-wavelet transform.
#'
#' The time series is transformed using Haar-wavelet transform,
#' then the near-zero-values will be rounded to zero to an extend
#' and the series will be decoded, creating a new, compressed
#' version of the original series.
#' @param lpo Times series as numeric vector
#' @param level Compression level, from 0 to 1
#' @export
#'
#' @importFrom stats ts quantile
#'
#' @examples
#' set.seed(1)
#' d <- squares(100)
#' lpo <- d[, 1]
#' lpm <- compress.lpo(lpo, 0.9)
#' plot(ts(lpo))
#' lines(ts(lpm), col = "red")

compress.lpo <- function(lpo, level = 0.99) {

  l <- length(lpo)
  lpo <- ts(c(lpo, rep(0, 2^ceiling(log(l, base = 2)) - l)))
  trans <- wavelets::dwt(lpo, filter="haar")
  w.vector.length <- l / 2
  w.vector <- numeric()
  for (i in 1:trans@level) {
    w.vector <- append(abs(trans@W[i][[1]]), w.vector)
  }
  limit <- quantile(w.vector, level)

  for (i in 1:trans@level) {
    trans@W[i][[1]][abs(trans@W[i][[1]]) <= limit] <- 0
  }

  res <- wavelets::idwt(trans)
  res <- res[1:l]
  return (res)
}


library("modreg")
###CHAPTER 5: BIAS VARIANCE TRADE-OFF
##plot 01
N <- 100
x <- seq(.09,.5,len=N)
f <- 2*sin(1/x)
sigma2 <- 1
y <- f + rnorm(N,0,sigma2)
postscript("Plots/plot-05-01.ps")
plot(x,y,main="True f(x)=5 sin(1/x) and observations")
lines(x,f,type="l")
dev.off()
####plot02
NN <- 5
postscript("Plots/plot-05-02.ps")
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N,0,sigma2)
       ksmooth(x,y,kernel="box",bandwidth=.01)$y
     })
par(mfrow=c(2,2),mai=c(0,0,0,0),oma=c(1,1,1,1))
plot(x,f,type="l",lwd=1.5,ylim=range(c(f,as.vector(results))))
lines(x,results[,1],lty=4)

plot(x,f,ylim=range(results),type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N,0,sigma2)
       ksmooth(x,y,kernel="box",bandwidth=.1)$y
     })
plot(x,f,type="l",lwd=1.5)
lines(x,results[,1],lty=4)

plot(x,f,type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
dev.off()

##plot03
postscript("Plots/plot-05-03.ps")
par(mfrow=c(1,2))

x <- seq(1,100,len=N)
f <- 2*sin(1/(x+18.62)*218)
y <- f + rnorm(N,0,sigma2)
plot(x,y)
lines(x,f)

#N <- 500
x <- seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f + rt(N,3)
plot(x,y)
lines(x,f)
dev.off()

########## plot04
Nl <- 50
#N <- 500
x <- seq(1,100,len=N)
f <- 2*sin(1/(x+18.62)*218)
y <- f + rnorm(N,0,sigma2)
lambdas <- seq(.01,2.2,len=Nl)
cvs <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 200
AUX <-matrix(rnorm(N*NN,0,sigma2),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit0 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse)[1]])
fit1 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs)[1]])
postscript("Plots/plot-05-04.ps")
par(mfrow=c(2,3),oma=c(0,0,2,0))
plot(lambdas,cvs,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs)[1]],lty=1)
plot(lambdas,mse+1,xlab="lambdas",type="l")
abline(v=lambdas[order(mse)[1]],lty=2)
o <- sort(sample(1:length(x),50))
plot(x,f,type="l",ylim=range(c(fit1$y,fit0$y[o])))
lines(x[o],fit1$y[o],lty=2,col=2)
lines(x[o],fit0$y[o],lty=3,col=3)
legend(70,0,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))

#N <- 500
x <- seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f + rt(N,3)
N1 <- 50
cvs2 <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 20
AUX <-matrix(rt(N*NN,3),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse2 <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit00 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse2)[1]])
fit11 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs2)[1]])
plot(lambdas,cvs2,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs2)[1]],lty=1)
plot(lambdas,mse2+sigma2,xlab="lambdas",type="l")
abline(v=lambdas[order(mse2)[1]],lty=2)
o <- sort(sample(1:length(x),100))
plot(x,f,type="l",ylim=range(c(f,fit11$y,fit00$y[o])))
lines(x[o],fit11$y[o],lty=2,col=2)
lines(x[o],fit00$y[o],lty=3,col=3)
legend(70,1,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))
mtext(side=3,paste("N =",N),cex=1.2,line=0,outer=T)
dev.off()

###NOW for N=500
Nl <- 50
N <- 500
x <- seq(1,100,len=N)
f <- 2*sin(1/(x+18.62)*218)
y <- f + rnorm(N,0,sigma2)
lambdas <- seq(.01,2.2,len=Nl)
cvs <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 20
AUX <-matrix(rnorm(N*NN,0,sigma2),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit0 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse)[1]])
fit1 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs)[1]])
postscript("Plots/plot-05-05.ps")
par(mfrow=c(2,3),oma=c(0,0,2,0))
plot(lambdas,cvs,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs)[1]],lty=1)
plot(lambdas,mse+1,xlab="lambdas",type="l")
abline(v=lambdas[order(mse)[1]],lty=2)
o <- sort(sample(1:length(x),50))
plot(x,f,type="l",ylim=range(c(fit1$y,fit0$y[o])))
lines(x[o],fit1$y[o],lty=2,col=2)
lines(x[o],fit0$y[o],lty=3,col=3)
legend(70,0,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))

#N <- 500
x <- seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f + rt(N,3)
N1 <- 50
cvs2 <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 20
AUX <-matrix(rt(N*NN,3),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse2 <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit00 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse2)[1]])
fit11 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs2)[1]])
plot(lambdas,cvs2,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs2)[1]],lty=1)
plot(lambdas,mse2+sigma2,xlab="lambdas",type="l")
abline(v=lambdas[order(mse2)[1]],lty=2)
o <- sort(sample(1:length(x),100))
plot(x,f,type="l",ylim=range(c(f,fit11$y,fit00$y[o])))
lines(x[o],fit11$y[o],lty=2,col=2)
lines(x[o],fit00$y[o],lty=3,col=3)
legend(70,1,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))
mtext(side=3,paste("N =",N),cex=1.2,line=0,outer=T)
dev.off()

postscript("Plots/plot-05-06.ps")
y <- read.table("Data/cholostyramine.dat",header=T)
attach(y)
plot(compliance,improvement)
abline(lm(improvement~compliance,data=y),col=4,lty=1)
o <- order(compliance)
lines(compliance[o],loess(improvement~compliance,data=y)$fitted[o],col=2,lty=2)
dev.off()

###bootsrap.. there is bootstrap function in R, but we need to download library
postscript("Plots/plot-05-07.ps")
B <- 50
N <- length(compliance)
fit1 <- lm(improvement~compliance,data=y)
fit2 <- loess(improvement~compliance,data=y)
thetas <- c(predict(fit1,data.frame(compliance=c(60,80,100))),
            predict(fit2,data.frame(compliance=c(60,80,100))))
par(mfrow=c(1,2))
aux <- matrix(sample(1:N,B*N,replace=T),B,N)
plot(compliance,improvement,type="n")
abline(h=0,v=60)
plot(compliance,improvement,type="n")
abline(h=0,v=60)
thetastars <- apply(aux,1,function(o){
  fit1 <- lm(improvement~compliance,data=y,subset=o)
  fit2 <- loess(improvement~compliance,data=y,subset=o)
  par(mfg=c(1,1,1,2))
  abline(fit1)
  par(mfg=c(1,2,1,2))
  oo <- order(compliance[o])
  lines(compliance[o][oo],fit2$fitted[oo])
  c(predict(fit1,data.frame(compliance=c(60,80,100))),
    predict(fit2,data.frame(compliance=c(60,80,100))))
})
dev.off()
detach("y")

##this prints out the results
junk <- rbind(thetas,
              apply(thetastars,1,function(x) sqrt(var(x))))

print(round(junk))

############
#### CONFIDENCE BANDS STUFF
###############
N <- 100
x <- sort(runif(N,1,100))#seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f+rnorm(N,0,1)
Y <- diag(N)
l <- .7
S <- apply(Y,1,function(yy) loess(yy~x,span=l)$fitted)
aux <- svd(S) ##then ss' is ud^2u'
SS <- aux$u%*%diag(aux$d^2)%*%t(aux$u) ##this is ss'
dfvar <- sum(diag(SS))
dferr <- N - 2*sum(diag(S)) + dfvar
###TRUE
NN <- 5000
AUX <- matrix(rnorm(NN*N,0,1),ncol=N)
Gtrue <- apply(AUX,1,function(error){
  yy <- error+f;resid <- yy-S%*%yy
  sum(error^2)/(sum(resid^2)/dferr)})
fit1 <- S%*%y
residstar <- y - fit1
B <- 500
Gboot <- rep(0,B)
for(i in 1:B){
  	error <- sample(residstar,N,replace=T)
        yy <- error+fit1;resid <- yy-S%*%yy
        Gboot[i] <- sum(error^2)/(sum(resid^2)/dferr)
         }
Gapprox <-dferr+  dfvar*rf(NN,dfvar,dferr)

postscript("Plots/plot-05-08.ps")
par(mfrow=c(1,1))
plot(x,y)
lines(x,f,col=3)
lines(x,fit1,lty=2,col=4)
dev.off()

postscript("Plots/plot-05-09.ps")
par(mfrow=c(1,2))
RANGE <- range(Gtrue,Gapprox,Gboot)
qqplot(Gtrue,Gboot,ylim=RANGE,xlim=RANGE,pch="B",col=3)
lines(sort(Gtrue),sort(Gapprox),pch="F",col=4)
abline(0,1)
##NOW we make bootstrap curves
NNN <- 7
sigmahat <- sqrt((sum(((diag(N)-S)%*%y)^2)/dferr))
G <- Gboot ##we can use others here like Gapprox
qG <- quantile(G,.95)
fs <- sapply(1:NNN,function(i){
	resid<- rnorm(N,0,sigmahat)
        auxG <-  sum(resid^2)/(sigmahat^2)
        ##notice SS' = [UD][UD]'
        newf <- fit1+ aux$u%*%diag(aux$d)%*%resid
        if(auxG < qG) return(c(1,newf))
        else return(c(0,newf))
}
)
ci <- 2*sqrt(diag(SS)*sigmahat^2)
plot(x,fit1,ylim=range(c(fit1+ci,fit1-ci,as.vector(fs[-1,]))),type="l")
polygon(c(x,rev(x)),c(fit1+ci,rev(fit1-ci)),col=655,border=F)
lines(x,fit1)
apply(fs,2,function(yy) lines(x,yy[-1],col=3+yy[1],lty=3-yy[1]))
dev.off()

###NOW for t-distribution
N <- 100
x <- sort(runif(N,1,100))#seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f+rt(N,3)
Y <- diag(N)
l <- .7
S <- apply(Y,1,function(yy) loess(yy~x,span=l)$fitted)
aux <- svd(S) ##then ss' is ud^2u'
SS <- aux$u%*%diag(aux$d^2)%*%t(aux$u) ##this is ss'
dfvar <- sum(diag(SS))
dferr <- N - 2*sum(diag(S)) + dfvar
###TRUE
NN <- 5000
AUX <- matrix(rt(NN*N,3),ncol=N)
Gtrue <- apply(AUX,1,function(error){
  yy <- error+f;resid <- yy-S%*%yy
  sum(error^2)/(sum(resid^2)/dferr)})
fit1 <- S%*%y
residstar <- y - fit1
B <- 1000
Gboot <- rep(0,B)
for(i in 1:B){
  	error <- sample(residstar,N,replace=T)
        yy <- error+fit1;resid <- yy-S%*%yy
        Gboot[i] <- sum(error^2)/(sum(resid^2)/dferr)
         }
Gapprox <-dferr+  dfvar*rf(NN,dfvar,dferr)

postscript("Plots/plot-05-10.ps")
par(mfrow=c(1,2))
RANGE <- range(Gtrue,Gapprox,Gboot)
qqplot(Gtrue,Gboot,ylim=RANGE,xlim=RANGE,pch="B",col=3)
lines(sort(Gtrue),sort(Gapprox),pch="F",col=4)
abline(0,1)
##NOW we make bootstrap curves
NNN <- 7
sigmahat <- sqrt((sum(((diag(N)-S)%*%y)^2)/dferr))
G <- Gboot ##we can use others here like Gapprox
qG <- quantile(G,.95)
fs <- sapply(1:NNN,function(i){
	resid<- rnorm(N,0,sigmahat)
        auxG <-  sum(resid^2)/(sigmahat^2)
        ##notice SS' = [UD][UD]'
        newf <- fit1+ aux$u%*%diag(aux$d)%*%resid
        if(auxG < qG) return(c(1,newf))
        else return(c(0,newf))
}
)
ci <- 2*sqrt(diag(SS)*sigmahat^2)
plot(x,fit1,ylim=range(c(fit1+ci,fit1-ci,as.vector(fs[-1,]))),type="l")
polygon(c(x,rev(x)),c(fit1+ci,rev(fit1-ci)),col=655,border=F)
lines(x,fit1)
apply(fs,2,function(yy) lines(x,yy[-1],col=3+yy[1],lty=3-yy[1]))
dev.off()


source('./knn.r', chdir = T)

fast_cvloo_knn <- function() {
  maxK <- length(iris[,1]) - 1
  classes = unique(iris$Species)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(iris[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 3:4], iris[i, 3:4])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == iris$Species[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  for (i in 1:length(ans)) {

    ans[i] = ans[i] / length(iris[,1] - 1)
  }

  return (ans)
}

par(mfrow=c(1,1), pty="s")
# LOO CV, looking for the best k
stats <- fast_cvloo_knn()
plot(1:(length(iris[,1]) - 1), stats, type="l", xlab="k", ylab="Accuracy")

maxPoint = which(stats == max(stats))
points((1:(length(iris[,1]) - 1))[maxPoint], stats[maxPoint], pch = 19, col = "red")

bestK <- which.max(stats)
cat("Best K =", bestK, "\n")

1 - Nearest neighbors algorithm/knn-loocv.r