# 4. faza: Napredna analiza podatkov

obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(42) # zato, da so rezultati ponovljivi
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)

  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

diagram.obrisi = function(k.obrisi) {
  ggplot() +
    geom_boxplot(
      data = k.obrisi,
      mapping = aes(x = k, y = obrisi)
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = k, y = obrisi),
      color = "red"
    ) +
    geom_line(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = as.integer(k), y = obrisi),
      color = "red"
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi) %>%
        filter(obrisi == max(obrisi)) %>%
        filter(k == min(k)),
      mapping = aes(x = k, y = obrisi),
      color = "blue"
    ) +
    xlab("število skupin (k)") +
    ylab("obrisi (povprečje obrisov)") +
    ggtitle(paste("Maksimalno povprečje obrisov pri k =", obrisi.k(k.obrisi))) +
    theme_classic()
}

nakupi = tabela2 %>% dplyr::select(
  Year, Country, Stopnja, Koliko_vseh_nakupov_je_opravila_ta_skupina
) %>%
  filter(
    Year == 2019
  ) %>%
  pivot_wider(
    names_from = Stopnja,
    values_from = Koliko_vseh_nakupov_je_opravila_ta_skupina
  ) %>%
  dplyr::select(-Year)
nakupi[5, 1] = 'Germany'
nakupi[38, 1] = 'Kosovo'

#dendrogram, hierarhično razvrščanje v skupine
drzave = nakupi[, 1] %>% unlist()
razdalje = nakupi[, -1] %>% dist()
dendrogram = razdalje %>% hclust(method = "ward.D")
#dendrogramcek <- plot(
#  dendrogram,
#  labels = drzave,
#  ylab = "višina",
#  main = NULL
#)
#Zgornjo kodo, ki nariše dendrogram, sem zakomentirala, saj se mi je dendrogramcek kljub temu, da sem ga shranila
#pod spremenljivko in ga ne poklicala v poročilu, še zmeraj prikazoval.

hc.kolena = function(dendrogram, od = 1, do = NULL, eps = 0.5) {
  # število primerov in nastavitev parametra do
  n = length(dendrogram$height) + 1
  if (is.null(do)) {
    do = n - 1
  }
  # k.visina je tabela s štirimi stolpci
  # (1) k, število skupin
  # (2) višina združevanja
  # (3) sprememba višine pri združevanju
  # (4) koleno: ali je točka koleno?
  k.visina = tibble(
    k = as.ordered(od:do),
    visina = dendrogram$height[do:od]
  ) %>%
    # sprememba višine
    mutate(
      dvisina = visina - lag(visina)
    ) %>%
    # ali se je intenziteta spremembe dovolj spremenila?
    mutate(
      koleno = lead(dvisina) - dvisina > eps
    )
  k.visina
}

# iz tabele k.visina vrne seznam vrednosti k,
# pri katerih opazujemo koleno
hc.kolena.k = function(k.visina) {
  k.visina %>%
    filter(koleno) %>%
    dplyr::select(k) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

# izračunamo tabelo s koleni za dendrogram
r = hc.kolena(dendrogram)

# narišemo diagram višin združevanja
diagram.kolena = function(k.visina) {
  k.visina %>% ggplot() +
    geom_point(
      mapping = aes(x = k, y = visina),
      color = "red"
    ) +
    geom_line(
      mapping = aes(x = as.integer(k), y = visina),
      color = "red"
    ) +
    geom_point(
      data = k.visina %>% filter(koleno),
      mapping = aes(x = k, y = visina),
      color = "blue", size = 2
    ) +
    ggtitle(paste("Kolena:", paste(hc.kolena.k(k.visina), collapse = ", "))) +
    xlab("število skupin (k)") +
    ylab("razdalja pri združevanju skupin") +
    theme_classic()
}
diagram.kolena(r)

diagram.skupine = function(podatki, oznake, skupine, k) {
  podatki = podatki %>%
    bind_cols(skupine) %>%
    dplyr::rename(skupina = ...4)

  d = podatki %>%
    ggplot(
      mapping = aes(
        x = x, y = y, color = skupina
      )
    ) +
    geom_point() +
    geom_label(label = oznake, size = 2) +
    scale_color_hue() +
    theme_classic()

  for (i in 1:k) {
    d = d + geom_encircle(
      data = podatki %>%
        filter(skupina == i)
    )
  }
  d
}

#k-ti voditelji

b <- transform(nakupi, No_or_low= as.numeric(unlist(nakupi[,2])),
          Med = as.numeric(unlist(nakupi[,3])),
          High = as.numeric(unlist(nakupi[,4])),
          Students = as.numeric(unlist(nakupi[,5])))%>% dplyr::select(Students, No_or_low, Med, High)
skupine = b[, -1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()

print(skupine)
r.hc = nakupi[, -1] %>% obrisi(hc = TRUE)
r.km = nakupi[, -1] %>% obrisi(hc = FALSE)

diagram.obrisi(r.hc)
diagram.obrisi(r.km)

#Optimalno število skupin je torej 2 ali 4/5.

drzave.x.y =
  as_tibble(razdalje %>% cmdscale(k = 2)) %>%
  bind_cols(drzave) %>%
  dplyr::select(drzava = ...3, x = V1, y = V2)

k = obrisi.k(r.hc)
skupine = nakupi[, -1] %>%
  dist() %>%
  hclust(method = "ward.D") %>%
  cutree(k = k) %>%
  as.ordered()
diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, k)

k = obrisi.k(r.km)
set.seed(42) # ne pozabimo na ponovljivost rezultatov
skupine = nakupi[, -1] %>%
  kmeans(centers = k) %>%
  getElement("cluster") %>%
  as.ordered()
diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, k)

set.seed(42)
skupine = nakupi[, -1] %>%
  kmeans(centers = 4) %>%
  getElement("cluster") %>%
  as.ordered()
skup <- diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, 2)

download.file(url='https://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/svet/TM_WORLD_BORDERS-0.3.shp',
              destfile='TM_WORLD_BORDERS-0.3.shp', method='curl')
download.file(url='https://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/svet/TM_WORLD_BORDERS-0.3.dbf',
              destfile='TM_WORLD_BORDERS-0.3.dbf', method='curl')
download.file(url='https://kt.ijs.si/~ljupco/lectures/appr/zemljevidi/svet/TM_WORLD_BORDERS-0.3.shx',
              destfile='TM_WORLD_BORDERS-0.3.shx', method='curl')
svet.sp <- readOGR(getwd(), "TM_WORLD_BORDERS-0.3")
svet.sp = gBuffer(svet.sp, byid = TRUE, width = 0)

svet.centroidi = read_csv("podatki/drzave-centroidi.csv")
evropske.drzave = tibble(
  drzava = c(
    "Albania", "Andorra", "Armenia",
    "Austria", "Azerbaijan", "Belarus",
    "Belgium", "Bosnia and Herzegovina",
    "Bulgaria", "Croatia", "Cyprus",
    "Czechia", "Denmark", "Estonia",
    "Finland", "France", "Georgia",
    "Germany", "Greece", "Hungary",
    "Iceland", "Ireland", "Italy",
    "Kazakhstan", "Latvia",
    "Liechtenstein", "Lithuania",
    "Luxembourg", "Malta", "Moldova",
    "Monaco", "Montenegro",
    "Netherlands", "North Macedonia",
    "Norway", "Poland", "Portugal",
    "Romania", "Russia", "San Marino",
    "Serbia", "Slovakia", "Slovenia",
    "Spain", "Sweden", "Switzerland",
    "Turkey", "Ukraine", "United Kingdom",
    "Holy See (Vatican City)"
  )
)

evropa.izsek = as(extent(-25, 60, 30, 75), "SpatialPolygons")
sp::proj4string(evropa.izsek) <- sp::proj4string(svet.sp)

evropske.drzave = tibble(
  drzava = c(
    "Albania", "Andorra", "Armenia",
    "Austria", "Azerbaijan", "Belarus",
    "Belgium", "Bosnia and Herzegovina",
    "Bulgaria", "Croatia", "Cyprus",
    "Czechia", "Denmark", "Estonia",
    "Finland", "France", "Georgia",
    "Germany", "Greece", "Hungary",
    "Iceland", "Ireland", "Italy",
    "Kazakhstan", "Latvia",
    "Liechtenstein", "Lithuania",
    "Luxembourg", "Malta", "Moldova",
    "Monaco", "Montenegro",
    "Netherlands", "North Macedonia",
    "Norway", "Poland", "Portugal",
    "Romania", "Russia", "San Marino",
    "Serbia", "Slovakia", "Slovenia",
    "Spain", "Sweden", "Switzerland",
    "Turkey", "Ukraine", "United Kingdom",
    "Holy See (Vatican City)"
  )
)

# Evropa se po zemljepisni dolžini razteza
# od -25 do 60, po širini pa od 30 do 75
evropa.izsek = as(extent(-25, 60, 30, 75), "SpatialPolygons")
sp::proj4string(evropa.izsek) <- sp::proj4string(svet.sp)
colnames(evropske.drzave)[1] <- "NAME"
evropa.poligoni = svet.sp %>% crop(evropa.izsek) %>% fortify() %>% tibble() %>%
left_join(
  evropske.drzave,
  by = "NAME"
)
colnames(svet.centroidi)[1] <- "NAME"
evropa.centroidi = evropske.drzave %>%
  left_join(
    svet.centroidi,
    by = "NAME"
  )

colnames(evropa.poligoni)[12] <- "drzava"
colnames(evropa.centroidi)[1] <- "drzava"

prostorski.diagram.skupine = function(drzave, skupine, k) {
  drzave %>%
    bind_cols(skupine) %>%
    dplyr::select(drzava = ...1, skupina = ...2) %>%
    left_join(
      evropa.poligoni,
      by = "drzava"
    ) %>%
    ggplot() +
    geom_polygon(
      mapping = aes(long, lat, group = group, fill = skupina),
      color = "grey"
    ) +
    scale_fill_brewer() +
    coord_map() +
    xlim(-25, 50) +
    theme_classic() +
    theme(
      axis.line = element_blank(),
      axis.ticks = element_blank(),
      axis.text = element_blank(),
      axis.title = element_blank()
    )
}

set.seed(42)
skupine = nakupi[, -1] %>%
  kmeans(centers = 2) %>%
  getElement("cluster") %>%
  as.ordered()

z1 <- prostorski.diagram.skupine(drzave, skupine, 2)

k = dendrogram %>%
  hc.kolena %>%
  hc.kolena.k() %>%
  getElement(1)

skupine = dendrogram %>%
  cutree(k = 4) %>%
  as.ordered()

z2<- prostorski.diagram.skupine(drzave, skupine, k)

podatki.ucni <- tabela1 %>%
  filter(
    Year == 2019
  ) %>%
  dplyr::select(-Year, - Area)
podatki.ucni <- podatki.ucni[-c(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 50, 52, 54, 56, 58, 60, 62, 64, 66, 68), ]

podatki.ucni <- podatki.ucni[(-c(32, 33, 34)),]
g <- ggplot(podatki.ucni, aes(x=BDPpc, y=Value)) + geom_point()
g + geom_smooth(method="lm")

lin <- lm(data=podatki.ucni, Value ~ BDPpc + Education)
lin
napovedi <- predict(lin)

kv <- lm(data=podatki.ucni, Value ~ Education + I(BDPpc^2))

mls <- loess(data=podatki.ucni, Value ~ BDPpc + Education)

sapply(list(lin, kv, mls), function(x) mean((x$residuals^2)))

podatki.ucni <- transform(podatki.ucni, Education = as.numeric(as.character(Education)))
k <- 5
formula <- Value ~ BDPpc

napaka.cv <- function(podatki, k, formula) {
  n <- nrow(podatki)
  r <- sample(1:n)

  razrez <- cut(1:n, k, labels = FALSE)

  razbitje <- split(r, razrez)

  pp.napovedi = rep(0, n)
  for (i in 1:length(razbitje)) {
    #Naučimo se modela na množici S/Si
    model = podatki[ -razbitje[[i]], ] %>% lm(formula = formula)
    #Naučen model uporabimo za napovedi na Si
    pp.napovedi[ razbitje[[i]] ] = predict(object = model, newdata = podatki[ razbitje [[i]], ] )

  }

  #model so učni podatki in ostalo ( razbitje[[i]]) so testni podatki.

  napaka <- mean((pp.napovedi - podatki$Value)^2)
  return(napaka)
}
napaka.cv(podatki.ucni, 5, formula)

formule <- c(Value ~ BDPpc,
             Value ~ BDPpc + I(BDPpc^2),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4) +I(BDPpc^5))
napake <- rep(0, 5)
for (i in 1:5){
  formula <- formule[[i]]
  napaka <- napaka.cv(podatki.ucni, 5, formula)
  napake[i] <- napaka
}
which.min(napake)
lin.model <- lm(data = podatki.ucni, formula = Value ~ BDPpc + I(BDPpc^2))

napaka_regresije = function(podatki, model) {
  podatki %>%
    bind_cols(Value.hat = predict(model, podatki)) %>%
    mutate(
      izguba = (Value - Value.hat) ^ 2
    ) %>%
    dplyr::select(izguba) %>%
    unlist() %>%
    mean()
}

library(ranger)
library(janitor)
p.ucni <- janitor::clean_names(podatki.ucni)
set.seed(42)

ucenje = function(podatki, formula, algoritem) {
  switch(
    algoritem,
    lin.reg = lm(formula, data = podatki),
    ng = ranger(formula, data = podatki)
  )
}

napovedi = function(podatki, model, algoritem) {
  switch(
    algoritem,
    lin.reg = predict(model, podatki),
    ng = predict(model, podatki)$predictions
  )
}

napaka_regresije = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(value.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (value - value.hat) ^ 2
    ) %>%
    dplyr::select(izguba) %>%
    unlist() %>%
    mean()
}

napaka_razvrscanja = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(value.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (value != value.hat)
    ) %>%
    dplyr::select(izguba) %>%
    unlist() %>%
    mean()
}

lin.model = p.ucni %>% ucenje(value ~ bd_ppc, "lin.reg")
p.ucni %>% napaka_regresije(lin.model, "lin.reg")

set.seed(42)
ng.reg.model = p.ucni %>% ucenje(value ~ bd_ppc, "ng")
print(p.ucni %>% napaka_regresije(ng.reg.model, "ng"))

k <- 5
formula2 <- value ~ bd_ppc

napaka.cv2 <- function(podatki, k, formula) {
  n <- nrow(podatki)
  r <- sample(1:n)

  razrez <- cut(1:n, k, labels = FALSE)

  razbitje <- split(r, razrez)

  pp.napovedi = rep(0, n)
  for (i in 1:length(razbitje)) {
    #Naučimo se modela na množici S/Si
    model = podatki[ -razbitje[[i]], ] %>% ranger(formula = formula)
    #Naučen model uporabimo za napovedi na Si
    pp.napovedi[ razbitje[[i]] ] = predict(object = model, data = podatki[ razbitje [[i]], ])$predictions

  }

  #model so učni podatki in ostalo ( razbitje[[i]]) so testni podatki.

  napaka <- mean((pp.napovedi - podatki$value)^2)
  return(napaka)
}
napaka.cv(p.ucni, 5, formula2)

formule <- c(Value ~ BDPpc,
             Value ~ BDPpc + I(BDPpc^2),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4),
             Value ~ BDPpc + I(BDPpc^2) + I(BDPpc^3) + I(BDPpc^4) +I(BDPpc^5))
napake <- rep(0, 5)
for (i in 1:5){
  formula <- formule[[i]]
  napaka <- napaka.cv(podatki.ucni, 5, formula)
  napake[i] <- napaka
}
which.min(napake)
lin.model <- lm(data = podatki.ucni, formula = Value ~ BDPpc + I(BDPpc^2))

library(iml)

# Pripravimo le napovedne spremenljivke,
# kot jih rabi funkcija Predictor$new

X = p.ucni %>% dplyr::select(bd_ppc, education)

# Funkciji Predictor$new moramo povedati
# kako napovedujemo z modelom naključnih gozdov

pfun = function(model, newdata) {
  predict(model, data = newdata, predict.all = FALSE)$predictions
}

# pripravimo najprej objekt razreda Prediktor
# prvi argument funkcije je model,
# drugi in tretji so podatki o napovednih
# in ciljni spremenljivki,
# zadnji pa funkcija za napovedovanje

reg.pred = Predictor$new(
  ng.reg.model,
  data = X, y = p.ucni$value,
  predict.fun = pfun
)

# na koncu uporabimo funkcijo FeatureImp$new
reg.moci = FeatureImp$new(reg.pred, loss = "mse")

plot(reg.moci)

slo <- tabela1 %>% filter(Country == "Slovenia")
slo <- slo[-c(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32),]
slo <- slo[-c(1, 2),]

CAC <- slo[,4]
CACs <- slo[,c(1,4)]
CACs %>% ggplot() +
  geom_line(
    mapping = aes(x = Year, y = Value),
    color = "pink"
  )
library(ranger)
Lag <- function(x, n){
  (c(rep(NA, n), x)[1 : length(x)] )
}
naredi.df <- function(x){data.frame(Value = x,
                                    Value1 = Lag(x, 1),
                                    Value2 = Lag(x, 2) ,
                                    Value3 = Lag(x, 3),
                                    Value4 = Lag(x, 4)
)
}
df <- naredi.df(CAC$Value)
model.bi = ranger(Value ~ Value1 + Value2 + Value3 + Value4, data=df %>% drop_na())
lllll <- nrow(df)
for (i in 1:5){
  df <- naredi.df(c(df$Value, NA))
  napoved = predict(model.bi,  data = df[lllll + i, ] )$predictions
  df[lllll+i, 1] = napoved
}
napovedi = df[c(15, 16, 17, 18, 19), 1]
CACs2 <- CACs
CACs2[c(15, 16, 17, 18, 19),2] = napovedi
CACs2[c(15, 16, 17, 18, 19),1] = c(2020, 2021, 2022, 2023, 2024)

nap <- ggplot(CACs2) + geom_point(aes(x = Year, y = Value, colour = Year > 2019)) +
  scale_colour_manual(name = 'Napovedi', values = setNames(c('magenta','blue'),c(T, F))) +
  xlab('Leto') + ylab('Odstotek ljudi, ki spletno nakupuje')


## Dati

mi.1 <- 1.02
var.1 <- 2.17

mi.2 <- 1.85
var.2 <- 4.65

## Svolgimento

y.negativa <- pnorm(0, mi.2, sqrt(var.2))
x.negativa <- pnorm(0, mi.1, sqrt(var.1))

pr.1 <- 1 - (x.negativa*y.negativa)
pr.2 <- (1 - x.negativa)/pr.1

print(pr.1)
print(pr.2)


#' Obtain 2x2 contingency table from marginal parameters and odds ratio
#'
#' Columns are the case and control frequencies
#' Rows are the frequencies for allele 1 and allele 2
#'
#' @param af Allele frequency of effect allele
#' @param prop Proportion of cases
#' @param odds_ratio Odds ratio
#' @param eps tolerance. Default = 1e-15
#'
#' @export
#' @return 2x2 contingency table as matrix
contingency <- function(af, prop, odds_ratio, eps=1e-15)
{
	a <- odds_ratio-1
	b <- (af+prop)*(1-odds_ratio)-1
	c_ <- odds_ratio*af*prop

	if (abs(a) < eps)
	{
		z <- -c_ / b
	} else {
		d <- b^2 - 4*a*c_
		if (d < eps*eps)
		{
			s <- 0
		} else {
			s <- c(-1,1)
		}
		z <- (-b + s*sqrt(max(0, d))) / (2*a)
	}
	y <- vapply(z, function(a) zapsmall(matrix(c(a, prop-a, af-a, 1+a-af-prop), 2, 2)), matrix(0.0, 2, 2))
	i <- apply(y, 3, function(u) all(u >= 0))
	return(y[,,i])
}

#' Estimate allele frequency from SNP
#'
#' @param g Vector of 0/1/2
#'
#' @export
#' @return Allele frequency
allele_frequency <- function(g)
{
	(sum(g == 1) + 2 * sum(g == 2)) / (2 * sum(!is.na(g)))
}

#' Estimate the allele frequency in population from case/control summary data
#'
#' @param af Effect allele frequency (or MAF)
#' @param prop Proportion of samples that are cases
#' @param odds_ratio Odds ratio
#' @param prevalence Population disease prevalence
#'
#' @export
#' @return Population allele frequency
get_population_allele_frequency <- function(af, prop, odds_ratio, prevalence)
{
	co <- contingency(af, prop, odds_ratio)
	af_controls <- co[1,2] / (co[1,2] + co[2,2])
	af_cases <- co[1,1] / (co[1,1] + co[2,1])
	af <- af_controls * (1 - prevalence) + af_cases * prevalence
	return(af)
}

#' Estimate proportion of variance of liability explained by SNP in general population
#'
#' This uses equation 10 in Genetic Epidemiology 36 : 214–224 (2012)
#'
#' @param b Log odds ratio
#' @param af allele frequency
#' @param ncase Number of cases
#' @param ncontrol number of controls
#' @param prevalence prevalence
#' @param model Is the effect size estiamted in "logit" (default) or "probit" model
#'
#' @export
#' @return Rsq
lor_to_rsq <- function(b, af, ncase, ncontrol, prevalence, model="logit")
{
	if(model == "logit")
	{
		ve <- pi^2/3
	} else if(model == "probit") {
		ve <- 1
	} else {
		stop("Model must be probit or logit")
	}
	af <- get_population_allele_frequency(af, ncase / (ncase + ncontrol), exp(b), prevalence)
	vg <- b^2 * af * (1-af)
	return(vg / (vg + ve) / 0.58)
}


#' Function that creates a sinusoidal Sea Surface Temperature (SST) curve
#' from a list of parameters
#'
#' Takes the specified parameters for amplitude, period, phase and average value
#' as well as the number of years specified and the time interval. It then
#' creates a sinusoid based on the boundary conditions. Used as intermediate
#' step during iterative modeling.
#'
#' @param T_par List of four parameters describing (in order) amplitude
#' (\code{T_amp}; in degrees C), period (\code{T_per}; in days), phase
#' (\code{T_pha} in day of the year) and average temperature (\code{T_av};
#' in degrees C)
#' @param years Length of the preferred sinusoid in number of years (defaults
#' to 1)
#' @param t_int Time interval of sinusoidal record (in days)
#' @return A matrix containing columns for time (in days) and SST (in degrees C)
#' @examples
#' # Set parameters
#' T_amp <- 20
#' T_per <- 365
#' T_pha <- 150
#' T_av <- 15
#' T_par <- c(T_amp, T_per, T_pha, T_av)
#' SST <- temperature_curve(T_par, 1, 1) # Run the function
#' @export
temperature_curve <- function(T_par, # Function to create temperature as function of time based on sinusoidal parameters
    years = 1, # Default number of years of the record = 1
    t_int = 1 #  Default time interval = 1 day
    ){

    T_amp <- T_par[1] # Seasonal SST range (degr. C)
    T_per <- T_par[2] # Period of SST seasonality (days)
    T_pha <- T_par[3] # Timing of peak in SST sinusoid (day of the year)
    T_av <- T_par[4] # Annual average SST (degr. C)

    t <- seq(0, years * T_per, t_int) # Define time axis based on the number of days in a year and the time interval. Model multiple years (default = 3) to accommodate changes in growth rate over lifetime.

    SST <- T_av + T_amp/2 * sin((2 * pi * (t - T_pha + T_per/4)) / T_per) # Create SST sinusoid based on parameters and time vector

    # Collate results and export
    res <- cbind(t, SST)
    return(res)
}


longmult <- function(xstr, ystr)
{
   #get the number described in each string
   getnumeric <- function(xstr) as.numeric(unlist(strsplit(xstr, "")))

   x <- getnumeric(xstr)
   y <- getnumeric(ystr)

   #multiply each pair of digits together
   mat <- apply(x %o% y, 1, as.character)

   #loop over columns, then rows, adding zeroes to end of each number in the matrix to get the correct positioning
   ncols <- ncol(mat)
   cols <- seq_len(ncols)
   for(j in cols)
   {
      zeroes <- paste(rep("0", ncols-j), collapse="")
      mat[,j] <- paste(mat[,j], zeroes, sep="")
   }

   nrows <- nrow(mat)
   rows <- seq_len(nrows)
   for(i in rows)
   {
      zeroes <- paste(rep("0", nrows-i), collapse="")
      mat[i,] <- paste(mat[i,], zeroes, sep="")
   }

   #add zeroes to the start of the each number, so they are all the same length
   len <- max(nchar(mat))
   strcolumns <- formatC(cbind(as.vector(mat)), width=len)
   strcolumns <- gsub(" ", "0", strcolumns)

   #line up all the numbers below each other
   strmat <- matrix(unlist(strsplit(strcolumns, "")), byrow=TRUE, ncol=len)

   #convert to numeric and add them
   mat2 <- apply(strmat, 2, as.numeric)
   sum1 <- colSums(mat2)

   #repeat the process on each of the totals, until each total is a single digit
   repeat
   {
      ntotals <- length(sum1)
      totals <- seq_len(ntotals)
      for(i in totals)
      {
         zeroes <- paste(rep("0", ntotals-i), collapse="")
         sum1[i] <- paste(sum1[i], zeroes, sep="")
      }
      len2 <- max(nchar(sum1))
      strcolumns2 <- formatC(cbind(as.vector(sum1)), width=len2)
      strcolumns2 <- gsub(" ", "0", strcolumns2)
      strmat2 <- matrix(unlist(strsplit(strcolumns2, "")), byrow=TRUE, ncol=len2)
      mat3 <- apply(strmat2, 2, as.numeric)
      sum1 <- colSums(mat3)
      if(all(sum1 < 10)) break
   }

   #Concatenate the digits together
   ans <- paste(sum1, collapse="")
   ans
}

a <- "18446744073709551616"
longmult(a, a)


# ......................................................................................
# .................. Cvičení 11. Dvou-výběrové testy/Intervalové odhady.................
# ......................... Michal Béreš, Martina Litschmannová.........................
# ......................................................................................

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

#  Přehled testů/konstrukcí IO ####
# * Párová vs. dvouvýběrová data ####
# - Párová data označují data, která jsou vstažena k dvěma měřením stejných entit ->
# datové sloupce jsou závislé.
# - Pokud jsou nezávislé, jedná se o dvouvýběrový test.
# - Pro párová data napočítáme rozdíl mezi sloupci (případně jinou funkci dle zadání) a
# použijeme jednovýběrové testy na tento rozdíl.

# ** Příklady párových dat: ####
# - měření žárovek při dvou různých teplotách (pokud každý kus je měřen dvakrát - při
# teplotě 1 a teplotě 2)
#     - zde pozor, může se stát, že jsou testy např. destruktivní a nelze měřit dvakrát
# stejnou entitu (výrobek). Potom bychom uvažovali dva nezávislé výběry, každý pro jeden
# typ měření -> nezávislé datové sloupce -> dvouvýběrové testy
# - měření hodnot v krvi pacienta před a po podání léčiva
#     - opět pozor na například testování léků ve dvou skupinách (placebo/skutečný lék)
# -> dvě nezávislé skupiny -> dvouvýběrové testy

# * Obecně k dvouvýběrovým testům/IO ####
# - test je vždy svázán s příslušným IO -> stejné podmínky pro použití
# - pokud má test podmínky použití (např.: normalita dat, symetrie dat) pak musí tuto
# podmínku splnit **oba soubory**, pokud alespoň jeden nesplňuje, považujeme předpoklad
# za porušený
# - jeden z velmi důležitých předpokladů je nezávislost dat
#     - např.: měření výrobků výrobce A a výrobků výrobce B - zde je rozumné
# předpokládat, že výrobky výrobce A jsou samostatné entity od výrobků výrobce B

# * Dvouvýběrové testy/IO - rozdíl měr polohy ####

# vyrobíme si testovací data - tak je lze použít všude
data1 = rnorm(n = 30, mean = 105, sd = 10)
data2 = rnorm(n = 30, mean = 100, sd = 10)
boxplot(data1,data2)

# ** Dvouvýběrový Studentův t-test ####
# - Testuje/odhaduje rozdíl středních hodnot: $H_0: \mu_{1} - \mu_{2} = a$
# - požadavky:
#     - Normalita dat
#     - Homoskedasticita (shoda rozptlyů)
#     - nezávislost výběrů
# - funkce musí mít parametr var.equal = TRUE

# H0: mu1 - mu2 = 2
# HA: mu1 - mu2 != 2

t.test(x = data1, y = data2, mu = 2, alternative = "two.sided",
       var.equal = TRUE, conf.level = 0.95)

# H0: mu1 - mu2 = 2
# HA: mu1 - mu2 > 2

t.test(x = data1, y = data2, mu = 2, alternative = "greater",
       var.equal = TRUE, conf.level = 0.95)

# H0: mu1 - mu2 = 2
# HA: mu1 - mu2 < 2

t.test(x = data1, y = data2, mu = 2, alternative = "less",
       var.equal = TRUE, conf.level = 0.95)

# ** Aspinové-Welshův test ####
# - Testuje/odhaduje rozdíl středních hodnot: $H_0: \mu_{1} - \mu_{2} = a$
# - požadavky:
#     - Normalita dat
#     - nezávislost výběrů
# - funkce musí mít parametr var.equal = FALSE

# H0: mu1 - mu2 = 2
# HA: mu1 - mu2 != 2

t.test(x = data1, y = data2, mu = 2, alternative = "two.sided",
       var.equal = FALSE, conf.level = 0.95)

# H0: mu1 - mu2 = 2
# HA: mu1 - mu2 > 2

t.test(x = data1, y = data2, mu = 0, alternative = "greater",
       var.equal = FALSE, conf.level = 0.95)

# H0: mu1 - mu2 = 2
# HA: mu1 - mu2 < 2

t.test(x = data1, y = data2, mu = 0, alternative = "less",
       var.equal = FALSE, conf.level = 0.95)

# ** Mannův-Whitneyův test ####
# - Testuje/odhaduje rozdíl mediánů: $H_0: X_{0.5,1} - X_{0.5,2} = a$
# - požadavky:
#     - nezávislost výběrů
#     - (stejný typ rozdělení)
# - vyžaduje conf.int = TRUE, pro spočtení IO

# H0: X0.5,1 - X0.5,2 = 2
# HA: X0.5,1 - X0.5,2 != 2

wilcox.test(x = data1, y = data2, mu = 2, alternative = "two.sided",
            conf.level=0.95, conf.int = TRUE)

# H0: X0.5,1 - X0.5,2 = 2
# HA: X0.5,1 - X0.5,2 > 2

wilcox.test(x = data1, y = data2, mu = 2, alternative = "greater",
            conf.level=0.95, conf.int = TRUE)

# H0: X0.5,1 - X0.5,2 = 2
# HA: X0.5,1 - X0.5,2 < 2

wilcox.test(x = data1, y = data2, mu = 2, alternative = "less",
            conf.level=0.95, conf.int = TRUE)

# * Dvouvýběrové testy/IO - podíl rozptylů ####
# ** F-test ####
# - Testuje/odhaduje podíl rozptylů: $H_0: \sigma^2_{1} / \sigma^2_{2} = a$
# - požadavky:
#     - normalita dat
#     - nezávislost výběrů

# H0: sigma1^2/sigma2^2 = 1
# H0: sigma1^2/sigma2^2 != 1

var.test(x = data1, y = data2, ratio = 1, alternative = "two.sided",
         conf.level = 0.95)

# H0: sigma1^2/sigma2^2 = 1
# H0: sigma1^2/sigma2^2 > 1

var.test(x = data1, y = data2, ratio = 1, alternative = "greater",
         conf.level = 0.95)

# H0: sigma1^2/sigma2^2 = 1
# H0: sigma1^2/sigma2^2 < 1

var.test(x = data1, y = data2, ratio = 1, alternative = "less",
         conf.level = 0.95)

# ** Leveneův test ####
# - Testuje rovnost rozptylů: $H_0: \sigma^2_{1} = \sigma^2_{2}$ !
# - požadavky:
#     - nezávislost výběrů
# - vyžaduje data ve standardním datovém formátu
# - funkce leveneTest v balíčku car

# vyrobíme data ve standardním datovém formátu

data1.df = as.data.frame(data1)
data1.df$typ = "d1"
colnames(data1.df) = c("data", "typ")

data2.df = as.data.frame(data2)
data2.df$typ = "d2"
colnames(data2.df) = c("data", "typ")

data = rbind(data1.df, data2.df)
data$typ = as.factor(data$typ)

head(data)

# install.packages("car")

# H0: sigma1^2 = sigma2^2
# HA: sigma1^2 != sigma2^2

car::leveneTest(data$data ~ data$typ)

# * Dvouvýběrové testy/IO - rozdíl pravděpodobností ####
# ** Test homogenity dvou binomických rozdělení ####
# - Testuje shodu/odhaduje rozdíl pravděpodobností: $H_0: \pi_{1} - \pi_{2} = 0$
# - požadavky:
#     - dostatečná velikost výběrů: $n_i>\frac{9}{p_i(1-p_i)}$
#     - nezávislost výběrů

# vyrobíme si vhodná data
pi1 = 0.4
pi2 = 0.3

dp1 = runif(n = 100, min = 0, max = 1) < pi1
dp2 = runif(n = 130, min = 0, max = 1) < pi2

x1 = sum(dp1)
n1 = length(dp1)

x2 = sum(dp2)
n2 = length(dp2)

x1
n1
x2
n2

# H0: pi1 - pi2 = 0
# HA: pi1 - pi2 != 0

prop.test(x = c(x1, x2), n = c(n1, n2), alternative="two.sided",
          conf.level=0.95)

# H0: pi1 - pi2 = 0
# HA: pi1 - pi2 > 0

prop.test(x = c(x1, x2), n = c(n1, n2), alternative="greater",
          conf.level=0.95)

# H0: pi1 - pi2 = 0
# HA: pi1 - pi2 < 0

prop.test(x = c(x1, x2), n = c(n1, n2), alternative="less",
          conf.level=0.95)

#  Příklady ####
# * Příkald 1. ####
# Data v souboru cholesterol2.xls udávají hladinu cholesterolu v krvi mužů dvou různých
# věkových skupin (20-30 letých a 40-50 letých). Ověřte na hladině významnosti 0,05
# hypotézu, zda se hladina cholesterolu v krvi starších mužů neliší od hladiny
# cholesterolu v krvi mladších mužů.

# Načtení dat
chol = readxl::read_excel("./CV11/data/testy_dvouvyberove.xlsx",
                  sheet = "cholesterol2",
                  skip = 1)
colnames(chol)=c("mladsi","starsi")
head(chol)

# Převod do standardního datového formátu
chol.s = stack(chol)
chol.s = na.omit(chol.s)
colnames(chol.s) = c ("hodnoty","skupina")
head(chol.s)

# Explorační analýza
boxplot(chol.s$hodnoty ~ chol.s$skupina)

# Odstranění odlehlých pozorování:
chol.s$hodnoty.bez = chol.s$hodnoty

pom = boxplot(chol.s$hodnoty[chol.s$skupina == "mladsi"], plot = FALSE)
chol.s$hodnoty.bez[chol.s$skupina == "mladsi" &
                   chol.s$hodnoty %in% pom$out] = NA

pom = boxplot(chol.s$hodnoty[chol.s$skupina == "starsi"], plot = FALSE)
chol.s$hodnoty.bez[chol.s$skupina == "starsi" &
                   chol.s$hodnoty %in% pom$out] = NA

boxplot(chol.s$hodnoty.bez~chol.s$skupina)

# pozor v datech máme NA a musíme s tím dále počítat!!!
# (např. u zjištění délky)

library(dplyr)

chol.s %>%  group_by(skupina) %>%
            summarise(pocet = sum(!is.na(hodnoty.bez)),
                      prumer = mean(hodnoty.bez, na.rm = TRUE),
                      smer.odch = sd(hodnoty.bez, na.rm = TRUE))

# zaokrouhlování -> 3 platné cifry -> dle sd na tisíciny

# **Test o shodě středních hodnot / mediánů**

# Ověření normality
chol.s %>%  group_by(skupina) %>%
            summarise(norm.pval = shapiro.test(hodnoty.bez)$p.value)

# normalita na hl. významnosti 0.05 OK

# Ověření shody rozptylů

# Exploračně
rozptyly = chol.s %>%  group_by(skupina) %>%
            summarise(rozptyl = sd(hodnoty.bez, na.rm = TRUE)^2)
rozptyly
max(rozptyly$rozptyl)/min(rozptyly$rozptyl)

# explorační posouzení: poměr nejvetšího ku nejmenšímu je > než 2
# -> nepředpokládám shodu rozptylu

# Exaktně pomocí F-testu

# H0: sigma.starsi = sigma.mladsi
# Ha: sigma.starsi <> sigma.mladsi

# vyberu si žádaná data
starsi.bez = chol.s$hodnoty.bez[chol.s$skupina == "starsi"]
mladsi.bez = chol.s$hodnoty.bez[chol.s$skupina == "mladsi"]

var.test(x = starsi.bez, y = mladsi.bez, ratio = 1, conf.level=0.95)

# Na hl. významnosti 0.05 zamítáme předpoklad o shodě rozptylů
# Pozorovanou neshodu mezi rozptyly lze na hladině významnosti 0,05
# označit za statisticky významnou.

# Ověření shody středních hodnot (Aspinové-Welchův test)

# H0: mu.starsi - mu.mladsi = 0
# Ha: mu.starsi - mu.mladsi != 0

t.test(x = starsi.bez, y = mladsi.bez, mu = 0,
       alternative = "two.sided", var.equal=FALSE, conf.level=0.95)

# na hl. významnosti 0.05 zamítáme H0-> existuje stat. významný rozdíl.

# H0: mu.starsi = mu.mladsi (mu.starsi - mu.mladsi = 0)
# Ha: mu.starsi > mu.mladsi (mu.starsi - mu.mladsi > 0)

t.test(x = starsi.bez, y = mladsi.bez, mu = 0, alternative = "greater",
       var.equal = FALSE, conf.level = 0.95)

# Na hladině významnosti 0,05 zamítáme předpoklad o shodě středních
# hodnot cholesterolu ve skupinách mladších a starších mužů ve prospěch
# alternativy, že starší muži mají vyšší střední hladinu cholesterolu
# než muži mladší
# Dle výsledků výběrového šetření očekáváme, že střední obsah
# cholesterolu v krvi straších mužů bude cca o 0,524 mmol/l vyšší než
# střední obsah chol. u mladších mužů. Dle 95% levostranný interv.
# odhadu daného rozdílu očekáváme střední obsah cholesterolu u
# starších mužů minimálně o 0,457 mmol/l větší než stř. hodnota
# cholesterolu u mladších mužů.

# * Příklad 2. ####
# Údaje v souboru deprese.xls představují délku remise ve dnech z prostého náhodného
# výběru ze dvou různých skupin pacientů (pacienti s endogenní depresi a pacienti s
# neurotickou depresí). Ověřte, zda je pozorovaný rozdíl mezi průměrnou délkou remise u
# těchto dvou skupin pacientů statisticky významný.

# Načtení dat z xlsx souboru (pomoci balíčku readxl)
deprese = readxl::read_excel("data/testy_dvouvyberove.xlsx",
                     sheet = "deprese")
colnames(deprese)=c("endo","neuro")

head(deprese)

# Převod do standardního datového formátu
deprese.s = stack(deprese)
deprese.s = na.omit(deprese.s)
colnames(deprese.s) = c ("hodnoty","skupina")

head(deprese.s)

# Explorační analýza
boxplot(deprese.s$hodnoty~deprese.s$skupina)

# Data neobsahují odlehlá pozorování.

library(dplyr)

deprese.s %>%  group_by(skupina) %>%
                summarise(pocet = length(hodnoty),
                          prumer = mean(hodnoty),
                          smer.odch = sd(hodnoty))

# zaokrouhlování -> 3 platné cifry -> dle sd na jednotky

# **Test o shodě středních hodnot / mediánů**

# Ověření normality
# Předpoklad normality ověříme Shapirovovým - Wilkovovým testem.
deprese.s %>%  group_by(skupina) %>%
                summarise(norm.pval = shapiro.test(hodnoty)$p.value)

# Na hl. významnosti 0,05 zamítáme předpoklad normality

# alespoň orientačne zkontrolujeme podobnost rozdělení

# vybereme si data pro jednodušší spracování

neuro = deprese.s$hodnoty[deprese.s$skupina == "neuro"]
endo = deprese.s$hodnoty[deprese.s$skupina == "endo"]

par(mfrow = c(1,2))
hist(neuro)
hist(endo)

# Ověření shody mediánů (Mannův - Whitneyho test)

# Dle histogramů předpokládáme, že data mají stejný typ rozdělení.

# H0: med.neuro = med.endo (med.neuro - med.endo = 0)
# Ha: med.neuro != med.endo (med.neuro - med.endo != 0)

wilcox.test(x = neuro, y = endo, mu = 0, alternative = "two.sided",
            conf.level=0.95, conf.int = TRUE)

# na hl. významnosti 0.05 zamítáme H0-> existuje stat. významný rozdíl

# H0: med.neuro = med.endo (med.neuro - med.endo = 0)
# Ha: med.neuro > med.endo (med.neuro - med.endo > 0)

wilcox.test(x = neuro, y = endo, mu = 0, alternative = "greater",
            conf.level=0.95, conf.int = TRUE)

# Na hladině významnosti 0,05 zamítáme hyp. o shodě mediánů dob do
# remise onemocnění pro obě skupiny pacientů ve prospěch alternativy

# Medián doby remise je u pacientů s neurotickou depresí statisticky
# významně větší než u pacientů s endogenní depresí.

# Doba remise pacientů s neurotickou depresí je cca o 191 dnů delší
# než u pacientů s endogenní depresí. Dle 95% levostranného
# intervalového odhadu očekáváme, že pacienti s neuro. depresí mají
# minimálně o 168 dní delší dobu remise než pacienti s endo. depresí.

# * Příklad 3. ####
# Sledujeme osmolalitu moči na lůžkové stanici v 08:00 hodin a v 11:00 hodin u 16 mužů.
# Na základě výsledků uvedených v souboru osmolalita.xls ověřte, zda se osmolalita
# statisticky významně zvýšila.

# Načtení dat
osmolalita = readxl::read_excel("data/testy_dvouvyberove.xlsx",
                        sheet = "osmolalita", skip = 1)
osmolalita = osmolalita[,c(2,3)]
colnames(osmolalita)=c("o8","o11")
head(osmolalita)

# Výpočet nárůstu osmolality
osmolalita$narust = osmolalita$o11 -  osmolalita$o8

# Explorační analýza
par(mfrow = c(1,1))
boxplot(osmolalita$narust)

# Data obsahují odlehlá pozorování.

# Odstranění odlehlých hodnot
pom = boxplot(osmolalita$narust,plot = F)

osmolalita$narust.bez = osmolalita$narust
osmolalita$narust.bez[osmolalita$narust %in% pom$out] = NA

boxplot(osmolalita$narust.bez)

# Explorační analýza pro data bez odlehlých pozorování
library(dplyr)

osmolalita %>% summarise(pocet = sum(!is.na(narust.bez)),
                         prumer = mean(narust.bez, na.rm = TRUE),
                         smer.odch = sd(narust.bez, na.rm = TRUE))

# zaokrouhlování -> 2 platné cifry -> dle sd na jednotky

# Ověření normality
# Předpoklad normality ověříme Shapirovým - Wilkovým testem.
shapiro.test(osmolalita$narust.bez)
# Na hl. významnosti 0.05 nelze předpoklad normality zamítnout
# (Shapirův-Wilkův test, W = 0,949, p-hodnota=0,545).

# Párový t-test
# H0: mu.narust = 0 mm
# Ha: mu.narust > 0 mm

t.test(osmolalita$narust.bez, mu = 0, alternative = "greater")

# Dle výběrového šetření lze očekávat, že osmolalita moči se
# mezi 8 a 11 hodinou zvýší o cca 24 mmol/kg. Dle 95% intervalového odhadu
# lze očekávat, že dojde k navýšení osmolality minimálně o 10 mmol/kg).
# Na hladině významnosti 0,05 lze tento nárůst označit za statisticky
# významný (párový t-test, t = 3,1, df = 13, p-hodnota = 0,005).

# * Příklad 4. ####
# Byly testovány polovodičové součástky dvou výrobců - MM a PP. MM prohlašuje, že její
# výrobky mají nižší procento vadných kusů. Pro ověření tohoto tvrzení bylo z produkce
# MM náhodně vybráno 200 součástek, z nichž 14 bylo vadných. Podobný experiment byl
# proveden u firmy PP s výsledkem 10 vadných ze 100 náhodně vybraných součástek.
# ** a)  ####
# Otestujte tvrzení firmy MM čistým testem významnosti.

x.MM = 14
n.MM = 200
p.MM = x.MM/n.MM
p.MM

x.PP = 10
n.PP = 100
p.PP = x.PP/n.PP
p.PP

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

# Dále pro obě firmy předpokládáme, že  n/N < 0.05, tj. že daná populace (součástek) má
# rozsah
# alespoň 20 * n, tj. 20 * 200 (4 000), resp. 20 * 150 (3 000) součástek, což je asi
# vcelku reálný předpoklad.

# Pearsonův X2 test
# H0: pi.PP = pi.MM
# Ha: pi.PP > pi.MM

prop.test(x = c(x.PP,x.MM),n = c(n.PP,n.MM), alternative = "greater",
          conf.level = 0.95)

# Vzhledem k p-hodnotě > hl. významnosti 0.05 nezamítáme H0 - tedy předpokl.
# shodné chybovosti. Nelze tedy říci, že firma MM má kvalitnější produkci.

# Pearsonův X2 test
# H0: pi.PP = pi.MM
# Ha: pi.PP != pi.MM

prop.test(x = c(x.PP,x.MM),n = c(n.PP,n.MM), alternative = "two.sided",
          conf.level = 0.95)

# ** b)  ####
# Otestujte tvrzení firmy MM prostřednictvím intervalového odhadu na hladině významnosti
# 0,05.

# Na základě 95% Clopperova - Pearsonova pravostranného intervalového odhadu
# (-0,036; 1,000) lze pozorovaný rozdíl v kvalitě výroby označit za
# statisticky nevýznamný. Ke stejným závěrům můžeme dojít i na základě
# Pearsonova pravostranného testu


###############################################
#########  Data Analysis French MTPL2
#########  GLM, Regression Trees and Boosting
#########  Author: Mario Wuthrich
#########  Version May 6, 2018
#########  See also: https://papers.ssrn.com/sol3/papers.cfm?abstract_id=3164764
###############################################

###############################################
#########  load packages and data
###############################################

require(MASS)
library(CASdatasets)
require(stats)
library(data.table)
library(plyr)
library(rpart)
library(rpart.plot)
library(Hmisc)

data(freMTPL2freq)
dat <- freMTPL2freq
dat$VehGas <- factor(dat$VehGas)      # consider VehGas as categorical
dat$n <- 1                            # intercept
dat$ClaimNb <- pmin(dat$ClaimNb, 4)   # correct for unreasonable observations (that might be data error)
dat$Exposure <- pmin(dat$Exposure, 1) # correct for unreasonable observations (that might be data error)
str(dat)

###############################################
#########  Poisson deviance statistics
###############################################

Poisson.Deviance <- function(pred, obs){
     2*(sum(pred)-sum(obs)+sum(log((obs/pred)^(obs))))/length(pred)
               }

###############################################
#########  feature pre-processing for GLM
###############################################

dat2 <- dat
dat2$AreaGLM <- as.integer(dat2$Area)
dat2$VehPowerGLM <- as.factor(pmin(dat2$VehPower,9))
VehAgeGLM <- cbind(c(0:110), c(1, rep(2,10), rep(3,100)))
dat2$VehAgeGLM <- as.factor(VehAgeGLM[dat2$VehAge+1,2])
dat2[,"VehAgeGLM"] <-relevel(dat2[,"VehAgeGLM"], ref="2")
DrivAgeGLM <- cbind(c(18:100), c(rep(1,21-18), rep(2,26-21), rep(3,31-26), rep(4,41-31), rep(5,51-41), rep(6,71-51), rep(7,101-71)))
dat2$DrivAgeGLM <- as.factor(DrivAgeGLM[dat2$DrivAge-17,2])
dat2[,"DrivAgeGLM"] <-relevel(dat2[,"DrivAgeGLM"], ref="5")
dat2$BonusMalusGLM <- as.integer(pmin(dat2$BonusMalus, 150))
dat2$DensityGLM <- as.numeric(log(dat2$Density))
dat2[,"Region"] <-relevel(dat2[,"Region"], ref="R24")
dat2$AreaRT <- as.integer(dat2$Area)
dat2$VehGasRT <- as.integer(dat2$VehGas)
str(dat2)

###############################################
#########  choosing learning and test sample
###############################################

set.seed(100)
ll <- sample(c(1:nrow(dat2)), round(0.9*nrow(dat2)), replace = FALSE)
learn <- dat2[ll,]
test <- dat2[-ll,]
(n_l <- nrow(learn))
(n_t <- nrow(test))

###############################################
#########  GLM analysis
###############################################

### Model GLM1
d.glm1 <- glm(ClaimNb ~ VehPowerGLM + VehAgeGLM + DrivAgeGLM + BonusMalusGLM
                        + VehBrand + VehGas + DensityGLM + Region + AreaGLM,
                        data=learn, offset=log(Exposure), family=poisson())

summary(d.glm1)
#anova(d.glm1)   # this calculation takes a bit of time

learn$fitGLM <- fitted(d.glm1)
test$fitGLM <- predict(d.glm1, newdata=test, type="response")

glmfit_alldata<-c(as.vector(learn$fitGLM),as.vector(test$fitGLM))
ids<-c(learn$IDpol,test$IDpol)
srtperm<-order(ids)
ids[srtperm]
is.unsorted(ids[srtperm])

# in-sample and out-of-sample losses (in 10^(-2))
(insampleGLM <- 100*Poisson.Deviance(learn$fitGLM, learn$ClaimNb))
100*Poisson.Deviance(test$fitGLM, test$ClaimNb)

###############################################
#########  Regressionn tree analysis
###############################################

### Model RT2
t0<-Sys.time()
tree1 <- rpart(cbind(Exposure,ClaimNb) ~ AreaRT + VehPower + VehAge + DrivAge + BonusMalus + VehBrand + VehGasRT + Density + Region,
            learn, method="poisson",
            control=rpart.control(xval=1, minbucket=10000, cp=0.00001))
ela<-Sys.time()-t0
rpart.plot(tree1)        # plot tree
tree1                    # show tree with all binary splits
printcp(tree1)           # cost-complexit statistics

learn$fitRT <- predict(tree1)*learn$Exposure
test$fitRT <- predict(tree1, newdata=test)*test$Exposure
100*Poisson.Deviance(learn$fitRT, learn$ClaimNb)
100*Poisson.Deviance(test$fitRT, test$ClaimNb)

average_loss <- cbind(tree1$cptable[,2], tree1$cptable[,3], tree1$cptable[,3]* tree1$frame$dev[1] / n_l)
plot(x=average_loss[,1], y=average_loss[,3]*100, type='l', col="blue", ylim=c(30.5,33.5), xlab="number of splits", ylab="average in-sample loss (in 10^(-2))", main="decrease of in-sample loss")
points(x=average_loss[,1], y=average_loss[,3]*100, pch=19, col="blue")
abline(h=c(insampleGLM), col="green", lty=2)
legend(x="topright", col=c("blue", "green"), lty=c(1,2), lwd=c(1,1), pch=c(19,-1), legend=c("Model RT2", "Model GLM1"))

# cross-validation and cost-complexity pruning
K <- 10                  # K-fold cross-validation value
set.seed(100)
xgroup <- rep(1:K, length = nrow(learn))
xfit <- xpred.rpart(tree1, xgroup)
(n_subtrees <- dim(tree1$cptable)[1])
std1 <- numeric(n_subtrees)
err1 <- numeric(n_subtrees)
err_group <- numeric(K)
for (i in 1:n_subtrees){
 for (k in 1:K){
  ind_group <- which(xgroup ==k)
  err_group[k] <- Poisson.Deviance(learn[ind_group,"Exposure"]*xfit[ind_group,i],learn[ind_group,"ClaimNb"])
               }
  err1[i] <- mean(err_group)
  std1[i] <- sd(err_group)
   }

x1 <- log10(tree1$cptable[,1])
xmain <- "cross-validation error plot"
xlabel <- "cost-complexity parameter (log-scale)"
ylabel <- "CV error (in 10^(-2))"
errbar(x=x1, y=err1*100, yplus=(err1+std1)*100, yminus=(err1-std1)*100, xlim=rev(range(x1)), col="blue", main=xmain, ylab=ylabel, xlab=xlabel)
lines(x=x1, y=err1*100, col="blue")
abline(h=c(min(err1+std1)*100), lty=1, col="orange")
abline(h=c(min(err1)*100), lty=1, col="magenta")
abline(h=c(insampleGLM), col="green", lty=2)
legend(x="topright", col=c("blue", "orange", "magenta", "green"), lty=c(1,1,1,2), lwd=c(1,1,1,1), pch=c(19,-1,-1,-1), legend=c("tree1", "1-SD rule", "min.CV rule", "Model GLM1"))

# prune to appropriate cp constant
printcp(tree1)
tree2 <- prune(tree1, cp=0.00003)
printcp(tree2)

learn$fitRT2 <- predict(tree2)*learn$Exposure
test$fitRT2 <- predict(tree2, newdata=test)*test$Exposure
100*Poisson.Deviance(learn$fitRT2, learn$ClaimNb)
100*Poisson.Deviance(test$fitRT2, test$ClaimNb)

###############################################
#########  Poisson regression tree boosting
###############################################

### Model PBM3
J0 <- 3       # depth of tree
M0 <- 50      # iterations
nu <- 1       # shrinkage constant

learn$fitPBM <- learn$Exposure
test$fitPBM  <- test$Exposure

for (m in 1:M0){
    PBM.1 <- rpart(cbind(fitPBM,ClaimNb) ~ AreaRT + VehPower + VehAge + DrivAge + BonusMalus + VehBrand + VehGasRT + Density + Region,
             data=learn, method="poisson",
             control=rpart.control(maxdepth=J0, maxsurrogate=0, xval=1, minbucket=10000, cp=0.00001))
             if(m>1){
                   learn$fitPBM <- learn$fitPBM * predict(PBM.1)^nu
                   test$fitPBM <- test$fitPBM * predict(PBM.1, newdata=test)^nu
                   } else {
                   learn$fitPBM <- learn$fitPBM * predict(PBM.1)
                   test$fitPBM <- test$fitPBM * predict(PBM.1, newdata=test)
                   }
              }

100*Poisson.Deviance(learn$fitPBM, learn$ClaimNb)
100*Poisson.Deviance(test$fitPBM, test$ClaimNb)

RCode/Noll Salzmann Wuethrich FreMTPL2 Part 1 (GLM, RT, PBM).r


##################################################################################################################
#########  WHO 2007                                                                                #####
#########  Department of Nutrition for Health and Development                                                #####
#########  World Health Organization                                                                         #####
#########  Last modified on 08/10/2013     -     Developed using R version 3.0.1 (2013-05-16)                #####
#########  This code corcerns the  the calculation of prevalences using all vallid z-scores (non-missing)    #####
#########  for three indicators: weight-for-age (5 to 10 years), height-for-age (5 to 19 years) and BMI-for- #####
#########  age (5 to 19 years) based on the WHO 2007 references.                                             #####
#########  Exact age must be given in months (no rounding necessary), height in centimeters and weight in    #####
#########  kilograms.                                                                                #####
##################################################################################################################
##################################################################################################################

##################################################################################################################
#########  Functions for calculating the z-scores and prevalences for a nutritional survey                   #####
##################################################################################################################

########################################################################
#### Auxiliar functions
########################################################################

#############################################################################
##### Prevalence calculation for the upper bound and corresponding 95% C.I.
#############################################################################

prevph.L <- function(a,x,w) {
   ph <- sum((x > a)*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum((!is.na(x))*w,na.rm=T))+(1/(2*sum((!is.na(x))*w,na.rm=T)))
   vec <- c(rounde(sum((!is.na(x))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), min(1,ph+aux))*100,digits=1))
   return(vec)
   }

#### With oedema (only for weight-for-age and bmi-for-age)

prevph <- function(a,x,w,f) {
   f<-as.character(f)
   ph <- sum((x > a)*w,na.rm=T)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T))+(1/(2*sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)))
   vec <- c(rounde(sum(((!is.na(x)) | (f=="y"))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), min(1,ph+aux))*100,digits=1))
   return(vec)
   }

#############################################################################
##### Prevalence calculation for the lower bound and corresponding 95% C.I.
#############################################################################

#### Without oedema (for height-for-age)

prevnh.L <- function(a,x,w) {
   ph <- sum((x < a)*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum((!is.na(x))*w,na.rm=T))+(1/(2*sum((!is.na(x))*w,na.rm=T)))
   vec <- c(rounde(sum((!is.na(x))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), min(1,ph+aux))*100,digits=1))
   return(vec)
   }

#### With oedema  (for all weight-related indicators)

prevnh <- function(a,x,w,f) {
   f<-as.character(f)
   ph <- sum((x < a | f=="y")*w,na.rm=T)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)
   aux <- 1.96*sqrt(ph*(1-ph)/sum(((!is.na(x)) | (f=="y"))*w,na.rm=T))+(1/(2*sum(((!is.na(x)) | (f=="y"))*w,na.rm=T)))
   vec <- c(rounde(sum(((!is.na(x)) | (f=="y"))*w,na.rm=T),digits=0),rounde(c(ph, max(0,ph-aux), min(1,ph+aux))*100,digits=1))
   return(vec)
   }

###########################################
#### Weighted mean  and standard deviation
###########################################

wmean <- function(x,w) { return(rounde(sum(x*w,na.rm=T)/sum(w[!is.na(x)]),digits=2) )  }

wsd <- function(x,w) {
   mh <- sum(x*w,na.rm=T)/sum((!is.na(x))*w,na.rm=T)
   sdh<-ifelse(length(x[!is.na(x)])>0,rounde(sqrt(sum(((x-mh)^2)*w,na.rm=T)/(sum((!is.na(x))*w,na.rm=T) - 1)),digits=2),NA)
   return( sdh )
   }

###########################################################################################
#### Rounding function - SPlus default rounding function uses the nearest even number rule
###########################################################################################

rounde <- function(x,digits=0) {
	expo<-10^digits
	return(ifelse(abs(x*expo) - floor(abs(x*expo)) < 0.5, sign(x*expo) * floor(abs(x*expo)), sign(x*expo) * (floor(abs(x*expo)) + 1))/expo)
}

######################################################################################
### Function for calculating individual height-for-age z-scores
######################################################################################

calc.zhfa<-function(mat,hfawho2007){

for(i in 1:length(mat$age.mo)) {

	if(!is.na(mat$age.mo[i]) & mat$age.mo[i]>=61 & mat$age.mo[i]<229) {

	### Interpolated l,m,s values

			low.age<-trunc(mat$age.mo[i])
          upp.age<-trunc(mat$age.mo[i]+1)
			diff.age<-(mat$age.mo[i]-low.age)

			if(diff.age>0) {
			l.val<-hfawho2007$l[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]]+diff.age*( hfawho2007$l[hfawho2007$age==upp.age & hfawho2007$sex==mat$sex[i]]-hfawho2007$l[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]] )
			m.val<-hfawho2007$m[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]]+diff.age*( hfawho2007$m[hfawho2007$age==upp.age & hfawho2007$sex==mat$sex[i]]-hfawho2007$m[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]] )
			s.val<-hfawho2007$s[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]]+diff.age*( hfawho2007$s[hfawho2007$age==upp.age & hfawho2007$sex==mat$sex[i]]-hfawho2007$s[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]] )
			} else {
				l.val<-hfawho2007$l[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]]
				m.val<-hfawho2007$m[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]]
				s.val<-hfawho2007$s[hfawho2007$age==low.age & hfawho2007$sex==mat$sex[i]]
			}
		mat$zhfa[i]<-(((mat$height[i]/m.val)^l.val)-1)/(s.val*l.val)

	}	else mat$zhfa[i]<- NA

}
return(mat)
}

######################################################################################
### Function for calculating individual weight-for-age z-scores
######################################################################################

calc.zwei<-function(mat,wfawho2007){

for(i in 1:length(mat$age.mo)) {

	if(!is.na(mat$age.mo[i])  & mat$age.mo[i]>=61 & mat$age.mo[i]<121 & mat$oedema[i]!="y") {

	### Interpolated l,m,s values

			low.age<-trunc(mat$age.mo[i])
          upp.age<-trunc(mat$age.mo[i]+1)
			diff.age<-(mat$age.mo[i]-low.age)

			if(diff.age>0) {
			l.val<-wfawho2007$l[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]]+diff.age*( wfawho2007$l[wfawho2007$age==upp.age & wfawho2007$sex==mat$sex[i]]-wfawho2007$l[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]] )
			m.val<-wfawho2007$m[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]]+diff.age*( wfawho2007$m[wfawho2007$age==upp.age & wfawho2007$sex==mat$sex[i]]-wfawho2007$m[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]] )
			s.val<-wfawho2007$s[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]]+diff.age*( wfawho2007$s[wfawho2007$age==upp.age & wfawho2007$sex==mat$sex[i]]-wfawho2007$s[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]] )
			} else {
				l.val<-wfawho2007$l[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]]
				m.val<-wfawho2007$m[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]]
				s.val<-wfawho2007$s[wfawho2007$age==low.age & wfawho2007$sex==mat$sex[i]]
			}

		mat$zwfa[i]<-(((mat$weight[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zwfa[i]) & mat$zwfa[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zwfa[i]<- 3+((mat$weight[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zwfa[i]) & mat$zwfa[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zwfa[i]<- (-3)+((mat$weight[i]-sd3neg)/sd23neg)
						}

		} else mat$zwfa[i]<-NA
}
return(mat)
}

######################################################################################
### Function for calulating individual BMI-for-age z-scores
######################################################################################

calc.zbmi<-function(mat,bfawho2007){

for(i in 1:length(mat$age.mo)) {

	if(!is.na(mat$age.mo[i]) & mat$age.mo[i]>=61 & mat$age.mo[i]<229 & mat$oedema[i]!="y") {

	### Interpolated l,m,s values

			low.age<-trunc(mat$age.mo[i])
          upp.age<-trunc(mat$age.mo[i]+1)
			diff.age<-(mat$age.mo[i]-low.age)

			if(diff.age>0) {
			l.val<-bfawho2007$l[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]]+diff.age*( bfawho2007$l[bfawho2007$age==upp.age & bfawho2007$sex==mat$sex[i]]-bfawho2007$l[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]] )
			m.val<-bfawho2007$m[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]]+diff.age*( bfawho2007$m[bfawho2007$age==upp.age & bfawho2007$sex==mat$sex[i]]-bfawho2007$m[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]] )
			s.val<-bfawho2007$s[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]]+diff.age*( bfawho2007$s[bfawho2007$age==upp.age & bfawho2007$sex==mat$sex[i]]-bfawho2007$s[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]] )
			} else {
				l.val<-bfawho2007$l[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]]
				m.val<-bfawho2007$m[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]]
				s.val<-bfawho2007$s[bfawho2007$age==low.age & bfawho2007$sex==mat$sex[i]]
			}

		mat$zbfa[i]<-(((mat$cbmi[i]/m.val)^l.val)-1)/(s.val*l.val)
		if(!is.na(mat$zbfa[i]) & mat$zbfa[i]>3) {
						sd3pos<- m.val*((1+l.val*s.val*3)^(1/l.val))
						sd23pos<- sd3pos- m.val*((1+l.val*s.val*2)^(1/l.val))
						mat$zbfa[i]<- 3+((mat$cbmi[i]-sd3pos)/sd23pos)
						}
		if(!is.na(mat$zbfa[i]) & mat$zbfa[i]< (-3)) {
						sd3neg<- m.val*((1+l.val*s.val*(-3))**(1/l.val))
						sd23neg<- m.val*((1+l.val*s.val*(-2))**(1/l.val))-sd3neg
						mat$zbfa[i]<- (-3)+((mat$cbmi[i]-sd3neg)/sd23neg)
						}

		} else mat$zbfa[i]<-NA

}

return(mat)
}

###################################################################################
#### Main function starts here: who2007
###################################################################################

###############################################################################################################################################
#### This function can be used to:
#### 1. Calculate the z-scores for the indicators: height-for-age, weight-for-age and body mass index-for-age
####    The output file with z-scores values is exported the file to an Excel spreadsheet (see readme file);
#### 2. Calculate the prevalence rates of stunting, underweight, wasting and overweight, and z-scores means and standard deviations. Results
####    are exported to an Excel spreadsheet, displayed by age group.
###############################################################################################################################################

#############################################################################
##### Function for calculating the z-scores for all indicators
#############################################################################

who2007 <- function(FileLab="Temp",FilePath="C:\\Documents and Settings",mydf,sex,age,weight,height,oedema=rep("n",dim(mydf)[1]),sw=rep(1,dim(mydf)[1])) {

#############################################################################
###########   Calculating the z-scores for all indicators
#############################################################################

   old <- options(warn=(-1))

   sex.x<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(sex))])
   age.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(age))])
   weight.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(weight))])
   height.x<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(height))])
   if(!missing(oedema)) oedema.vec<-as.character(get(deparse(substitute(mydf)))[,deparse(substitute(oedema))]) else oedema.vec<-oedema
   if(!missing(sw))	sw<-as.double(get(deparse(substitute(mydf)))[,deparse(substitute(sw))])	else sw<-as.double(sw)
   sw<-ifelse(is.na(sw),0,sw)

	sex.vec<-NULL
   sex.vec<-ifelse(sex.x!="NA" & (sex.x=="m" | sex.x=="M" | sex.x=="1"),1,ifelse(sex.x!="NA" & (sex.x=="f" | sex.x=="F" | sex.x=="2"),2,NA))
	age.vec<-age.x
	height.vec<-height.x
   oedema.vec<-ifelse(oedema.vec=="n" | oedema.vec=="N","n",ifelse(oedema.vec=="y" | oedema.vec=="Y","y","n"))

   mat<-cbind.data.frame(age.x,as.double(sex.vec),weight.x,height.x,oedema.vec,sw,stringsAsFactors=F)
	names(mat)<-c("age.mo","sex","weight","height","oedema","sw")

	mat$cbmi<-mat$weight/((height.vec/100)^2)
	mat$zhfa<-NULL
	mat$fhfa<-NULL
	mat$zwfa<-NULL
	mat$fwfa<-NULL
	mat$zbfa<-NULL
	mat$fbfa<-NULL

#############################################################################
###########   Calculating the z-scores for all indicators
#############################################################################

cat("Please wait while calculating z-scores...\n")

### Height-for-age z-score

mat<-calc.zhfa(mat,hfawho2007)

### Weight-for-age z-score

mat<-calc.zwei(mat,wfawho2007)

### BMI-for-age z-score

mat<-calc.zbmi(mat,bfawho2007)

#### Rounding the z-scores to two decimals

			mat$zhfa<-rounde(mat$zhfa,digits=2)
			mat$zwfa<-rounde(mat$zwfa,digits=2)
			mat$zbfa<-rounde(mat$zbfa,digits=2)

#### Flagging z-score values for individual indicators

			mat$fhfa<-ifelse(abs(mat$zhfa) > 6,1,0)
			mat$fwfa<-ifelse(mat$zwfa > 5 | mat$zwfa < (-6),1,0)
			mat$fbfa<-ifelse(abs(mat$zbfa) > 5,1,0)

if(is.na(mat$age.mo) & mat$oedema=="y") {
mat$fhfa<-NA
mat$zwfa<-NA
mat$zbfa<-NA
}

mat<-cbind.data.frame(mydf,mat[,-c(2:6)])

###################################################################################################
######### Export data frame with z-scores and flag variables
###################################################################################################

assign("matz",mat,envir = .GlobalEnv)

write.table(matz, file=paste(FilePath,"\\",FileLab,"_z.csv",sep=""),na="",row.names = FALSE,sep=",",quote = TRUE)

cat(paste("Z-scores calculated and exported to ",FilePath,"\\",FileLab,"_z.csv\n\n",sep=""))

#######################################################################################################
#### Calculating prevalences and summary statistics.
#######################################################################################################

if(any(sw <0)) stop("Negative weights are not allowed and program will stop. Prevalence tables will not be produced.")

mat.out<-mat

mat.out$sw.vec<-sw
mat.out$sex.vec<-as.double(sex.vec)
mat.out$oedema.vec<-as.character(oedema.vec)
mat.out$oedema.vec1<-as.character(oedema.vec)

mat.out<-mat.out[!is.na(mat.out$age.mo) & mat.out$age.mo>=61 & mat.out$age.mo<229,]

####################################################
#### Creating age group variable in completed years
####################################################

mat.out$agegr <- floor(mat.out$age.mo/12)

##############################################
#### Make z-score as missing if it is flagged
##############################################

mat.out$zhfa<-ifelse(!is.na(mat.out$fhfa) & mat.out$fhfa!=0,NA,mat.out$zhfa)
mat.out$zwfa<-ifelse(!is.na(mat.out$fwfa) & mat.out$fwfa!=0,NA,mat.out$zwfa)
mat.out$zbfa<-ifelse(!is.na(mat.out$fbfa) & mat.out$fbfa!=0,NA,mat.out$zbfa)

if(dim(mat.out)[1]==0) stop("\n\nNo non-missing z-score values are available for calculating prevalences. Program will stop!\n\n.")

##############################################
#### Include all levels of age group variable
##############################################

mat.aux<-as.data.frame(cbind(array(rep(NA,((dim(mat.out)[2]-1)*15)),dim=c(15,(dim(mat.out)[2]-1)) ),seq(5,19,1)))

names(mat.aux)<-names(mat.out)

mat.out<-rbind(mat.out,mat.aux)

cat(" starting ")

########################################################################################################
#### Make Oedema variable to be "n" if age smaller than 61 mo or greater than 120 mo (for weight-for-age)
#### or smaller than 61 mo or greater than 228 mo (for bmi-for-age).
#### This is because children with oedema counts in the prevalence even if z-score is missing
#### for weight related indicators.
########################################################################################################

mat.out$oedema.vec<-ifelse((!is.na(mat.out$age.mo) & (mat.out$age.mo<61 | mat.out$age.mo>=229))  | mat.out$oedema.vec=="NA","n",mat.out$oedema.vec)
mat.out$oedema.vec1<-ifelse((!is.na(mat.out$age.mo) & (mat.out$age.mo<61 | mat.out$age.mo>=121))  | mat.out$oedema.vec=="NA","n",mat.out$oedema.vec)

#####################################################################################################################################################
#### Creating matrix with estimated prevalences, confidence intervals, and means and standard deviations of z-scores and exporting it to Excel file.
#####################################################################################################################################################

cat("\nPlease wait while calculating prevalences and z-score summary statistics...\n")

#### Sexes combined

#### % < -3 SD for all the indicators
mat<- t(cbind.data.frame(#
       prevnh(-3,mat.out$zwfa,mat.out$sw.vec,mat.out$oedema.vec1),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevnh.L(-3,mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-3, z$zhfa, z$sw.vec)),#
       prevnh(-3,mat.out$zbfa,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-3, z$zbfa, z$sw.vec, z$oedema.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh(-2,mat.out$zwfa,mat.out$sw.vec,mat.out$oedema.vec1),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevnh.L(-2,mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevnh.L(-2, z$zhfa, z$sw.vec)),#
       prevnh(-2,mat.out$zbfa,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevnh(-2, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +1 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph(1,mat.out$zwfa,mat.out$sw.vec,mat.out$oedema.vec1),lapply(split(mat.out, mat.out$agegr),function(z) prevph(1, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevph.L(1,mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(1, z$zhfa, z$sw.vec)),#
       prevph(1,mat.out$zbfa,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(1, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph(2,mat.out$zwfa,mat.out$sw.vec,mat.out$oedema.vec1),lapply(split(mat.out, mat.out$agegr),function(z) prevph(2, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevph.L(2,mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(2, z$zhfa, z$sw.vec)),#
       prevph(2,mat.out$zbfa,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(2, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +3 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph(3,mat.out$zwfa,mat.out$sw.vec,mat.out$oedema.vec1),lapply(split(mat.out, mat.out$agegr),function(z) prevph(3, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevph.L(3,mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr), function(z) prevph.L(3, z$zhfa, z$sw.vec)),#
       prevph(3,mat.out$zbfa,mat.out$sw.vec,mat.out$oedema.vec),lapply(split(mat.out, mat.out$agegr),function(z) prevph(3, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out$zwfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zwfa,z$sw.vec)),#
       wmean(mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zhfa,z$sw.vec)),#
       wmean(mat.out$zbfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wmean(z$zbfa,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out$zwfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zwfa,z$sw.vec)),#
       wsd(mat.out$zhfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zhfa,z$sw.vec)),#
       wsd(mat.out$zbfa,mat.out$sw.vec),lapply(split(mat.out, mat.out$agegr),function(z) wsd(z$zbfa,z$sw.vec)))))

####################################################################################################################
##### Exporting matrix to Excel file

rm(mat1)

mat1<-rbind(c("Set 1:","Sexes","combined",rep("",15)),
                       c("Weight","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[1:16,],#
                       c("Height","-for-","age",rep("",15)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[17:32,],#
                       c("BMI","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[33:48,])

for(j in 1:dim(mat1)[2]) mat1[,j]<-ifelse(mat1[,j]=="NA" | mat1[,j]=="NaN","",mat1[,j])

mat1<-cbind(c("",rep(c("","Age","5-19",as.character(5:19)),3)),mat1)

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

##### For boys and girls

for(i in 1:2) {

mat.out.sex<-mat.out[!is.na(mat.out$sex.vec) & mat.out$sex.vec==i,]

mat.aux<-as.data.frame(cbind(array(rep(NA,((dim(mat.out.sex)[2]-1)*15)),dim=c(15,(dim(mat.out.sex)[2]-1)) ),seq(5,19,1)))
names(mat.aux)<-names(mat.out.sex)
mat.out.sex<-rbind.data.frame(mat.out.sex,mat.aux)
mat.out.sex$oedema.vec<-ifelse((!is.na(mat.out.sex$age.mo) & (mat.out.sex$age.mo<61 | mat.out.sex$age.mo>=229)) | mat.out.sex$oedema.vec=="NA","n",mat.out.sex$oedema.vec)

#### % < -3 SD for all the indicators
mat<- t(cbind.data.frame(#
       prevnh(-3,mat.out.sex$zwfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec1),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevnh.L(-3,mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-3, z$zhfa, z$sw.vec)),#
       prevnh(-3,mat.out.sex$zbfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-3, z$zbfa, z$sw.vec, z$oedema.vec))))

#### % < -2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevnh(-2,mat.out.sex$zwfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec1),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevnh.L(-2,mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevnh.L(-2, z$zhfa, z$sw.vec)),#
       prevnh(-2,mat.out.sex$zbfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevnh(-2, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +1 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph(1,mat.out.sex$zwfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec1),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(1, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevph.L(1,mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(1, z$zhfa, z$sw.vec)),#
       prevph(1,mat.out.sex$zbfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(1, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +2 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph(2,mat.out.sex$zwfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec1),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(2, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevph.L(2,mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(2, z$zhfa, z$sw.vec)),#
       prevph(2,mat.out.sex$zbfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(2, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### % > +3 SD for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       prevph(3,mat.out.sex$zwfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec1),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(3, z$zwfa, z$sw.vec, z$oedema.vec1)),#
       prevph.L(3,mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr), function(z) prevph.L(3, z$zhfa, z$sw.vec)),#
       prevph(3,mat.out.sex$zbfa,mat.out.sex$sw.vec,mat.out.sex$oedema.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) prevph(3, z$zbfa, z$sw.vec, z$oedema.vec))))[,-1])

#### Means of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wmean(mat.out.sex$zwfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zwfa,z$sw.vec)),#
       wmean(mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zhfa,z$sw.vec)),#
       wmean(mat.out.sex$zbfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wmean(z$zbfa,z$sw.vec)))))

#### Standard deviations of z-scores for all the indicators
mat<-cbind.data.frame(mat,t(cbind.data.frame(#
       wsd(mat.out.sex$zwfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zwfa,z$sw.vec)),#
       wsd(mat.out.sex$zhfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zhfa,z$sw.vec)),#
       wsd(mat.out.sex$zbfa,mat.out.sex$sw.vec),lapply(split(mat.out.sex, mat.out.sex$agegr),function(z) wsd(z$zbfa,z$sw.vec)))))

####################################################################################################################
##### Exporting matrix to Excel file

mat2<-rbind.data.frame(c(paste("Set ",i+1,":",sep=""),c("Males","Females")[i],rep("",16)),
                       c("Weight","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[1:16,],#
                       c("Height","-for-","age",rep("",15)),#
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[17:32,],#
                       c("BMI","-for-","age",rep("",15)),
                       c("N","% < -3 SD","95%", "C.I.","% < -2 SD","95%", "C.I.","% > +1 SD","95%", "C.I.","% > +2 SD","95%", "C.I.","% > +3 SD","95%", "C.I.","Mean","SD"),mat[33:48,])

for(j in 1:dim(mat2)[2]) mat2[,j]<-ifelse(mat2[,j]=="NA" | mat2[,j]=="NaN","",mat2[,j])

mat2<-cbind(c("",rep(c("","Age","5-19",as.character(5:19)),3)),mat2)

names(mat2)<-names(mat1)

mat1<-rbind(mat1,mat2)

}    #### End of loop for sex

mat1<-mat1[-c(11:19,66:74,121:129),]

###################################################################################################################
######### Export table with prevalence values and their confidence intervals, and mean and SD of the z-scores
###################################################################################################################

assign("matprev",mat1,envir = .GlobalEnv)

write.table(matprev, file=paste(FilePath,"\\",FileLab,"_prev.csv",sep=""),na=" ",row.names = FALSE,col.names=F,sep=",",quote = TRUE)

cat(paste("Prevalences and z-score summary statistics calculated and exported to ",FilePath,"\\",FileLab,"_prev.csv\n",sep=""))

on.exit(options(old))

invisible()

}   #### End of main function who2007

# wfawho2007<-read.table("D:\\References 5-20y\\Macro R\\who2007_R\\wfawho2007.txt",header=T,sep="",skip=0)
# hfawho2007<-read.table("D:\\References 5-20y\\Macro R\\who2007_R\\hfawho2007.txt",header=T,sep="",skip=0)
# bfawho2007<-read.table("D:\\References 5-20y\\Macro R\\who2007_R\\bfawho2007.txt",header=T,sep="",skip=0)

# survey.who2007<-read.csv("D:\\References 5-20y\\Macro R\\who2007_R\\survey_who2007.csv",header=T,sep=",",skip=0,na.strings="")

# source("D:\\References 5-20y\\Macro R\\who2007_R\\who2007.r")

# who2007(FileLab = "survey_who2007", FilePath = "D:\\References 5-20y\\Macro R\\who2007_R", mydf = survey.who2007,sex = sex, age = agemons, weight = weight, height = height, sw=sw, oedema=oedema)


library(ggplot2)
library(plyr)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

cox_model <-
"data {
    int<lower=0> Nsubj;
    int<lower=1> T;
    vector[Nsubj] pscenter;
    vector[Nsubj] hhcenter;
    int<lower=0,upper=1> ncomact[Nsubj];
    int<lower=0,upper=1> rleader[Nsubj];
    int<lower=0,upper=1> dleader[Nsubj];
    vector[Nsubj] inter1;
    vector[Nsubj] inter2;
    int<lower=0,upper=1> FAIL[Nsubj];
    int<lower=0> obs_t[Nsubj];
    int<lower=0> t[T+1];

}

transformed data {
    int<lower=0> Y[Nsubj, T];
    int<lower=0> dN[Nsubj, T];

    # Set up data
    for(i in 1:Nsubj) {
        for(j in 1:T) {
            # risk set = 1 if obs_t >= t
            Y[i,j] <- int_step(obs_t[i] - t[j]);
            # counting process
            dN[i,j] <- Y[i, j] * int_step(t[j + 1] - obs_t[i]) * FAIL[i];
        }
    }
}

parameters {
    vector[7] beta;
    real<lower=0> c;
    real<lower=0> r;
    vector[T] dL0;
}

transformed parameters {
    vector[T] mu;
    matrix[Nsubj, T] Idt;
    vector[T] dL0_star;

    for(j in 1:T) {
        for(i in 1:Nsubj) {
            # Intensity
            Idt[i, j] <- Y[i, j] * exp(beta[1]*pscenter[i] + beta[2]*hhcenter[i] + beta[3]*ncomact[i]
                        + beta[4]*rleader[i] + beta[5]*dleader[i] + beta[6]*inter1[i] + beta[7]*inter2[i]) * dL0[j];
        }
        # prior mean hazard
        mu[j] <- dL0_star[j] * c;

        dL0_star[j] <- r * (t[j + 1] - t[j]);
    }
}

model {

    for(j in 1:T) {
        for(i in 1:Nsubj) {
            # Likelihood
            dN[i, j] ~ poisson(Idt[i, j]);
        }
        dL0[j] ~ gamma(mu[j], c);
    }

    c ~ gamma(0.0001, 0.00001);
    r ~ gamma(0.001, 0.0001);

    beta ~ normal(0.0, 100000);
}"

data <- read_rdump('survival.data.r')

inits <- list(c1=list(beta=c(-.36,-.26,-.29,-.22,-.61,-9.73,-.23),  c=0.01, r=0.01,
    dL0=c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)))

fit <- stan(model_code=cox_model, data=data, init=inits, iter=2000, chains=1, verbose=F)

print(fit)


#Bodyfatpercentage function:
bodyfatpercentage<-function(Weight, Neck, Chest, Abdomen, Hip, Thigh, Biceps, Forearm, Wrist){return (-20.70744484 + (Weight * -0.12231521) + (Neck * -0.55247243) + (Chest * 0.04107781) + (Abdomen * 1.04805259) + (Hip * -0.23442407) + (Thigh * 0.19800909) + (Biceps * 0.21621033) + (Forearm * 0.39878499) + (Wrist * -1.37931563))}


#' initiales a data.frame with the data for the loto analysis
#'
#' @return a data.frame with rows containing the numbers and winnings for
#' various draws
read.data <- function(numberSource = "numbers.csv", payoutSource = "winnings.csv") {
    numbers <- read.csv(numberSource)
    numbers$Date <- as.POSIXct(numbers$Date, format = "%Y-%m-%d")

    winnings <- read.csv(payoutSource)
    winnings$Date <- as.POSIXct(winnings$Date, format = "%Y-%m-%d")

    return(merge(numbers, winnings, by = "Date"))
}

#' calculates and returns the probabilities for every win category in lotto
#'
#' @return a data.frame containing the probabilities to win various combinations
#' in lotto
get.Prob <- function() {
    ret <- data.frame(
        Win6s = choose(43, 0) * choose(6, 6) / choose(49, 6) * 1 / 10,
        Win6 = choose(43, 0) * choose(6, 6) / choose(49, 6) * 9 / 10,
        Win5s = choose(43, 1) * choose(6, 5) / choose(49, 6) * 1 / 10,
        Win5 = choose(43, 1) * choose(6, 5) / choose(49, 6) * 9 / 10,
        Win4s = choose(43, 2) * choose(6, 4) / choose(49, 6) * 1 / 10,
        Win4 = choose(43, 2) * choose(6, 4) / choose(49, 6) * 9 / 10,
        Win3s = choose(43, 3) * choose(6, 3) / choose(49, 6) * 1 / 10,
        Win3 = choose(43, 3) * choose(6, 3) / choose(49, 6) * 9 / 10,
        Win2s = choose(43, 4) * choose(6, 2) / choose(49, 6) * 1 / 10
    )
    return(ret)
}

#' calculates the expected prices for each win class
#'
#' @return a data.frame with the first row containing the probabilites of
#' winning and the second row containing the expected winnings
get.ExpWin <- function(date) {
    prob <- get.Prob()

    if (date > as.POSIXct("2020-09-20")) {
        # payout rate is the probability of winning in the lowest win class
        # times the payout ratio (6 € for 0.6 € contributed to the pool)
        lowest <- prob[1, 9] * 10

        # payout rate is fixed for the highest win class
        highest <- 0.15

        # for other win classes it is relative to highest and lowest
        remaining <- (1 - highest - lowest)
        payout_rate <- c(
            highest,
            remaining * 0.15,
            remaining * 0.052,
            remaining * 0.155,
            remaining * 0.043,
            remaining * 0.102,
            remaining * 0.087,
            remaining * 0.411,
            lowest
        )

        # for every 1.2 € played 60 cents are payed out
        expect <- 0.6 * payout_rate / prob

        # the draw2s class has a fixed payout rate
        expect[1, 9] <- 6
        return(rbind(prob, expect))
    }

    if (date > as.POSIXct("2013-05-03")) {
        # payout rate is the probability of winning in the lowest win class
        # times the payout ratio (5 € for 0.5 € contributed to the pool)
        lowest <- prob[1, 9] * 10

        # payout rate is fixed for the highest win class
        highest <- 0.128

        # for other win classes it is relative to highest and lowest
        remaining <- (1 - highest - lowest)
        payout_rate <- c(
            highest,
            remaining * 0.10,
            remaining * 0.05,
            remaining * 0.15,
            remaining * 0.05,
            remaining * 0.10,
            remaining * 0.10,
            remaining * 0.45,
            lowest
        )

        # for every 1 € played 50 cents are payed out
        expect <- 0.5 * payout_rate / prob

        # the draw2s class has a fixed payout rate
        expect[1, 9] <- 5
        return(rbind(prob, expect))
    }

    stop("Date not supported")
}

#' calculates the ratios between the expected winnings and the actual payed
#' out amounts
#'
#' @return ratios of realized and expected winnings
get.WinRatios <- function(data) {
    m <- apply(data, 1, function(row) {
        exp.win <- get.ExpWin(row["Date"])[2, ]
        ratio.win2S <- as.numeric(row["Win2S"]) / exp.win$Win2s

        ratio.win3 <- exp.win$Win3 / as.numeric(row["Win3"])
        ratio.win3S <- exp.win$Win3s / as.numeric(row["Win3S"])
        ratio.win3zz <- ratio.win3S / ratio.win3

        ratio.win4 <- exp.win$Win4 / as.numeric(row["Win4"])
        ratio.win4S <- exp.win$Win4s / as.numeric(row["Win4S"])
        ratio.win4zz <- ratio.win4S / ratio.win4

        return(data.frame(
            Date = row["Date"],
            data.ZZ = row["ZZ"],
            ratio.win2S,
            ratio.win3,
            ratio.win3S,
            ratio.win3zz,
            ratio.win4,
            ratio.win4S,
            ratio.win4zz
        ))
    })
    m <- Reduce(function(...) merge(..., all = T), m)
    return(m)
}

#' given a vector representing a row of the data.frame returned by
#' @link read.data return a vector of exponents for the model.
#' correctDrawn modifies the exponents for the data set (e.g. 3 if
#' used for win3, 4 for win4, etc.)
#'
#' @return exponents for every lotto number used in the model for the
#' general analysis
getExponents <- function(row, correctDrawn) {
    exponent <- rep((6 - correctDrawn) / 43, 49)
    exponent[as.integer(row[2])] <- correctDrawn / 6
    exponent[as.integer(row[3])] <- correctDrawn / 6
    exponent[as.integer(row[4])] <- correctDrawn / 6
    exponent[as.integer(row[5])] <- correctDrawn / 6
    exponent[as.integer(row[6])] <- correctDrawn / 6
    exponent[as.integer(row[7])] <- correctDrawn / 6
    return(exponent)
}


require(faraway)

G <- function(x){
	val <- logit(x)
	return(val)
}

G_Inv <- function(x){
	val <- ilogit(x)
	return(val)
}

Agg <- function(p_i, N_i){
	return(sum(p_i * N_i)/sum(N_i))
}

EvalK <- function(K, p_i, p_N, N_i){
	if (Mult == TRUE){
		p_tilde <- G_Inv(G(p_i) * K)
	} else {
		p_tilde <- G_Inv(G(p_i) + K)
	}
	LHS <- Agg(p_tilde, N_i)
	RHS <- p_N
	SE <- (LHS-RHS)^2
	return(SE)
}

# p_i = our grid of probabilities
# p_N = national target
# sim_N_i = our grid of sample sizes (population raster)
# a = bounds for raking factor, perhaps return warning if optimal is on edge of limits
FindK <- function(p_i, p_N, N_i, a) {
	if (Mult == TRUE){
		Limits <- c(0,a)
	} else {
		Limits <- c(-a,a)
	}
	iter <- 1
	Boundary = TRUE
	while (Boundary & iter < 10){
		Limits <- Limits * iter
		val <- optimize(EvalK, Limits, p_i = p_i, p_N = p_N, N_i = N_i, tol = 1e-20)$min
		Boundary <- (round(abs(val)) == Limits[2])
		iter <- iter + 1
	}
	return(val)
}

NumLocs <- 100
sim_p_i <- runif(NumLocs)
sim_N_i <- round(runif(NumLocs)+runif(NumLocs)*100*runif(NumLocs))

Mult <- FALSE
a <- 2

Try <- 99

p_Ns <- seq(0, 1, length = Try + 2)[-c(1,Try+2)]
Scale <- seq(-10, 10, length = Try + 2)[-c(1,Try+2)]
AggP <- rep(NA, length=Try)

RF <- matrix(0, Try, Try)

for (i in 1:Try){
	tmp_p_i <- ilogit(logit(sim_p_i) + Scale[i])
	AggP[i] <- Agg(tmp_p_i, sim_N_i)
	for (j in 1:Try){
		tmp_p <- p_Ns[j]
		RF[i,j] <- FindK(tmp_p_i, tmp_p, sim_N_i, a)
	}
}

persp(AggP,p_Ns,RF,phi=35,theta=45)