require(rms)
require(plotly)
n <- 1000    # define sample size
set.seed(17) # so can reproduce the results
age            <- rnorm(n, 50, 10)
blood.pressure <- rnorm(n, 120, 15)
sex            <- factor(sample(c('female','male'), n, TRUE))
country        <- factor(sample(c('US', 'Canada'),  n, TRUE))
i <- sex == 'female'
cholesterol <- numeric(n)
cholesterol[i]   <- rnorm(sum(i),   170, 15)
cholesterol[! i] <- rnorm(sum(! i), 200, 25)
label(age)            <- 'Age'      # label is in Hmisc
label(cholesterol)    <- 'Total Cholesterol'
label(blood.pressure) <- 'Systolic Blood Pressure'
label(sex)            <- 'Sex'
units(cholesterol)    <- 'mg/dl'   # uses units.default in Hmisc
units(blood.pressure) <- 'mmHg'
# Specify population model for log odds that Y=1
L <- .4*(sex=='male') + .045*(age-50) +
     (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male'))
# Simulate binary y to have Prob(y=1) = 1/[1+exp(-L)]
y <- ifelse(runif(n) < plogis(L), 1, 0)
cholesterol[1:3] <- NA   # 3 missings, at random
d <- data.frame(y, blood.pressure, age, cholesterol, sex, country)
rm(y, blood.pressure, age, cholesterol, sex, country)
dd <- datadist(d); options(datadist='dd')

f <- lrm(y ~ blood.pressure + sex * (age + rcs(cholesterol,4)) + country,
         data=d)

p <- Predict(f, cholesterol, sex)
source('~/R/Hmisc/R/histSpikeg.s')
source('~/R/rms/R/plotp.Predict.s')
source('~/R/Hmisc/R/scat1d.s')
# plotp(p, rdata=d, ylim=c(-1,2))

i <- attr(p, 'info')
cllab <- if(i$conf.int) paste0(i$conf.int, ' C.L.')

class(p) <- setdiff(class(p), 'Predict')

fm <- function(x) format(x, digits=4)

# pm <- subset(p, sex == 'male')
a <- i$Design
bpl <- labelPlotmath(a$label['blood.pressure'],
                     a$units['blood.pressure'], html=TRUE)
chl <- labelPlotmath(a$label['cholesterol'],
                     a$units['cholesterol'], html=TRUE)
agl <- labelPlotmath(a$label['age'],
                     a$units['age'], html=TRUE)

a <- plot_ly()
ht <- with(p, paste0('cholesterol=', fm(cholesterol), '
',
                       fm(yhat), ' [', fm(lower), ',', fm(upper), ']'))
j <- which(p$cholesterol == min(p$cholesterol))
ht[j] <- paste0(ht[j], '
Adjusted to:
', i$adjust[1])

a <- add_lines(a, data=p, x=~cholesterol, y=~yhat, color=~sex,
               text=~ht, hoverinfo='text')
a <- add_ribbons(a, data=p, x=~cholesterol, ymin=~lower, ymax=~upper,
                 color=~sex, hoverinfo='none')
source('~/R/Hmisc/R/histSpikeg.s')
a <- histSpikeg(yhat ~ cholesterol + sex, predictions=p,
                data=d, plotly=a, ylim=c(-1, 2))
layout(a, xaxis=list(title=chl),
          yaxis=list(title=i$ylabhtml, range=c(-1, 2)))

p <- Predict(f)
# w <- plotp(p, rdata=d)
# w$Continuous
# w$Categorical

i <- attr(p, 'info')
ylim <- range(c(p$lower, p$upper, p$yhat), na.rm=TRUE)
p <- subset(p, .predictor. %nin% c('sex', 'country'))
class(p) <- 'data.frame'
r <- subset(p, .predictor. == 'age')
r$ht <- with(r, paste0('age=', fm(age), '
',
                       fm(yhat), ' [', fm(lower), ',', fm(upper), ']'))
r$ht[1] <- paste0(r$ht[1], '
Adjusted to:
', i$adjust[3])
a <- plot_ly(r)
a <- add_lines(a, x=~age, y=~yhat, text=~ht, color=I('black'), hoverinfo='text',
               name='yhat', legendgroup='yhat')
a <- add_ribbons(a, x=~age, ymin=~lower, ymax=~upper, color=I('lightgray'),
                 hoverinfo='none', name=cllab, legendgroup=cllab)
source('~/R/Hmisc/R/histSpikeg.s')
a <- histSpikeg(yhat ~ age, data=d, predictions=r, ylim=ylim, plotly=a)
#aa <- histSpikep(a, x=d$age, y=approx(r$age, r$yhat, xout=d$age)$y, z=1)
ex <- function(x, delta=0) {
    r <- range(x, na.rm=TRUE)
    if(delta == 0) return(r)
    c(r[1] - delta * diff(r), r[2] + delta * diff(r))
}
a <- plotly::layout(a, xaxis=list(title=agl, range=ex(d$age)))

r <- subset(p, .predictor. == 'cholesterol')
r$ht <- with(r, paste0('cholesterol=', fm(cholesterol), '
',
                       fm(yhat), ' [', fm(lower), ',', fm(upper), ']'))
r$ht[1] <- paste0(r$ht[1], '
Adjusted to:
', i$adjust[4])
b <- plot_ly(r)
b <- add_lines(b, x=~cholesterol, y=~yhat, text=~ht, color=I('black'), hoverinfo='text',
               name='yhat', showlegend=FALSE, legendgroup='yhat')
b <- add_ribbons(b, x=~cholesterol, ymin=~lower, ymax=~upper, color=I('lightgray'),
                 hoverinfo='none', name=cllab, showlegend=FALSE, legendgroup=cllab)
b <- histSpikeg(yhat ~ cholesterol, data=d, predictions=r, ylim=ylim,
                plotly=b, showlegend=FALSE)
b <- layout(b, xaxis=list(title='cholesterol', range=ex(d$cholesterol)))
plotly::subplot(a, b, nrows=1, shareY=TRUE, titleX=TRUE)

p <- Predict(f)
r <- subset(p, .predictor. == 'sex')
a <- plot_ly(r, color=I('black'), height=plotlyParm$heightDotchart(2))
a <- add_segments(a, y=~sex, x=~lower, yend=~sex, xend=~upper, color=I('lightgray'), name=cllab, legendgroup=cllab)
a <- add_markers(a, y=~sex, x=~yhat, name='Estimate', legendgroup='Estimate')
#lm <- plotlyParm$lrmargin('female')
a <- layout(a, xaxis=list(title=i$ylabhtml),
               yaxis=list(title='Sex', titlefont=list(size=10)))

r <- subset(p, .predictor. == 'country')
b <- plot_ly(r, color=I('black'), height=plotlyParm$heightDotchart(2))
b <- add_segments(b, y=~country, x=~lower, yend=~country, xend=~upper, color=I('lightgray'), name=cllab, legendgroup=cllab, showlegend=FALSE)
b <- add_markers(b, y=~country, x=~yhat, name='Estimate', legendgroup='Estimate', showlegend=FALSE)
#lm <- plotlyParm$lrmargin('Canada')
b <- layout(b, xaxis=list(title=i$ylabhtml),
               yaxis=list(title='Country', titlefont=list(size=10)))

plotly::subplot(a, b, shareX=TRUE, titleY=TRUE, nrows=2, heights=c(2, 2) / sum(c(2, 2)))

p <- Predict(f, sex)
class(p) <- setdiff(class(p), 'Predict')

p <- Predict(f, age, sex, blood.pressure=c(120,140,160),
             cholesterol=c(180,200,215))


a <- 0;
while(a != Inf)
{
	a = a+1;
	if(a%%15 == 0)     {print("FIZZ BUZZ");}
	else if(a%%5 == 0) {print("BUZZ");}
	else if(a%%3 == 0) {print("FIZZ");}
	else               {print(a);}
}


cat(sapply(as.integer(readLines(tail(commandArgs(), n=1))), function(s) {
  if (s < 10) { return("True") }
  e <- as.integer(log10(s)) + 1
  r <- s
  while (s > 0) {
    r <- r - (s %% 10)^e
    s <- as.integer(s / 10)
  }
  if (r == 0) { return("True") }
  "False"
}), sep="\n")


# Source: https://www.business-science.io/code-tools/2018/04/08/introducing-anomalize.html
# Author: Matt Dancho - https://resources.rstudio.com/authors/matt-dancho

library(tidyverse)
library(anomalize)

tidyverse_cran_downloads

# Detect anomalies
tidyverse_cran_downloads %>%
  time_decompose(count) %>%
  anomalize(remainder) %>%
  time_recompose() %>%
  plot_anomalies(time_recomposed = TRUE, ncol = 3, alpha_dots = 0.5)

# Decomposition
tidyverse_cran_downloads %>%
  time_decompose(count, method = "stl", frequency = "auto", trend = "auto")

# Detect anomalies
tidyverse_cran_downloads %>%
  time_decompose(count, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "iqr", alpha = 0.05, max_anoms = 0.2)

# Visualize lubridate
tidyverse_cran_downloads %>%

# Select a single time series
filter(package == "lubridate") %>%
  ungroup() %>%

# Anomalize
time_decompose(count, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "iqr", alpha = 0.05, max_anoms = 0.2) %>%

# Plot Anomaly Decomposition
plot_anomaly_decomposition() +
ggtitle("Lubridate Downloads: Anomaly Decomposition")

# Recompose time series
tidyverse_cran_downloads %>%
  time_decompose(count, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "iqr", alpha = 0.05, max_anoms = 0.2) %>%
  time_recompose()

# Visualize Lubridate
tidyverse_cran_downloads %>%
  # Select single time series
  filter(package == "lubridate") %>%
  ungroup() %>%
  # Anomalize
  time_decompose(count, method = "stl", frequency = "auto", trend = "auto") %>%
  anomalize(remainder, method = "iqr", alpha = 0.05, max_anoms = 0.2) %>%
  time_recompose() %>%
  # Plot Anomaly Decomposition
  plot_anomalies(time_recomposed = TRUE) +
  ggtitle("Lubridate Downloads: Anomalies Detected")


#### Rscript SecondAssignment_R.r regrex1.csv

## read argument
args <- commandArgs(T)

## load data
df <- read.csv(args[1], head = TRUE)

## plot scatter
png("r_orig.png")
plot(y ~ x, data = df)
Null <- dev.off()

## model the data
linear_regressor <- lm(y ~ x, data = df)

## plot scatter with predicting value
png("r_lm.png")
plot(y ~ x, data = df)
abline(linear_regressor, col = "red")
Null <- dev.off()


library(plyr)
library(reshape)
library(ggplot2)

bnames <- read.csv("../data/bnames.csv", stringsAsFactors = FALSE)

# Focus on the last 60 years
recent <- subset(bnames, year >= 1950)

# Still a lot of names, so pull out those names which are both moderately
# popular (> 1 / 1000) and in top 1000 for at least 30 years.  In a real
# analysis you'd probably want to analyse more data.
per_name <- ddply(recent, c("sex", "name"), summarise,
  years = length(name), percent_avg = mean(percent))
long <- subset(per_name, years >= 30 & percent_avg > 0.001)
bnames_long <- merge(recent, long[c("sex", "name")], by = c("sex", "name"))

# To cluster, we need to reshape the data so that each year forms a column.
# We'll have to do this a few times, so we'll create a function to do this
# specifically for this data.  To learn more about how this works, see the
# documentation for the reshape package.
widen <- function(variable) {
  as.matrix(cast(bnames_long, sex + name ~ year, fill = 0,
    value = variable))
}

long$cluster1 <- kmeans(widen("percent"), 20)$cluster
bnames_cl <- merge(bnames_long, long, by = c("sex", "name"))
ggplot(bnames_cl, aes(year, percent)) +
  geom_line(aes(group = interaction(sex, name))) +
  facet_wrap(~ cluster1)

#head(dlply(long, "cluster1", function(df) as.character(df$name)))

# Hmmmm.  Maybe be clustering too much based on absolute size, and not
# on relative shape.  Lets rescale percent to 0,1

library(mgcv)
smooth <- function(var, date) {
  predict(gam(var ~ s(date)))
}
scale01 <- function(x) (x - min(x)) / diff(range(x))

bnames_long <- ddply(bnames_long, c("sex", "name"), transform,
  percent_std = scale01(percent),
  percent_smo = scale01(smooth(percent, year))
)

long$cluster2 <- kmeans(widen("percent_std"), 20)$cluster
long$cluster3 <- kmeans(widen("percent_smo"), 20)$cluster

bnames_cl <- merge(bnames_long, long, by = c("sex", "name"))
qplot(year, percent_std, data = bnames_cl, group = interaction(name, sex), geom = "line") +
  facet_wrap(~ cluster2)

qplot(year, percent_smo, data = bnames_cl, group = interaction(name, sex), geom = "line", colour = sex) +
  facet_wrap(~ cluster2)

#dlply(long, "cluster2", function(df) as.character(df$name))

tab <- table(long[c("cluster2", "cluster3")])
library(e1071)
match <- matchClasses(tab)

print.table(tab[, match], zero.print = ".")


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


setwd("/home/pan/Documents/glfw-test")
#d <- read.csv("fft_python.csv")
d <- read.csv("fft_out.csv")
rate <- 48000
M <- 73728
step <- rate/M
d[,1] <- d[,1]/M*rate

num_groups <- 40

# Groupings
groups <- rep(0,num_groups)
step_size <- 1/num_groups
y0 <- 15
x0 <- 0
y1 <- M/2
x1 <- 1
b <- log(y0/y1)/(x0-x1)
a <- y0*exp(-b*x0)
c <- 1
for(j in seq(x0,x1,length.out = num_groups)){
  groups[c] <- a*exp(j*b)
  c <- c + 1
}

# groups <- rep(0,num_groups)
# y0 <- 15
# x0 <- 0
# y1 <- M/2
# x1 <- 1
# b <- log(y1/y0)/log(x1/x0)
# a <- y0*x0^(-b)
# c <- 1
# for(j in seq(x0,x1,length.out = num_groups)){
#   groups[c] <- a*(j^b)
#   c <- c + 1
# }

groups
#plot(d[,1],ifelse(d[,2]>quantile(d[,2],0.999),d[,2],0),type='l')
plot(d[,1],d[,2],type='l')
#plot(d[,2],type='l')
# for(i in groups){
#   lines(rep(i/M*rate,2),seq(0,2^32,length.out = 2),col="red")
# }

grouped <- rep(0,num_groups)

group_pos = 1
qqq <- as.vector(quantile(d[,2],0.995))#max(d[,2])*0.75#0#as.vector(quantile(d[,2],0.9995))
for(i in 1:(M/2)){
  if(groups[group_pos]<=(i+1)*step){
    group_pos <- group_pos + 1
  }
  if(group_pos>=num_groups){
    group_pos = num_groups
  }
  #if(d[i,2] > qqq){
    grouped[group_pos] <- grouped[group_pos] + d[i,2]
  #}
  i
}

barplot(grouped/(2^31))
groups


source("power_priors_aux.r")

scenario <- 3

source(paste("analyses_Bernoulli/data_Bernoulli_scenario_", scenario, ".r", sep = ""))

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#### Sampling from the "prior"
compiled.model.prior <- stan_model("stan/simple_Bernoulli_posterior_unnormalised_fixed_a0.stan")

bb.data <- list(
  N0 = N_0,
  y0 = y_0,
  c = cc,
  d = dd,
  a_0 = NA,
  N = N,
  y = y
)

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

epsilon <- 0.05
J <- 20
maxA <- 1

source("grid_builder.r")

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid_derivOnly(eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10, stan.list = bb.data, pars = "theta")
)
write.csv(adaptive.ca0.estimates$result,
          file = paste("../data/constant_data/Bernoulli_posterior_logCA0_scenario_", scenario,
                       "_J=", J, ".csv", sep = ""), row.names = FALSE)

summaries.adaptive <- adaptive.ca0.estimates$summaries
for (j in 1:length(summaries.adaptive)){
  summaries.adaptive[[j]] <- data.frame(summaries.adaptive[[j]], a_0 = adaptive.ca0.estimates$result$a0[j])
}
summaries.adaptive.dt <- do.call(rbind, summaries.adaptive)

write.csv(summaries.adaptive.dt,
          file = paste("../data/sensitivity_data/posteriorSensitivity_simpleBernoulli_adaptive_scenario_", scenario,
          "_J=", J, ".csv", sep = ""))


#' Find the distance between locations specified by latitude/longitude in degrees.
#'
#' @param locs a matrix of locations, each row specifying two locations to find the distance between. The first two columns are the "from" longitude and latitude, respectively; the third and fourth columns are the "from" longitude and latitude, respectively.
#' @param dist logical: return the distances as a \code{\link{dist}} object (distance matrix)?
#'
#' @return either a matrix or a distance matrix containing the distances between all the points.
earth.dist = function (locs, dist=TRUE)
{
    if (class(locs) == "SpatialPoints")
        locs <- coordinates(locs)

    name <- list(rownames(locs), rownames(locs))
    n <- nrow(locs)
    z <- matrix(0, n, n, dimnames = name)
    z <- outer(1:n, 1:n, function(i, j) deg.dist(long1=locs[i,1], lat1=locs[i, 2], long2=locs[j, 1], lat2=locs[j,2]))

    if (dist == TRUE)
        z <- as.dist(z)

    return(z)
}


library(ggplot2)
library(dplyr)
library(GGally)

df = read.csv("csv/corei7_long.csv")

log_df = df %>%
    select(-Repetition, -Filename) %>%
    mutate(log_Expected_insns = log(Expected_insns),
           log_Functions = log(Functions),
           log_CompileTime = log(CompileTime)) %>%
    select(log_Expected_insns,
           log_Functions,
           log_CompileTime,
           Num_partitions,
           Inlined_percentage,
           Parallel)

ggpairs(log_df)


require(mvtnorm)

source('fmm_multivariate_generative.r')

cluster_statistics = function(cluster, l, b, w) {
  mclust   =
    # R, seriously?
    if (is.null(dim(cluster))) {
      matrix(cluster, ncol = ncol(w))
    } else {
      as.matrix(cluster)
    }
  m        = ncol(mclust)
  n        = nrow(mclust)
  ybar     = colMeans(mclust)
  centered = mclust - ybar
  ss       = t(centered) %*% centered
  ln       = (l + n * ybar) / (1 + n)
  tn       =
    if (n == 0) {
      w
    } else {
      solve(solve(w) + ss + n / (1 + n) * ((l - ybar) %*% t(l - ybar)))
    }
  bn       = b + n
  df       = bn - m + 1
  mu       = ln
  coef     = n / ((n + 1) * df)
  v        = coef * solve(tn)
  list(
      n = n, ln = ln, tn = tn, bn = bn
    , df = df, mu = mu, v = v
    )
}

conditional_label_model = function(y, k, z, a, l, b, w) {
  cluster_labels = seq(k)
  rows           = seq(nrow(y))
  m              = ncol(y)

  initial_clusters = sapply(
      cluster_labels
    , function(j) { y[which(z == j),] }
    , simplify = F)

  sufficient_statistics = lapply(
      initial_clusters
    , function(c) { cluster_statistics(c, l, b, w) })

  relabel = function(i) {
    old_label  = z[i]
    val        = y[i,]
    y_censored = as.matrix(y[-i,])
    z_censored = z[-i]
    n_censored = sapply(
        cluster_labels
      , function(j) { length(which(z_censored == j)) })

    score_by_cluster = function(j) {
      sufficient_stats = if (j == old_label) {
          cluster = y_censored[which(z_censored == j), ]
          sufficient_statistics[[j]] <<- cluster_statistics(cluster, l, b, w)
          sufficient_statistics[[j]]
        } else {
          sufficient_statistics[[j]]
        }
      dmvt(
          val
        , df    = sufficient_stats$df
        , sigma = sufficient_stats$v
        , delta = sufficient_stats$mu
        , log   = T
        )
    }

    scores    = exp(sapply(cluster_labels, score_by_cluster))
    weight    = n_censored + a / k
    probs     = scores * weight / sum(scores * weight)
    new_label = sample(cluster_labels, size = 1, prob = probs)

    z[i] <<- new_label
    new_stats = cluster_statistics(y[which(z == new_label),], l, b, w)
    sufficient_statistics[[new_label]] <<- new_stats

    new_label
  }
  sapply(rows, relabel)
}

inverse_model = function(n, k, y, a, l, b, w) {
  gibbs = function(z0) {
    z = conditional_label_model(y, k, z0, a, l, b, w)
    clustered = lapply(seq(k),
      function(j) {
        vals = y[which(z == j),]
        as.matrix(vals)
      })

    ps    = lapply(clustered, function(j) { nrow(j) / nrow(y) })
    mus   = lapply(clustered, colMeans)
    precs = lapply(clustered, function(j) (solve(cov(j))))
    ll    = lmodel(y, ps, mus, precs)
    list(z = z, ll = ll)
  }

  params = list(z = sample(seq(k), size = nrow(y), replace = T))
  acc    = params
  for (j in seq(n - 1)) {
    params = gibbs(params$z)
    acc$z  = rbind(acc$z, params$z)
    acc$ll = c(acc$ll, params$ll)
  }
  acc
}


#' fac.design
#'
#' randomized block design of Factorial design
#'
#' @param levels,nVars,r,center,factors,varNames,seed,std
#'
#' @return std.order, run.order, level of factor
#'
#' @examples
#' levels<-c(2,2,3)
#' r=2
#' std=TRUE
#'
#' @export
#'
#'

fac.design<-function (levels, nVars = 0, r=1,center = TRUE, factors = "none", varNames = NULL, seed=0, std=FALSE){

  if (seed == 0) {
    genera<-runif(1)
    seed <-.Random.seed[3]
  }
  set.seed(seed)

  if (length(levels) == 1) {
    std.order<-1:(as.numeric(levels)^as.numeric(nVars)*r)
    run.order<-sample(1:(as.numeric(levels)^as.numeric(nVars)*r))

    levels <- rep(levels, nVars)

    if (missing(nVars))
      stop("nVars is needed when levels is a scalar")
  }
  else {
    std.order<-1:(prod(levels)*r)
    run.order<-sample(1:(prod(levels)*r))

    nVars <- length(levels)
  }

  if (any(levels < 1)) stop("All levels must be greater than 1")

  N <- prod(levels)
  factorVec <- rep(0, nVars)

  if (missing(factors)) {
    factors <- NULL
  }
  else if (is.character(factors)) {
    if (factors == "all") {
      factors <- 1:nVars
      factorVec <- rep(1, nVars)
    }
    else stop("factors error")
  }
  else {
    nFactors <- length(factors)
    for (i in factors) factorVec[i] <- 1
  }

  design <- matrix(0, N, nVars)

  .Call("GetFactorial", design, as.integer(levels), as.integer(center),
        as.integer(factorVec), PACKAGE = "AlgDesign")

  design <- data.frame(design)

  if (!missing(factors)) {
    for (i in factors) {
      design[, i] <- factor(design[, i])
    }
  }

  #design<-design[,c(nVars:1)]

  if (!missing(varNames) && length(varNames == nVars))
    colnames(design) <- varNames
  else colnames(design) <- paste("X", 1:nVars, sep = "")

  result<-data.frame(std.order,run.order,design)

  if(std) print(result)
  else print(result[order(result$run.order),])

}


#Code to compare the PRADA RPKM results from Wang et al Cancer Cell 2015 to the kallisto results now
#Performs correlation analyses of RPKM (PRADA) and TPM (kallisto) for each aliquot present in both datasets
#-----------------------------------------------------

library(DBI)
library(odbc)
library(ggplot2)
library(reshape)

rm(list=ls())

con <- DBI::dbConnect(odbc::odbc(), "GLASSv3")

q <- "SELECT r1.sample_barcode AS rna_barcode, tpm.aliquot_barcode AS tpm_barcode, r1.gene_symbol, rpkm, tpm
FROM analysis.rnaseq r1
JOIN analysis.gene_tpm tpm ON substr(tpm.aliquot_barcode,1,15) = r1.sample_barcode AND tpm.gene_symbol = r1.gene_symbol"

expr <- dbGetQuery(con,q)

aliquots <- unique(expr[,"tpm_barcode"])
mycor <- rep(0,length(aliquots))
for(i in 1:length(aliquots))
{
	cat("\r",i)
	sub_expr <- expr[which(expr[,"tpm_barcode"]==aliquots[i]),]
	mycor[i] <- cor(sub_expr[,"rpkm"],sub_expr[,"tpm"],method="s",use="complete.obs")
}
res <- data.frame(aliquots,mycor)
range(res[,"mycor"])
mean(res[,"mycor"])
median(res[,"mycor"])

# > range(res[,"mycor"])
# [1] 0.8941404 0.9551054
# > mean(res[,"mycor"])
# [1] 0.9383039
# > median(res[,"mycor"])
# [1] 0.9439455

#Check inter-sample TPM vs RPKM
myres <- matrix(0,nrow=length(aliquots),ncol=length(aliquots))
rownames(myres) <- colnames(myres) <- aliquots
for(i in 1:length(aliquots))
{
	for(j in 1:length(aliquots))
	{
		cat("\r",i,"-->",j)
		sub_expr1 <- expr[which(expr[,"tpm_barcode"]==aliquots[i]),]
		sub_expr2 <- expr[which(expr[,"tpm_barcode"]==aliquots[j]),]
		myres[i,j] <- cor(sub_expr1[,"tpm"],sub_expr2[,"rpkm"],method="s",use="complete.obs")
	}
}
range(diag(myres))
mean(diag(myres))
median(diag(myres))

# > range(diag(myres))
# [1] 0.8941404 0.9551054
# > mean(diag(myres))
# [1] 0.9383039
# > median(diag(myres))
# [1] 0.9439455

range(myres[upper.tri(myres)])
mean(myres[upper.tri(myres)])
median(myres[upper.tri(myres)])

# > range(myres[upper.tri(myres)])
# [1] -0.02629383  0.94715435
# > mean(myres[upper.tri(myres)])
# [1] 0.01414496
# > median(myres[upper.tri(myres)])

#Check inter-sample TPM vs TPM
myres <- matrix(0,nrow=length(aliquots),ncol=length(aliquots))
rownames(myres) <- colnames(myres) <- aliquots
for(i in 1:length(aliquots))
{
	for(j in 1:length(aliquots))
	{
		cat("\r",i,"-->",j)
		sub_expr1 <- expr[which(expr[,"tpm_barcode"]==aliquots[i]),]
		sub_expr2 <- expr[which(expr[,"tpm_barcode"]==aliquots[j]),]
		myres[i,j] <- cor(sub_expr1[,"tpm"],sub_expr2[,"tpm"],method="s",use="complete.obs")
	}
}
range(diag(myres))
mean(diag(myres))
median(diag(myres))

# > range(diag(myres))
# [1] 1 1
# > mean(diag(myres))
# [1] 1
# > median(diag(myres))
# [1] 1

range(myres[upper.tri(myres)])
mean(myres[upper.tri(myres)])
median(myres[upper.tri(myres)])

# > range(myres[upper.tri(myres)])
# [1] -0.02657313  0.98609227
# > mean(myres[upper.tri(myres)])
# [1] 0.01468341
# > median(myres[upper.tri(myres)])
# [1] 0.001844946

#---------------------------------

#Compare TPM matrix to TPM long format (FIXED)

library(DBI)
library(odbc)

gene_mat <- read.delim("/projects/varnf/GLASS-III/GLASS-III/results/kallisto/kallisto/final/gene_tpm_matrix_all_samples.tsv")
rownames(gene_mat) <- gene_mat[,1]
gene_mat <- gene_mat[,-1]
colnames(gene_mat) <- gsub("\\.","-",colnames(gene_mat))

con <- DBI::dbConnect(odbc::odbc(), "GLASSv3")

q <- "SELECT aliquot_barcode, gene_symbol, tpm
FROM analysis.gene_tpm"

tpm <- dbGetQuery(con,q)
tpm <- tpm[-which(is.na(tpm[,"gene_symbol"])),]

aliquots <- colnames(gene_mat)

mycor <- rep(0,length(aliquots))
for(i in 1:length(aliquots))
{
	mysamp <- tpm[which(tpm[,"aliquot_barcode"]==aliquots[i]),]
	mymat <- gene_mat[mysamp[,"gene_symbol"],aliquots[i]]

	mycor[i] <- cor(mysamp[,"tpm"],mymat,method="s")
}

range(mycor)
mean(mycor)
median(mycor)

# > range(mycor)
# [1] 1 1
# > mean(mycor)
# [1] 1
# > median(mycor)
# [1] 1

#---------------------------------
#Compare RPKM matrix to TPM matrix (FIXED)

expr <- read.delim("/projects/varnf/GLASS/data/CIBERSORT/synapse_final_RNAseq.txt",sep="\t",header=T,stringsAsFactor=F)
expr <- expr[,c(1,20:ncol(expr))]
rownames(expr) <- expr[,1]
expr <- expr[,-1]
expr <- t(expr)

gene_mat <- read.delim("/projects/varnf/GLASS-III/GLASS-III/results/kallisto/kallisto/final/gene_tpm_matrix_all_samples.tsv")
rownames(gene_mat) <- gene_mat[,1]
gene_mat <- gene_mat[,-1]

colnames(gene_mat) <- substr(colnames(gene_mat),1,15)
colnames(gene_mat) <- gsub("\\.","-",colnames(gene_mat))

comxx <- intersect(rownames(expr),rownames(gene_mat))
expr <- expr[comxx,]
gene_mat <- gene_mat[comxx,]

comxx <- intersect(colnames(expr),colnames(gene_mat))
expr <- expr[,comxx]
gene_mat <- gene_mat[,comxx]

mycor <- rep(0,ncol(expr))
for(i in 1:ncol(expr))
{
	mycor[i] <- cor(expr[,i],gene_mat[,i],method="s",use="complete")
}

range(mycor)
mean(mycor)
median(mycor)

# > range(mycor)
# [1] 0.8900890 0.9461537
# > mean(mycor)
# [1] 0.9307283
# > median(mycor)
# [1] 0.9323431


# Aggregating data

# A. Count() verb

# 1. Count and sorting
# Use count to find the number of counties in each region
# sort: sorts the data in descending order
counties_selected %>%
  count(region, sort = TRUE)

# 2. Count and weighting parameter
# Find number of counties per state, weighted by citizens, sorted in descending order
counties_selected %>%
  count(state, wt = citizens, sort = TRUE)

# 3. Count and mutate
counties_selected %>%
  # Add population_walk containing the total number of people who walk to work
  mutate(population_walk = walk * population / 100) %>%
  # Count weighted by the new column, sort in descending order
  count(state, wt = population_walk, sort = TRUE)

# B. Summarizing
# 1. Summarize overview
counties_selected %>%
  # Summarize to find minimum population, maximum unemployment, and average income
  summarize(min_population = min(population),
            max_unemployment = max(unemployment),
            average_income = mean(income)
  )

# 2. Summarize by state
counties_selected %>%
  group_by(state) %>%
  summarize(total_area = sum(land_area),
            total_population = sum(population)) %>%
  # Add a density column
  mutate(density = total_population / total_area) %>%
  # Sort by density in descending order
  arrange(desc(density))

# 3. Summarize by state and region
counties_selected %>%
  # Group and summarize to find the total population
  group_by(region, state) %>%
  summarize(total_pop = sum(population)) %>%
  # Calculate the average_pop and median_pop columns
  summarize(average_pop = mean(total_pop),
            median_pop = median(total_pop)
  )

# C. top_n
# 1. Selecting a county from each region
counties_selected %>%
  # Group by region
  group_by(region) %>%
  # Find the greatest number of citizens who walk to work. Second positional parameter relates to the column to filter by
  top_n(1, walk)

# 2. Finding the highest average income
counties_selected %>%
  group_by(region, state) %>%
  # Calculate average income
  summarize(average_income = mean(income)) %>%
  # Find the highest income state in each region
  top_n(1, average_income)

# 3. Finding which state has the largest population by Metro / Nonmetro area. Then count how many states this takes place
counties_selected %>%
  # Find the total population for each combination of state and metro
  group_by(state, metro) %>%
  summarize(total_pop = sum(population)) %>%
  # Extract the most populated row for each state
  top_n(1, total_pop) %>%
  # Count the states with more people in Metro or Nonmetro areas
  ungroup(metro) %>%
  count(metro)


# a * b^c
intpow <- function(a, b, c)
{
  if (c == 0)
    return(a)

  pow <- a

  while(1)
  {
    if (c%%2 == 1)
      pow <- pow * b

    c <- floor(c/2)
    if (c == 0)
      break

    b <- b*b
  }

  return( pow )
}

### from a to b by doubling
a2b_int_doubling <- function(a, b)
{
  n <- floor(log2(b/a))
  if (b %% 2 == 0)
    n <- n + 1

  vals <- integer(n)
  vals[1] <- a
  N <- a

  i <- 2
  while (N < b)
  {
    N <- 2L*N
    if (N <= b)
    {
      vals[i] <- N
      i <- i+1
    }
  }

  return(vals)
}

title_case <- function(x) gsub(x, pattern="(^|[[:space:]])([[:alpha:]])", replacement="\\1\\U\\2", perl=TRUE)


dim1 <- 1000000
dim2 <- 100

# create matrix with dim1 and dim"
data.speed.test <- matrix(rnorm(n = dim1 * dim2), nrow = dim1)

# with a loop compute mean per column and retur time needed
system.time({
  dim1.means.1 <- rep(NA, dim1)
  for(a in 1:dim1){
    dim1.means.1[a] <- mean(data.speed.test[a , ])
  }
})

# with apply compute mean per column and return time needed
system.time({
    dim1.means.2 <- apply(data.speed.test, 1, mean)
})


# Calculates the EMR cost per month, based on the number of events per month and the number of times per day the enrichment process is run
emrCostPerMonth <- function(eventsPerMonth, runsPerDay){
	runsPerMonth <- runsPerDay * 30
	eventsPerRun <- eventsPerMonth / runsPerMonth
	instanceHoursPerRun <- emrInstanceHoursRequired(eventsPerRun)
	costOfEachRun <- emrCostPerRunRaw(instanceHoursPerRun)

	# Monthly EMR cost = cost per run x runs per month
	costOfEachRun * runsPerMonth
}

# Function for modelling EMR costs based on number of Instances and number of hours
# Currently assumes that all instances are m1.small
emrCostPerRunRaw <- function(instancesHours){
	ec2PricePerHour <- 0.06
	emrPricePerInstancePerHour <- 0.015
	totalEmrPricePerInstancePerHour <- ec2PricePerHour + emrPricePerInstancePerHour
	totalEmrPricePerInstancePerHour * instancesHours
}

# Calculate the number of instance (m1small) hours required to process X lines of data
emrInstanceHoursRequired <- function(linesToProcess){
	# Following figures based on a regression analysis of job time vs number of lines processed
	intercept <- 3.788e-01
	gradient <-  3.689e-06
	instanceHoursRequired <- linesToProcess * gradient + intercept

	# Now round up to nearest whole number
	ceiling(instanceHoursRequired)
}