data=read.csv("C:\\Users\\Harsh Darji\\Desktop\\SS.csv", header=TRUE)   # Naming the file data

# Renaming Columns

colnames(data)<-c("satisfaction","airline_status","age","gender","price_sensitivity","year_of_first_flight","no_of_flights_per_annum",
                  "percent_of_flights_with_other_airlines","type_of_travel","no_of_loyalty_cards","shopping_amount_at_airport",
                  "eat_drink_at_airport","class","day_of_month","flight_date","airline_code","airline_name","origin_city",
                  "origin_state","destination_city","destination_state","schedule_departure_hour","departure_delay_in_minutes",
                  "arrival_delay_in_minutes","flight_cancelled","flight_time_in_minutes",
                  "flight_distance","arrival_delay_greater_than_5_minutes")

data$satisfaction<-substr(data$satisfaction,0,4) # treating 4.00.34 properly

str(data)

data$satisfaction<-as.numeric(data$satisfaction)

data$cust_satisfaction<-as.factor(data$cust_satisfaction)

cust_satisfaction=replicate(length(data$satisfaction), "nil")
cust_satisfaction[data$satisfaction >= 3]="1"
cust_satisfaction[data$satisfaction < 3]="0"
data$cust_satisfaction =cust_satisfaction

# Finding null values

colSums(is.na(data))

data_c<-subset(data,flight_cancelled=="Yes")

head(data_c)

colSums(is.na(data_c))

dim(data_c)

## Replacing NA's in  by mean

data_c$departure_delay_in_minutes[is.na(data_c$departure_delay_in_minutes)]<-round(mean(data_c$departure_delay_in_minutes,na.rm=TRUE))

# Replacing NAs by 0

data_c$flight_time_in_minutes <- replace(data_c$flight_time_in_minutes, is.na(data_c$flight_time_in_minutes),0)

data_c$arrival_delay_in_minutes <- replace(data_c$arrival_delay_in_minutes, is.na(data_c$arrival_delay_in_minutes),0)

data_m<-subset(data,flight_cancelled=="No")

colSums(is.na(data_m))

## Replacing NA's in Arrival_delay_in_minutes by mean

data_m$arrival_delay_in_minutes[is.na(data_m$arrival_delay_in_minutes)]<-round(mean(data_m$arrival_delay_in_minutes,na.rm=TRUE))

## Replacing NA's in fligt_time_in_minutes by mean

data_m$flight_time_in_minutes[is.na(data_m$flight_time_in_minutes)]<-round(mean(data_m$flight_time_in_minutes,na.rm=TRUE))

data_s<-subset(data_m,airline_name=="Southeast Airlines Co. ")

dim(data_s)

colSums(is.na(data_s))

data_a<-subset(data_m, airline_name!="Southeast Airlines Co. " )

dim(data_a)

# Plots

library(ggplot2)

ggplot(data_s,aes(x=age,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_s$satisfaction ,group=1), fun.y=mean, colour="blue", geom="line",group=1)

ggplot(data_a,aes(x=age,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

ggplot(data_s,aes(x=gender,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_s$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_a,aes(x=gender,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_s,aes(x=type_of_travel,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_s$satisfaction ,group=1), fun.y=mean, colour="blue", geom="line",group=1)

ggplot(data_a,aes(x=type_of_travel,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

ggplot(data_s,aes(x=class,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_s$satisfaction ,group=1), fun.y=mean, colour="blue", geom="line",group=1)

ggplot(data_a,aes(x=class,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

# Satisfaction Vs Airline Status

ggplot(data_s,aes(x=airline_status,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_s$satisfaction ,group=1), fun.y=mean, colour="blue", geom="line",group=1)

ggplot(data_a,aes(x=airline_status,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

# Satisfaction Vs No of flights per annum

ggplot(data_s,aes(x=no_of_flights_per_annum,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_s$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_a,aes(x=no_of_flights_per_annum,y=satisfaction))+geom_count()+
stat_summary(aes(y =data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

# satisfaction Vs year of first flight

data_s$year_of_first_flight<-as.factor(data_s$year_of_first_flight)
data_a$year_of_first_flight<-as.factor(data_a$year_of_first_flight)

ggplot(data_s,aes(x=year_of_first_flight,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

ggplot(data_a,aes(x=year_of_first_flight,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

# Satisfaction Vs shopping amount at AIRPORT

ggplot(data_s,aes(x=shopping_amount_at_airport,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_a,aes(x=shopping_amount_at_airport,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_s,aes(x=eat_drink_at_airport,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_a,aes(x=eat_drink_at_airport,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_s,aes(x=departure_delay_in_minutes,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_a,aes(x=departure_delay_in_minutes,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_s,aes(x=arrival_delay_in_minutes,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_a,aes(x=arrival_delay_in_minutes,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_s,aes(x=flight_time_in_minutes,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_a,aes(x=flight_time_in_minutes,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_s,aes(x=flight_distance,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="point",group=1)

ggplot(data_a,aes(x=flight_distance,y=satisfaction))+geom_count()+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="point",group=1)

ggplot(data_s,aes(x=arrival_delay_greater_than_5_minutes,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

ggplot(data_a,aes(x=arrival_delay_greater_than_5_minutes,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="line",group=1)

ggplot(data_s,aes(x=day_of_month,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_s$satisfaction ,group=1), fun.y=mean, colour="red", geom="line",group=1)

ggplot(data_a,aes(x=day_of_month,y=satisfaction))+geom_count(aes(color = ..n..))+
stat_summary(aes(y=data_a$satisfaction ,group=1), fun.y=mean, colour="blue", geom="line",group=1)

data_s$cust_satisfaction <-as.factor(data_s$cust_satisfaction)
data_a$cust_satisfaction <-as.factor(data_a$cust_satisfaction)

b0<-data.frame(table(data_s$cust_satisfaction))
b0

b1<-ggplot(b0,aes(x=reorder(Var1,Freq),y=Freq, group=1))
b1<-b1+geom_bar(stat="identity",fill="black",width=0.2)
#b1<-b1+theme(axis.text.x=element_text(angle=90,hjust=1))
b1<-b1+xlab("Cust satisfaction")+ylab("NUmber of satisfied customers")+ggtitle("1=Satisfied cutomers,0=not satisfied customer")
b1

b0<-data.frame(table(data_a$cust_satisfaction))
b0

b1<-ggplot(b0,aes(x=reorder(Var1,Freq),y=Freq, group=1))
b1<-b1+geom_bar(stat="identity",fill="black",width=0.2)
#b1<-b1+theme(axis.text.x=element_text(angle=90,hjust=1))
b1<-b1+xlab("Cust satisfaction")+ylab("NUmber of satisfied customers")+ggtitle("1=Satisfied cutomers,0=not satisfied customer")
b1

#Linear Regression On Southeast:

class(s)

lm1<-lm(satisfaction~age+airline_status+price_sensitivity+year_of_first_flight+no_of_flights_per_annum
           +percent_of_flights_with_other_airlines+type_of_travel+no_of_loyalty_cards+shopping_amount_at_airport
           +eat_drink_at_airport+class+day_of_month+flight_date+origin_city+origin_state+destination_city+destination_state
           +schedule_departure_hour+departure_delay_in_minutes+ +arrival_delay_in_minutes+flight_time_in_minutes+flight_distance
           +arrival_delay_greater_than_5_minutes,data=data_s)

summary(lm1)

#Taing significant P values to make a new model

final_lm<-lm(satisfaction~age+airline_status+no_of_flights_per_annum+type_of_travel+eat_drink_at_airport+
             class+schedule_departure_hour+arrival_delay_greater_than_5_minutes,
             data=data_s)

summary(final_lm)

# But we see that Adjusted R square has gone up, which indicates new model is better and we can discard other variables..

# Logistic

logit.m<-glm(cust_satisfaction~age+airline_status+price_sensitivity+year_of_first_flight+no_of_flights_per_annum
           +percent_of_flights_with_other_airlines+type_of_travel+no_of_loyalty_cards+shopping_amount_at_airport
           +eat_drink_at_airport+class+day_of_month
           +schedule_departure_hour+departure_delay_in_minutes+ +arrival_delay_in_minutes+flight_time_in_minutes+flight_distance
           +arrival_delay_greater_than_5_minutes,data=data_s,family=binomial(link='logit'))

summary(logit.m)

#Anova

#The difference between the null deviance and the residual deviance shows how our model is
# doing against the null model (a model with only the intercept). The wider this gap, the better.

anova(logit.m,test="Chisq")

anova(logit.m,test="Chisq")

# Adding Age, airline_status and type_of_travel significantly reduces the residual deviance.
# The other variables seem to improve the model less even though class and  arrival_delay_greater_than_5_minutes
# has a low p-value.
# A large p-value here indicates that the model without the variable explains more or less the same amount of variation.
# Ultimately what you would like to see is a significant drop in deviance and the AIC.
# Here(logistic regression) doesn't have equivalent R^2 value like in Linear regression,
# but the McFadden R2 index can be used to assess the model fi

logit.final<-glm(cust_satisfaction~age+airline_status+no_of_flights_per_annum+type_of_travel+departure_delay_in_minutes+
                arrival_delay_in_minutes+arrival_delay_greater_than_5_minutes,data=data_s,
           family=binomial(link='logit'))

summary(logit.m)

anova(logit.final,test="Chisq")

# From both linear and logistic regression we get the sam variables which are significant so now we will use only those variables for prediction

nrow(data_s)

test<-data_s[7000:9000,]

colnames(data_s)

fitted.results <- predict(logit.final,newdata=subset(data_s,select=c(2,3,7,9,12,13,22,23,24,28)),type='response')
fitted.results <- ifelse(fitted.results > 0.3,1,0)
misClasificError <- mean(fitted.results != data_s$cust_satisfaction)

print(paste('Accuracy',1-misClasificError))

# Finding area under the curve

library(ROCR)

p<- predict(logit.m,newdata=subset(test,select=c(2,3,4,5,6,7,8,9,10,11,12,13,14,22,23,24,26,27,28)),type='response')
pr<-prediction(p,test$cust_satisfaction)
prf<-performance(pr,measure="tpr",x.measure="fpr")
plot(prf)

auc<-performance(pr,measure="auc")
auc<-auc@y.values[[1]]
auc

aucraccy<-auc*100.0
aucraccy

#SVM

# For svm we will use only the significant variables:
set.seed(3033)
library(caret)

intrain<-createDataPartition(y=data_s$cust_satisfaction,p=0.7,list=FALSE) #spiting 70-30
training<-data_s[intrain,]
testing<-data_s[-intrain,]

mytrain<-trainControl(method="repeatedcv",number=10, repeats=3)
set.seed(3233)
# repeatedcv= repeated cross validatio

#preProcess parameter center & scale,
#These two help for centering and scaling the data.
#After preProcessing these convert our training data with mean value as approximately 0 and standard deviation as 1.
# The tuneLength parameter holds an integer value. This is for tuning our algorithm.

mysvm<-train(cust_satisfaction~age+airline_status+no_of_flights_per_annum+type_of_travel+departure_delay_in_minutes+
                arrival_delay_in_minutes+arrival_delay_greater_than_5_minutes,
             data=training,
             method="svmLinear"
            )

summary(mysvm)

mysvm

# SVM class method

library(kernlab)

newtrain <-training[,c(2,3,4,5,6,7,8,9,10,11,12,13,14,22,23,24,26,27,28,29)]
newtest<-testing[,c(2,3,4,5,6,7,8,9,10,11,12,13,14,22,23,24,26,27,28,29)]
head(newtrain$cust_satisfaction)

myOutput<-ksvm(cust_satisfaction ~., data=newtrain, kernel = "rbfdot",kpar="automatic", C=5,cross=3, prob.model=TRUE)

myOutput

# See the output of Support vector histogram to understand outcome
hist(alpha(myOutput)[[1]], main="support vector histogram with C=5",
     xlab="support vector values")

svmPred <- predict(myOutput, newtest, type = "votes")
svmPred
str(svmPred)
head(svmPred)

# Create a confusion matrix (a 2 x 2 table)
comTable <- data.frame(newtest[ ,20], svmPred[2, ])
table(comTable)

# Calculate an error rate based on what you see in the confusion matrix.
t<-table(comTable)
y<-sum(t[1,1]+t[2,2])/sum(t)

Y<-y*100.0

Y


# ......................................................................................
# ............................ Cvičení 12. Vícevýběrové testy...........................
# .................. Michal Béreš, Martina Litschmannová, Adéla Vrtková.................
# ......................................................................................

# 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

# * Testovací data pro ukázku volání funkcí ####

# vyrobím data framy o jednom sloupci z náh. dat
a = as.data.frame(rnorm(n = 35, mean = 107, sd = 10))
b = as.data.frame(rnorm(n = 30, mean = 105, sd = 10))
c = as.data.frame(rnorm(n = 40, mean = 102, sd = 10))
d = as.data.frame(rnorm(n = 32, mean = 101, sd = 10))

# přejmenuju název sloupce
colnames(a) = c("hodnota")
colnames(b) = c("hodnota")
colnames(c) = c("hodnota")
colnames(d) = c("hodnota")

# doplním typ pro všechny data framy
a$typ = "a"
b$typ = "b"
c$typ = "c"
d$typ = "d"

# slepím po řádcích dohromady
data = rbind(a,b,c,d)
# převedu typ na typ factor
data$typ = as.factor(data$typ)

head(data)

boxplot(data$hodnota ~ data$typ)
# pokud jsou k dispozici nějaká OP, budu je igrorovat
# (vím, že data jsou z normálního rozdělení!)
# (vím i že mají stejný rozptyl)

#  Přehled funkcí  ####
# * Míry variability ####
# ** Bartlettův test ####
# - ověřuje shodu rozptylů
#     - $H_0: \sigma^2_1 = \sigma^2_2 = \sigma^2_3 = \ldots$
#     - $H_A: \neg H_0$
# - předpokladem je normalita dat (a samozřejmě nezávislost a spojitost)

bartlett.test(data$hodnota ~ data$typ)

# ** Leveneův test ####
# - ověřuje shodu rozptylů
#     - $H_0: \sigma^2_1 = \sigma^2_2 = \sigma^2_3 = \ldots$
#     - $H_A: \neg H_0$
# - předpokladem je pouze nezávislost a spojitost

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

# ** Cochranův a Hartleyův test ####
# - také ověřují shodu rozptylů
# - požadují normalitu dat a tzv. vyvážené třízení
#     - vyvážené třízení znamená, že máme přibližně stejné množství dat v každé skupině
# - nebudeme je používat
#
# * Míry polohy ####
# ** ANOVA (analýza rozptylu) ####
# - ověřuje shodu polohy (středních hodnot)
#     - $H_0: \mu_1 = \mu_2 = \mu_3 = \ldots$
#     - $H_A: \neg H_0$
# - předpoklady:
#     - normalita dat
#     - homoskedasticita (shodné rozptyly)
#     - (a samozřejmě nezávislost a spojitost)
# - pokud zamítáme $H_0$ je vyžadována Post-Hoc analýza
#     - pomocí TukeyHSD testu

# Základní ANOVA
# H0: mu1 = mu2 = mu3 = mu4
# HA: ~H0 (negace H0)

res = aov(data$hodnota ~ data$typ)
summary(res)

# Post-Hoc analýza

TukeyHSD(res)

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(data$hodnota)
prumer_vsech

# průměry ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(mean_skup = mean(hodnota))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# ** Kruskalův - Wallisův test ####
# - ověřuje shodu polohy (mediánů)
#     - $H_0: X_{0.5,1} = X_{0.5,2} = X_{0.5,3} = \ldots$
#     - $H_A: \neg H_0$
# - předpoklady:
#     - symetrie dat
#     - (a samozřejmě nezávislost a spojitost)
# - pokud zamítáme $H_0$ je vyžadována Post-Hoc analýza
#     - pomocí Dunnové testu/metody

# Základní KW test
# H0: X0.5,1 = X0.5,2 = X0.5,3 = X0.5,4
# HA: ~H0 (negace H0)

kruskal.test(data$hodnota ~ data$typ)

# Post-Hoc analýza

# altP = T nastavuje p-hodnotu tak,aby se při rozhodování
# o statistické významnosti srovnávala s alfa
# (defaultně: altp = FALSE, pak srovnáváme s alfa/2)

# install.packages("dunn.test")

dunn.test::dunn.test(x = data$hodnota, g = data$typ,
          method = "bonferroni", altp = TRUE)

# počítání efektů

# celkový median
median_vsech = median(data$hodnota)
median_vsech

# mediany ve skupinách
efekty = data %>% group_by(typ) %>%
    summarize(median_skup = median(hodnota))

# efekty
efekty$efekt = efekty$median_skup - median_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

#  Příklady ####
# * Příklad 1. ####
# Testujeme nulovou hypotézu µ1 = µ2 = µ3. Bylo zjištěno, že data, která máme k
# dispozici jsou výběry z normálního rozdělení splňující předpoklad homoskedasticity
# (shody rozptylů). Na základě údajů získaných explorační analýzou doplňte tabulku ANOVA
# a vyplývající závěry.
# Obrázek viz sbírka úloh.

n = c(40,40,42)          # rozsahy výběrů
prum = c(300,290,310)    # průměry v jednotlivých skupinách / třídách
s = c(33,34,31)          # směr. odchylky v jednotlivých skup. / třídách

n.total = sum(n)         # celkový rozsah výběrů
k = 3                    # počet tříd
df.b = k-1               # počet stupňů volnosti - meziskupinový
df.e = n.total-k         # počet stupňů volnosti - reziduální

# celkový průměr (pomocí váženého průměru)
prum.total = weighted.mean(x = prum, w = n)
prum.total

# meziskupinový součet čtverců
ss.b = sum(n*(prum - prum.total)^2)
ss.b

# reziduální součet čtverců
ss.e = sum((n - 1)*s^2)
ss.e

# celkový součet čtverců
ss.b + ss.e

# rozptyl mezi skupinami / třídami
ms.b = ss.b/df.b
ms.b

# rozptyl uvnitř skupin / tříd
ms.e = ss.e/df.e
ms.e

# F-poměr
F = ms.b/ms.e
F

# p-hodnota
p = 1 - pf(F,df.b,df.e)
p

# Na hladině významnosti 0,05 zamítáme hypotézu o shodě středních hodnot
# tj. střední hodnoty alespoň jedné dvojice skupin se stat. významně liší.

# odhady skupinových efektů
efekt = prum - prum.total
efekt

# Oproti celkovému průměru vykazuje nejvíce podprůměrné výsledky skupina 2
# (o cca 10 jednotek nižší než celkový průměr). Naopak průměr skupiny 3 je
# o cca 10 jednotek vyšší než celkový průměr. Průměrné výsledky skupiny 1
# odpovídají celkovému průměru.

# * Příklad 2. ####
# 122 pacientů, kteří podstoupili operaci srdce, bylo náhodně rozděleno do tří
# skupin.
# **Skupina 1:** Pacienti dostali 50 % oxidu dusného a 50 % kyslíkové směsi nepřetržitě
# po dobu 24 hodin.
# **Skupina 2:** Pacienti dostali 50 % oxidu dusného a 50 % kyslíkové směsi pouze během
# operace.
# **Skupina 3:** Pacienti nedostali žádný oxid dusný, ale dostali 35-50 % kyslíku po
# dobu 24 hodin.
# Data v souboru kyselina listova.xls odpovídají koncentracím soli kyseliny listové v
# červených krvinkách ve všech třech skupinách po uplynutí 24 hodin ventilace. Ověřte,
# zda pozorované rozdíly mezi koncentracemi soli kyseliny listové jsou statisticky
# významné, tj. zda existuje vliv složení směsi na sledovaný parametr.

kysel = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx", sheet=1)
colnames(kysel) = c("sk1","sk2","sk3")   # přejmenování sloupců
kysel

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

boxplot(kysel.s$hodnoty ~ kysel.s$skupina)
# Data neobsahují odlehlá pozorování.

# otestujeme normalitu pomocí S.-W. testu
library(dplyr)

kysel.s %>% group_by(skupina) %>%
    summarise(norm.pval = shapiro.test(hodnoty)$p.value)

# Informace potřebné pro nastavení zaokrouhlování

kysel.s %>% group_by(skupina) %>%
    summarise(len = length(hodnoty), st.dev = sd(hodnoty))

# sd zaokrouhlujeme na 3 platné cifry
# sd a míry polohy zaokrouhlujeme na desetiny

# Ověření shody rozptylů
s2 = kysel.s %>% group_by(skupina) %>%
        summarise(var = sd(hodnoty)^2)
s2 # výběrové rozptyly

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího
# rozptylů (<2) nepředpokládáme, že se rozptyly statisticky významně liší

# Předpoklad normality nebyl zamítnut -> Bartlettův test
bartlett.test(kysel.s$hodnoty ~ kysel.s$skupina)

# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů
# (Bartlettův test, x_OBS = 0,878, df = 2, p-hodnota = 0,645).

# Chceme srovnávat stř. hodnoty nezávislých výběrů z normálních rozdělení
# se stejnými rozptyly -> ANOVA
# příkaz aov() vyžaduje data ve standardním datovém formátu

vysledky = aov(kysel.s$hodnoty ~ kysel.s$skupina)
summary(vysledky)

# Na hladině významnosti 0,05 zamítáme hypotézu o shodě středních hodnot
# (ANOVA, p-hodnota<<0,001) -> mnohonásobné porovnávání

# post-hoc analýza
TukeyHSD(vysledky)

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(kysel.s$hodnoty)
prumer_vsech

# průměry ve skupinách
efekty = kysel.s %>% group_by(skupina) %>%
    summarize(mean_skup = mean(hodnoty))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# Považujeme-li vysoký obsah kyseliny listové za pozitivní, pak statisticky
# významně nejlepších výsledků dosáhli pacienti ze skupiny 1 (průměrný obsah
# kys. listové o cca 27 jednotek vyšší než prům. obsah kys. listové v krvi
# všech testovaných pacientů) a statisticky významně nejhorších výsledků
# dosáhli pacienti ze skup. 2 (průměrný obsah kys. listové o cca 26 jednotek
# nižší než průměrný obsah kys. listové v krvi všech testovaných pacientů).
# Obsah kys. listové v krvi pacientů ze skupiny 3
# odpovídá celkovému průměru. Všechny tři skupiny pacientů jsou navzájem dle
# obsahu kys. listové v krvi statisticky významně odlišné.

# * Příklad 3. ####
# Na farmě jsou chována tři plemena králíků. Byl proveden pokus kralici.xls, jehož cílem
# bylo zjistit, zda i když chováme a vykrmujeme všechny králíky po stejnou dobu a za
# stejných podmínek, existuje statisticky významný (průkazný) rozdíl mezi plemeny v
# hmotnostech králíků. Ověřte.

kralici = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx", sheet=2)
colnames(kralici) = c("viden","cesky","kalif")   # přejmenování sloupců
kralici

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

boxplot(kralici.s$hodnoty ~ kralici.s$skupina)
# data obsahojí OP

# Odstranění odlehlého pozorování
pom = boxplot(kralici.s$hodnoty ~ kralici.s$skupina, plot = FALSE)
pom$out

kralici.s$hodnoty.bez = kralici.s$hodnoty
kralici.s$hodnoty.bez[kralici.s$hodnoty.bez %in% pom$out]=NA

# Krabicový graf
boxplot(kralici.s$hodnoty.bez ~ kralici.s$skupina)

library(dplyr)

kralici.s %>% group_by(skupina) %>%
    summarise(norm.pval = shapiro.test(hodnoty.bez)$p.value)

# Na hladině významnosti 0,05 nezamítáme předpoklad normality.

# Informace potřebné pro nastavení zaokrouhlování
kralici.s %>% group_by(skupina) %>%
    summarize(len = sum(!is.nan(hodnoty.bez)),
              sd = sd(hodnoty.bez, na.rm = TRUE))

# sd zaokrouhlujeme na 2 platné cifry
# sd a míry polohy zaok. na setiny (sjednocení napříč druhy králíků)

# Ověření shody rozptylů
s2 = kralici.s %>% group_by(skupina) %>%
        summarize(var = sd(hodnoty.bez, na.rm = TRUE)^2)
s2

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího rozpt.
# (blízký 2, avšak rozsah výběrů < 30) je těžší odhadnout, zda lze
# předpokládat shodu rozptylů. Rozhodnout nám pomůže test.

# Předpoklad normality nebyl zamítnut -> Bartlettův test
bartlett.test(kralici.s$hodnoty.bez ~ kralici.s$skupina)

# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů
# (Bartlettův test, x_OBS = 3,1, df = 2, p-hodnota = 0,217).

# Chceme srovnávat stř. hodnoty nezávislých výběrů z normálních
# rozdělení se stejnými rozptyly -> ANOVA
# příkaz aov() vyžaduje data ve standardním datovém formátu

vysledky = aov(kralici.s$hodnoty.bez ~ kralici.s$skupina)
summary(vysledky)

# Na hladině významnosti 0,05 zamítáme hypotézu o shodě středních hodnot
# (p-hodnota<<0,001, ANOVA) -> mnohonásobné porovnávání

# post-hoc analýza
TukeyHSD(vysledky)

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(kralici.s$hodnoty.bez, na.rm = TRUE)
prumer_vsech

# průměry ve skupinách
efekty = kralici.s %>% group_by(skupina) %>%
    summarize(mean_skup = mean(hodnoty.bez, na.rm = TRUE))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# * Příklad 4. ####
# Soutěž o nejlepší jakost výrobků obeslali čtyři výrobci A, B, C, D celkem 66 výrobky.
# Porota sestavila pořadí (uvedeno pouze pořadí výrobku od nejlepšího k nejhoršímu), jež
# je uvedené v souboru jakost.xls. Na základě uvedených údajů posuďte, zda původ výrobků
# má vliv na jeho jakost.

jakost.s = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx", sheet = 3)
colnames(jakost.s) = c("poradi", "skupina")   # přejmenování sloupců
head(jakost.s)
# data již jsou v standardním formátu

boxplot(jakost.s$poradi ~ jakost.s$skupina)

# Ověření normality nemá smysl provádět - z povahy jde o diskr. data-pořadí

# Informace potřebné pro nastavení zaokrouhlování
jakost.s %>% group_by(skupina) %>%
    summarize(len = length(poradi),
              sd = sd(poradi))

# sd zaokrouhlujeme na 2 platné cifry
# sd a míry polohy zaokrouhlujeme na celá čísla

# Ověření shody rozptylů
s2 = jakost.s %>% group_by(skupina) %>% summarize(var = sd(poradi)^2)
s2

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího
# rozptylů (<2) ze předpokládat shodu rozptylů.
# (Kruskalův - Wallisův test má větší sílu testu, jsou-li data homosk.)

# Jde o "pořadová" data, nemá smysl uvažovat o předpokladu norm.
# -> Leveneův test
car::leveneTest(jakost.s$poradi ~ jakost.s$skupina)
# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů
# (Leveneho test, x_OBS = 0,4, df_num = 3, df_denom = 62, p-hodnota = 0,750)

# Ověření symetrie

jakost.s %>% group_by(skupina) %>%
    summarize(sikmost = moments::skewness(poradi),
              test.pval = lawstat::symmetry.test(poradi,boot=FALSE)$p.value)

# Chceme srovnávat mediány nezávislých výběrů -> Kruskalův-Wallisův test
kruskal.test(jakost.s$poradi ~ jakost.s$skupina)

# Na hladině významnosti 0,05 nelze zamítnout hypotézu o shodě mediánů
# (Kruskalův-Wallisův test, x_OBS = 3,7, df = 3, p-hodnota=0,295).
# Tj. statisticky významné rozdíly mezi výrobci (z hlediska pořadí
# výrobků v soutěži) neexistují.

# * Příklad 5. ####
# Byl sledován vliv tří preparátů na srážlivost krve. Kromě jiných ukazatelů byl
# zjišťován tzv. trombinový čas. Údaje o 42 sledovaných osobách jsou zaznamenány v
# souboru trombin.xls. Závisí velikost trombinového času na tom, jaký byl použit
# preparát?

trombin.s = readxl::read_excel("./CV12/data/testy_vicevyberove.xlsx",
                               sheet=4, skip = 1)
colnames(trombin.s) = c("hodnoty","skupina")   # přejmenování sloupců

head(trombin.s)
# data jsou již ve standardním formátu

# explorační analýza - ověření OP
boxplot(trombin.s$hodnoty ~ trombin.s$skupina)
# neobsahuje OP

# ověření normality
library(dplyr)

trombin.s %>% group_by(skupina) %>%
    summarize(norm.pval = shapiro.test(hodnoty)$p.value)

# Na hladině významnosti 0,05 zamítáme předpoklad normality (u Ačka)

# Informace potřebné pro nastavení zaokrouhlování

trombin.s %>% group_by(skupina) %>%
    summarize(len = length(hodnoty), stdev = sd(hodnoty))

# sd zaokrouhlujeme na 2 platné cifry
# sd a míry polohy zaokrouhlujeme na setiny (sjednocení napříč skupinami)

# Ověření shody rozptylů (není nutné - stejně musíme použít KW)
s2 = trombin.s %>% group_by(skupina) %>%
        summarize(var = sd(hodnoty)^2)
s2

max(s2$var)/min(s2$var)
# Dle krabicového grafu a informace o poměru největšího a nejmenšího
# rozptylů (>>2) nelze předpokládat shodu rozptylů.

# Předpoklad normality byl zamítnut -> Leveneho test

#trombin.s$skupina = as.factor(trombin.s$skupina)

car::leveneTest(trombin.s$hodnoty ~ trombin.s$skupina)

# předpoklad homoskedasticity byl zamítnut

# Ověření symetrie
trombin.s %>% group_by(skupina) %>%
  summarize(sikmost = moments::skewness(hodnoty),
            test.pval = lawstat::symmetry.test(hodnoty, boot=FALSE)$p.value)
# nezamítáme přepoklad symetrie dat

# Chceme srovnávat mediány nez. výběrů, která nemají norm. rozdělení
# -> Kruskalův - Wallisův test

kruskal.test(trombin.s$hodnoty,trombin.s$skupina)
# Na hladině významnosti 0,05 zamítáme hypotézu o shodě mediánů
# Tj. trombinový čas je statisticky významně
# ovlivněn preparátem. -> mnohonásobné porovnávání

# altP = T nastavuje p-hodnotu tak,aby se při rozhodování
# o statistické významnosti srovnávala s alfa
# (defaultně: altp = FALSE, pak srovnáváme s alfa/2)

dunn.test::dunn.test(trombin.s$hodnoty,trombin.s$skupina,
          method = "bonferroni", altp = TRUE)

# počítání efektů
library(dplyr)

# celkový průměr
median_vsech = median(trombin.s$hodnoty)
median_vsech

# průměry ve skupinách
efekty = trombin.s %>% group_by(skupina) %>%
    summarize(median_skup = median(hodnoty))

# efekty
efekty$efekt = efekty$median_skup - median_vsech

# vypsat setřízené
efekty %>% arrange(desc(efekt))

# * Příklad 6. (více skupin) ####
# Co se Sněhurka dostala k sedmi trpaslíkům vycítila příležitost nemalého výdělku.
# Trpaslíci Sněhurce v podstatě zobou z ruky a veškeré vydolované zlato jí ihned
# předávají. Sněhurce však ani toto úplně nestačí a má pocit, že by mohla z trpaslíků
# benefitovat více. Proto si začla zaznamenávat kolik kilogramů zlata denně od každého z
# trpaslíků obdrží (snehurka.xlsx). Ověřte, zda se trpaslíci liší v množství vytěženého
# zlata, pokud ano sestave homogenní skupiny z hlediska vytěženého zlata.

zlato = readxl::read_excel("./CV12/data/snehurka.xlsx")
head(zlato)
# data jsou ve standardním dtovém formátu

boxplot(zlato$hodnota ~ zlato$typ)
# data neobsahují OP

# ověření normality
library(dplyr)

zlato %>% group_by(typ) %>%
    summarize(p.hodnota = shapiro.test(hodnota)$p.value)

# Na hladině významnosti 0,05 ne zamítáme předpoklad normality

# Předpoklad normality nebyl zamítnut -> Bartlettův test
bartlett.test(zlato$hodnota ~ zlato$typ)

# Na hladině významnosti 0,05 nelze zamítnout předpoklad o shodě rozptylů

# ANOVA
vysledky = aov(zlato$hodnota ~ zlato$typ)
summary(vysledky)
# Zamítáme předpoklad o shodě
# -> existují stat. významné rozdíly ve středních hodnotách

# POST-HOC
res = TukeyHSD(vysledky)[[1]]
res

# počítání efektů
library(dplyr)

# celkový průměr
prumer_vsech = mean(zlato$hodnota)
prumer_vsech

# průměry ve skupinách
efekty = zlato %>% group_by(typ) %>%
    summarize(mean_skup = mean(hodnota))

# efekty
efekty$efekt = efekty$mean_skup - prumer_vsech

# vypsat setřízené
efekty.s = efekty %>% arrange(desc(efekt))
efekty.s


#########################################################
#####  Main file: estimate radiation, conductance,  #####
#####  photosynthesis, and evapotranspiration with  #####
#####             process based model               #####
#########################################################

# Load model functions
source('eco_model.r')
library(pracma)

# Load data
dat <- read.table('./data/TdrTsoilWindLaiPrecParTaVpdMay2001-Daytime.txt')
names(dat) <- c('Month', 'Day','Hour','Minute','Tdr','Tsoil','Wind','Lai','Prec','Par','Ta','Vpd')
dat$Year <- 2001

# Convert VPD from kPa to Pa
dat$Vpd <- dat$Vpd*1000

# Define global variables and model parameters
define_global_variables()

# Calculate solar zenith, elevation, azimuth, and declination angles
sun <- compute_sun_angles(LATI, LONGI, dat$Year, dat$Month, dat$Day, dat$Hour, dat$Minute)

# Calculate top of canopy diffuse/direct components of PAR and NIR
rad <- compute_toc_down_rad(dat$Par, sun$zenith, sun$jday)

# calculate sunlit and shaded components of LAI
i <- seq(from=0, to=89, by=1)
kb <- sqrt(x^2 + tan(i*pi/180)^2 / (x + 1.774 * (x+1.182)^-0.733))
beer <- function(lai, kb, omega) exp(-kb * omega * lai) # Beer's law
trans_D <- outer(dat$Lai, kb, beer, omega=omega) # apply function across all LAIs and angles
trans_d <- apply(trans_D, 1, function(trans_D, i) trapz(i, 2*trans_D*sin(i*pi/180.0)*cos(i*pi/180.0)*(pi/180)), i=i) # integrate across all angles

Kd <- -log(trans_d)/dat$Lai
Kb <- omega * sqrt(x^2 + tan(sun$zenith)^2) / (x + 1.774*(x+1.182)^-0.733)

sunlit_lai <- (1 - exp(-Kb*dat$Lai)) / Kb
shaded_lai <- dat$Lai - sunlit_lai

# Compute canopy shortwave radiation
canopy_shortwave <- compute_canopy_intercepted_shortwave_rad(rad$par_D,
                                                             rad$par_d,
                                                             rad$nir_D,
                                                             rad$nir_d,
                                                             dat$Lai,
                                                             Kb,
                                                             Kd)

# Compute canopy longwave radiation
canopy_longwave <- compute_longwave_rad(dat$Ta, dat$Tsoil, dat$Vpd, rad$cloud)

# Compute net radiation
canopy_net_rad <- compute_canopy_net_rad(canopy_shortwave,
                                         canopy_longwave,
                                         rad,
                                         sunlit_lai,
                                         shaded_lai,
                                         Kb,
                                         Kd)

# Estimate aerodynamic resistance and conductance
ra <- canopy_aerodynamic_resistance(dat$Wind, hs, h2)
ra[dat$Wind <= 0] <- 1.0 / g1_blayer
ga <- 1/ra

# Compute soil resistance
rs_u <- compute_soil_surface_resistance(dat$Tdr)
ra_u <- ra

# Estimate photosynthesis parameters
psn_para <- compute_psn_parameters(dat$Ta, Kb, sunlit_lai, shaded_lai)
fsoil_theta <- 1.0

# Calcuate photosynthesis and stomatal conductance for sunlit leaves
sunlit <- 1;
psn_sunlit <- compute_bwb_farq_psn(psn_para,
                                   canopy_shortwave$sunlit_apar,
                                   dat$Ta,
                                   dat$Vpd,
                                   fsoil_theta,
                                   sunlit)

out <- canopy_bwb_stomatal_conductance(psn_sunlit, dat$Ta, m, dat$Vpd)
gs_sunlit <- out$gs
gc_sunlit <- out$gc

rs_sunlit <- 1/gs_sunlit
rs_sunlit[gs_sunlit<=0] <- 1e6

# Calculate photosynthesis and stomatal conductance for shaded leaves
sunlit <- 0
psn_shaded <- compute_bwb_farq_psn(psn_para,
                                   canopy_shortwave$shaded_apar,
                                   dat$Ta,
                                   dat$Vpd,
                                   fsoil_theta,
                                   sunlit)

out <- canopy_bwb_stomatal_conductance(psn_shaded, dat$Ta, m, dat$Vpd)
gs_shaded <- out$gs
gc_shaded <- out$gc

rs_shaded <- 1/gs_shaded
rs_shaded[gs_shaded<=0] <- 1e6

# Calculate evapotranspiration using Penman-Monteith model
ET_sunlit <- penman_monteith(dat$Ta,
                             canopy_net_rad$Rnet_sunlit,
                             gs_sunlit,
                             ga,
                             dat$Vpd)

ET_shaded <- penman_monteith(dat$Ta,
                             canopy_net_rad$Rnet_shaded,
                             gs_shaded,
                             ga,
                             dat$Vpd)

ET_understory <- penman_monteith(dat$Ta,
                                 canopy_net_rad$Rnet_floor,
                                 1/rs_u,
                                 1/ra_u,
                                 dat$Vpd)

S <- dat$Tdr / porosity

Exfil_soil <- compute_potential_exfiltration(S,
                                             soil_depth,
                                             Ksat,
                                             m_z,
                                             p1,
                                             p2,
                                             p_0,
                                             porosity)

ET_understory <- pmin(Exfil_soil, ET_understory)

# Add outputs to data frame
dat$apar <- canopy_shortwave$sunlit_apar*sunlit_lai +
  canopy_shortwave$shaded_apar*shaded_lai
dat$rnet <- canopy_net_rad$Rnet_stand
dat$psn <- (psn_sunlit*sunlit_lai + psn_shaded*shaded_lai)*0.012
dat$A <- psn_sunlit*sunlit_lai + psn_shaded*shaded_lai # um/m^2/s
dat$gc <- 1000000*(gc_sunlit*sunlit_lai + gc_shaded*shaded_lai) / (22.4/1000.0) # um/m^2/s
dat$et <- ET_sunlit*sunlit_lai + ET_shaded*shaded_lai + ET_understory


#' F-test of Overall Siginificance in Linear Regression
#'
#' @param x a string of covariates
#' @param arms a string of treatment variables
#' @param arms_label a string vector with labels of treatment arms.
#' @param data data which you want to use.
#'
#' @importFrom stats complete.cases
#' @importFrom stats anova
#' @importFrom stats lm
#'
#'
ftest <- function(x, arms, arms_label, data) {
  # data shape
  usedt <- data[, c(x, arms)]
  usedt <- usedt[complete.cases(usedt), ]

  # calculate mean value in each arm
  mu <- lapply(arms_label, function(t) {
    mean(usedt[usedt[[arms]] == t, ][[x]])
  })

  # implement F-test
  f <- anova(lm(paste0(x, "~", arms), usedt))[["Pr(>F)"]][1]

  # output
  data.frame(
    x = x,
    item = c(arms_label, "P-value (F-test)"),
    val = c(unlist(mu), f)
  )
}

#' T-Test for RCTs with Multiple Experimental Arms
#'
#' @param y a string of outcome.
#' @param arms a string of treatment variables.
#' @param arms_label a string vector of label of treatments.
#' @param ctrl a string of the control.
#' @param data data object you want to use.
#'
#' @importFrom stats t.test
#' @importFrom broom tidy
#' @importFrom dplyr bind_rows
#'
ttest <- function(y, arms, arms_label, ctrl, data) {
  # using data
  usedt <- data[, c(y, arms)]
  usedt <- usedt[complete.cases(usedt), ]

  # vector of outcome variables
  y0 <- usedt[usedt[[arms]] == ctrl, ][[y]]
  y1 <- lapply(arms_label, function(x) usedt[usedt[[arms]] == x, ][[y]])

  # t-test
  t <- lapply(y1, t.test, y = y0)
  t <- lapply(t, broom::tidy)

  # standard errors of mean
  stderr <- lapply(y1, se, na.rm = TRUE)

  # data.frame containing result
  out <- dplyr::bind_rows(t)
  out <- out[, c("estimate", "estimate1", "p.value")]
  colnames(out) <- c("effect", "mean", "p.value")
  out$se <- unlist(stderr)
  out$outcome <- y
  out$treat <- arms_label
  out <- out[, c("outcome", "treat", "mean", "se", "effect", "p.value")]

  # output
  out
}


a=rnorm(300 , mean=0 , sd=4)
b=rnorm(300 , mean=0 , sd=4)
c=rnorm(300 , mean=8 , sd=8)
par(bg="black")
par(mar=c(0,0,0,0))
plot(a ,b , cex=abs(c) , col=rgb(0.5,0.2,1,0.25) , pch=20 ,
     bty="n" , xaxt="n" , yaxt="n" , xlab="" ,
     ylab="" , xlim=c(-3,10) , ylim=c(-3,10))
#legend("bottomright", legend = expression(italic("Made with R by Holtz Yan")),)
dev.off()


library(libexpm)

n <- 100
x <- matrix(rnorm(n*n), n, n)

matpow <- function(x, pow)
{
  ret <- x
  if (pow == 1) return(ret)

  for (i in 2:pow)
  {
    ret <- ret %*% x
  }

  ret
}

pow <- 2

t1 <- system.time(test1 <- normest(x, pow))[3]
t2 <- system.time(test2 <- norm(matpow(x, pow), type="O"))[3]

t1
t2

test1
test2


### R script to demonstrate RFF version of time delay GP model

## Define imagined data generating process and draw a mock dataset

Nobs_quasar_image_A <- 150
observation_times_quasar_image_A <- sort(runif(Nobs_quasar_image_A,0,10))
Nobs_quasar_image_B <- 75
observation_times_quasar_image_B <- sort(runif(Nobs_quasar_image_B,0,10))

true_time_delay <- 1
true_GP_bandwidth <- 1
true_GP_scale <- 0.5
true_expected_counts_quasar_image_A <- 40
true_expected_counts_quasar_image_B <- 30
true_expected_background_counts <- 5

true_cov_matrix <- true_GP_scale^2*exp(-true_GP_bandwidth*as.matrix(dist(sort(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)),upper = TRUE,diag = TRUE))^2)
true_cov_matrix <- true_cov_matrix+diag(Nobs_quasar_image_A+Nobs_quasar_image_B)*0.0001

library(MASS)
true_latent_curve <- exp(mvrnorm(1,rep(0,Nobs_quasar_image_A+Nobs_quasar_image_B),true_cov_matrix))
plot(true_latent_curve)

true_latent_curve_quasar_image_A <- true_latent_curve[which(sort.list(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)) %in% 1:(Nobs_quasar_image_A))]
true_latent_curve_quasar_image_B <- true_latent_curve[which(!(sort.list(c(observation_times_quasar_image_A,observation_times_quasar_image_B+true_time_delay)) %in% 1:(Nobs_quasar_image_A)))]
observed_counts_quasar_image_A <- rpois(Nobs_quasar_image_A,true_expected_background_counts+true_expected_counts_quasar_image_A*true_latent_curve_quasar_image_A)
observed_counts_quasar_image_B <- rpois(Nobs_quasar_image_B,true_expected_background_counts+true_expected_counts_quasar_image_B*true_latent_curve_quasar_image_B)

plot(observation_times_quasar_image_A,observed_counts_quasar_image_A,ylim=c(0,50))
points(observation_times_quasar_image_B,observed_counts_quasar_image_B,col="red")

## Construct Bayesian model with RFF approximation of latent Gaussian process and prepare derivatives with PyTorch

library(randtoolbox)
library(reticulate)

k_RFF <- 500 # Number of RFF bases (will use sin&cos orthogonal pairs)
omega_qmc_RFF <- t(qnorm(halton(k_RFF,1)))

torch <- import("torch")
np <- import("numpy")
Variable <-  torch$autograd$Variable

omega_qmc_RFF <- torch$from_numpy(omega_qmc_RFF)$float()
observation_times_quasar_image_A <- torch$from_numpy(np$array(observation_times_quasar_image_A))$float()
observation_times_quasar_image_B <- torch$from_numpy(np$array(observation_times_quasar_image_B))$float()

observed_counts_quasar_image_A <- torch$from_numpy(np$array(observed_counts_quasar_image_A))$float()
observed_counts_quasar_image_B <- torch$from_numpy(np$array(observed_counts_quasar_image_B))$float()

time_delay <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_GP_bandwidth <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_GP_scale <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_expected_counts_quasar_image_A <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_expected_counts_quasar_image_B <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
log_expected_background_counts <- Variable(torch$zeros(as.integer(1)),requires_grad=TRUE)$float()
RFF_slopes <- Variable(torch$ones(as.integer(2*k_RFF)),requires_grad=TRUE)$float()

optimizer <- torch$optim$Adam(list(time_delay,log_GP_bandwidth,log_GP_scale,log_expected_counts_quasar_image_A,log_expected_counts_quasar_image_B,log_expected_background_counts,RFF_slopes),lr=0.05)

for (j in 1:200) {
GP_bandwidth <- torch$exp(log_GP_bandwidth)
GP_scale <- torch$exp(log_GP_bandwidth)
expected_background_counts <- torch$exp(log_expected_background_counts)

omega_QMC_RFF_scaled <- torch$mul(omega_qmc_RFF,GP_bandwidth$unsqueeze(as.integer(1)))
RFFprojections_A <- torch$matmul(observation_times_quasar_image_A$unsqueeze(as.integer(1)),omega_QMC_RFF_scaled)
RFFprojections_B <- torch$matmul(observation_times_quasar_image_B$add(time_delay)$unsqueeze(as.integer(1)),omega_QMC_RFF_scaled)
RFFs_A <- torch$cat(c(torch$sin(RFFprojections_A),torch$cos(RFFprojections_A)),as.integer(1))
RFFs_B <- torch$cat(c(torch$sin(RFFprojections_B),torch$cos(RFFprojections_B)),as.integer(1))
latent_GP_A <- torch$matmul(RFFs_A,RFF_slopes)$mul(GP_scale$mul(1.0/k_RFF))
latent_GP_B <- torch$matmul(RFFs_B,RFF_slopes)$mul(GP_scale$mul(1.0/k_RFF))

latent_signal_A <- torch$exp(latent_GP_A$add(log_expected_counts_quasar_image_A))
latent_signal_B <- torch$exp(latent_GP_B$add(log_expected_counts_quasar_image_B))
obs_signal_A <- latent_signal_A$add(expected_background_counts)
obs_signal_B <- latent_signal_B$add(expected_background_counts)

likelihood_fn_A <- torch$distributions$Poisson(obs_signal_A)
likelihood_A <- likelihood_fn_A$log_prob(observed_counts_quasar_image_A)
likelihood_fn_B <- torch$distributions$Poisson(obs_signal_B)
likelihood_B <- likelihood_fn_B$log_prob(observed_counts_quasar_image_B)
prior_slopes_fn <- torch$distributions$Normal(0,1)
prior_slopes <- prior_slopes_fn$log_prob(RFF_slopes)
prior_time_delay_fn <- torch$distributions$Normal(0,1)
prior_time_delay <- prior_time_delay_fn$log_prob(time_delay)
prior_log_GP_bandwidth_fn <- torch$distributions$Normal(0,1)
prior_log_GP_bandwidth <- prior_log_GP_bandwidth_fn$log_prob(log_GP_bandwidth)
prior_log_GP_scale_fn <- torch$distributions$Normal(0,1)
prior_log_GP_scale <- prior_log_GP_scale_fn$log_prob(log_GP_scale)
prior_log_expected_background_counts_fn <- torch$distributions$Normal(0,1)
prior_log_expected_background_counts <- prior_log_expected_background_counts_fn$log_prob(log_expected_background_counts)

posterior_log_prob_part_i <- likelihood_A$sum()
posterior_log_prob_part_ii <- torch$add(posterior_log_prob_part_i,likelihood_B$sum())
posterior_log_prob_part_iii <- torch$add(posterior_log_prob_part_ii,prior_slopes$sum())
posterior_log_prob_part_iv <- torch$add(posterior_log_prob_part_iii,prior_time_delay)
posterior_log_prob_part_v <- torch$add(posterior_log_prob_part_iv,prior_log_GP_bandwidth)
posterior_log_prob_part_vi <- torch$add(posterior_log_prob_part_v,prior_log_expected_background_counts)
posterior_log_prob <- torch$add(posterior_log_prob_part_vi,prior_log_GP_scale)$mul(-1)

optimizer$zero_grad()
if (j==1) {posterior_log_prob$backward(retain_graph=TRUE)}
else {posterior_log_prob$backward()}
optimizer$step()
print(posterior_log_prob,"\n")

}

latent_fn_all_Aobs <- exp(c(as.numeric(latent_GP_A$detach()$numpy()),as.numeric(latent_GP_B$detach()$numpy()))+as.numeric(log_expected_counts_quasar_image_A$detach()$numpy()))+as.numeric(expected_background_counts$detach()$numpy())
relative_obs_times_to_A <- c(as.numeric(observation_times_quasar_image_A$detach()$numpy()),as.numeric(observation_times_quasar_image_B$detach()$numpy())+as.numeric(time_delay$detach()$numpy()))
latent_fn_all_Bobs <- exp(c(as.numeric(latent_GP_A$detach()$numpy()),as.numeric(latent_GP_B$detach()$numpy()))+as.numeric(log_expected_counts_quasar_image_B$detach()$numpy()))+as.numeric(expected_background_counts$detach()$numpy())

layout(1:2)
plot(observation_times_quasar_image_A$detach()$numpy(),observed_counts_quasar_image_A$detach()$numpy(),xlim=c(0,10),ylim=c(0,125),xlab='Observation Times A',ylab="Observed Counts A")
lines(sort(relative_obs_times_to_A),latent_fn_all_Aobs[sort.list(relative_obs_times_to_A)],col="red")

plot(observation_times_quasar_image_B$detach()$numpy(),observed_counts_quasar_image_B$detach()$numpy(),xlim=c(0,10),ylim=c(0,125),xlab='Observation Times B',ylab="Observed Counts B")
lines(sort(relative_obs_times_to_A)-as.numeric(time_delay$detach()$numpy()),latent_fn_all_Bobs[sort.list(relative_obs_times_to_A)],col="red")

cat("True time delay = ",true_time_delay,"\n",sep="")
cat("Estimated time delay = ",as.numeric(time_delay$detach()$numpy()),"\n",sep="")


 C02ALJ Example Program Results

  Roots of quartic equation           Error estimates
                                    (machine-dependent)

  z =   2.0000E+00 +0.0000E+00*i          1.2E-15
  z =  -2.0000E+00 +0.0000E+00*i          1.1E-15
  z =  -1.0000E+00 +3.0000E+00*i          1.1E-15
  z =  -1.0000E+00 -3.0000E+00*i          1.1E-15


#'
#'@title Add vertical error bars to current plot
#'
#'@description Adds vertical error bars to current plot.
#'
#'@param x - vector of x coordinates or matrix w/ columns 1 & 2 taken as x,y
#'@param y - vector of y coordinates (or NULL, if x is a matrix)
#'@param upper - upper CI for y
#'@param lower - lower CI for y
#'@param sigma - standard deviations for y
#'@param cv - cvs for y, instead of sigma
#'@param CI - upper confidence interval (if sigma or cv specified)
#'@param lognormal - flag (T/F). if true, assumed distribution is lognormal
#'@param width - relative width of error bars
#'@param ... - graphics parameters for segments (e.g., col, lty, lwd)
#'
#'@export
#'@import graphics
#'@import stats
#'
plotErrorBars.V<-function(x,
                          y=NULL,
                          upper=NULL,       #upper CI for y
                          lower=NULL,       #lower  CI for y
                          sigma=NULL,       #standard deviations for y
                          cv=NULL,          #cvs for y, instead of sigma
                          CI=0.8,           #upper confidence interval (if sigma or cv specified)
                          lognormal=FALSE,  #if true, assumed distribution is lognormal
                          width=1,          #relative width of error bars
                          ...               #graphics parameters for segments (e.g., col, lty, lwd)
                          ) {
#    old.par<-par(new=T);
    if (is.null(y)) {
        if (is.vector(x)) {
            yp<-x;
            xp<-1:length(x);
        } else if (is.matrix(x)) {
            yp<-x[,2];
            xp<-x[,1];
        } else {
            cat('Exiting--not implemented for this type of x. \n');
            return;
        }
    } else {
        xp = x;
        yp = y;
    }
    if (!is.null(cv)){
        sigma<-cv*yp;
    }
    if (!is.null(sigma)) {
        if (!lognormal) {
            upper<-qnorm(1-(1-CI)/2,sd=sigma);#upper confidence bounds
            lower<-qnorm((1-CI)/2,sd=sigma);  #lower confidence bounds
        } else {
            lnyp<-log(yp);
            lnsd<-sqrt(log(1+(sigma/yp)^2))
            upper<-qlnorm(1-(1-CI)/2,meanlog=lnyp,sdlog=lnsd)-yp;
            lower<-qlnorm((1-CI)/2,meanlog=lnyp,sdlog=lnsd)-yp;
        }
    }
    usr<-par("usr");
#    cat("usr = ",usr,"\n")
    ebw<-width*(usr[2]-usr[1])/((max(xp,na.rm=TRUE)-min(xp,na.rm=TRUE)));
#    cat("ebw = ",ebw,"\n");
    for (i in 1:length(xp)) {
        if (!is.null(upper)) {
            segments(xp[i],yp[i],xp[i],yp[i]+upper[i],...);
            segments(xp[i]-ebw,yp[i]+upper[i],xp[i]+ebw,yp[i]+upper[i],...);
        }
        if (!is.null(lower)) {
            segments(xp[i],yp[i],xp[i],yp[i]+lower[i],...);
            segments(xp[i]-ebw,yp[i]+lower[i],xp[i]+ebw,yp[i]+lower[i],...);
        }
    }
#    on.exit(par(old.par));
}


library(affy)
library(limma) ##– linear model for DE
library(Heatplus)## – for heat map view
library(gplots) ## - for color change in heatmap plot

data.dir = "/Users/kyclark/work/abe516/r/de/data"
cel.files = file.path(data.dir, dir(data.dir, pattern = "*.CEL"))
raw = ReadAffy(filenames = cel.files)
eset = rma(raw)

# construct a design matrix for this experiment
f = factor(c(1, 1, 2, 2, 3, 3, 4, 4),
           labels=c("brain", "f.brain", "f.liver", "liver"))
design = model.matrix(~ 0 + f)
colnames(design) = c("brain", "f.brain", "f.liver", "liver")
fit = lmFit(eset, design)
contrast.matrix = makeContrasts(f.brain-brain, f.liver - liver,
                                levels = design)
fit2 = contrasts.fit(fit, contrast.matrix)
fit2 = eBayes(fit2)

## select genes with adjusted p-value < 0.0001
p.bh = p.adjust(fit2$F.p.value, method = "BH")
select = (p.bh < 0.0001)
table(select) ## how many genes are selected for further analysis

newdata = exprs(eset)[select,]
#heatmap_2(newdata, legend = 4)
heatmap_2(newdata, legend = 4, col = greenred(20), legfrac = 10)

# Change the grouping of columns:
# create a hierarchical tree "by hand" and cut it
hc = hclust(dist(t(newdata)))
c4 = cutree(hc, k = 4)
heatmap_plus(newdata, clus = c4, addvar = design, col = greenred(20))

c2 = cutree(hc, k = 2)
heatmap_plus(newdata, addvar = design, clus = c2, col = greenred(20))

# "Scale" parameter of heatmap
# default value is “row”
# only impacts the colors of the image. # It does not affect the dendrograms.
heatmap_2(newdata, scale = "row", legend = 4, col = greenred(20)) ### we already saw it
heatmap_2(newdata, scale = "none", legend = 4, col = greenred(20))

# But scaling the data ...
# These two codes generate different dendrograms

# If you focus on the absolute distance among genes, use:
heatmap_2(newdata, scale="row", legend=4,col=greenred(20))  ### we already saw it

# If you’re interested in the expression pattern of genes across experiments, use
heatmap_2(t(scale(t(newdata))), scale="none", legend=4, col=greenred(20) )


 ZUNMHR Example Program Results

 Eigenvalues
    (-6.0004,-6.9998) (-5.0000, 2.0060) ( 7.9982,-0.9964) ( 3.0023,-3.9998)

 Contents of array C
                    1                 2
 1  ( 0.8457,-0.0000) (-0.3865, 0.1732)
 2  (-0.0177, 0.3036) (-0.3539, 0.4529)
 3  ( 0.0875, 0.3115) ( 0.6124, 0.0000)
 4  (-0.0561,-0.2906) (-0.0859,-0.3284)


# Some plottings : prices, returns and log of gross returns
# 17-03-2015
# Killian Martin--Horgassan

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

N <- 100
Xt <- rep(0,N)
Rt <- rep(0,N-1)
r_t <- rep(0,N-1)

# A brownian motion, used to model the evolution of the price
# of a stock
for (i in 1:N) {
	Xt[i] <- rnorm(1, mean = N, sd = i)
}

# The returns and log of gross returns
for (i in 1:N-1) {
	Rt[i] <- log(Xt[i+1]/Xt[i])
	r_t[i] <- (Xt[i+1]-Xt[i])/Xt[i]
}

quartz()
par(mfrow = c(1,3))
plot(Xt, xlab = 'Time step', ylab = 'Stock Price',type = 'l', col = 'black')
plot(r_t, xlab = 'Time step', ylab = 'Returns', type = 'l', col = 'red')
plot(Rt, xlab = 'Time step', ylab = 'Log of gross returns', type = 'l', col = 'blue')


# Master Thesis Project - Extreme Value Theory
# Plotting a random walk at n steps
# Killian Martin--Horgassan
# 23-04-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/randomWalk.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/Epsilon_is.r")

# Let the user enter the number of steps to the random walk
cat("How many steps to the random walk ?")
Nb <- as.numeric(readline("n :\n"))

# Get the random Walk and print it if the vector is not too large
Epsilons <- Epsilon_is(Nb)
S <- randomWalk(Nb,Epsilons)
if (Nb <= 25){
	print(S)
}

# Plot the Random Walk
quartz()

title <- paste("A random walk of ", Nb, "steps", sep = " ")
xlabel <- "Time steps i"
ylabel <- expression(S[i])

plot(S,xlab = xlabel, ylab = ylabel, main = title, type ='l')


# straightness: calculate linearity of the trajectory for each bouts = distance premier dernier point/dist totale

tr <- as.traj(id = id, xy = xy, date = da)

sp<-speed(tr)

disuc<-sp$speed*sp$dt
ditot<-tapply(disuc, sp$id, sum)

xyperan<-split(xy, id)

dd<-function(x) {
        xfirst<-x[1,]
        xend<-x[nrow(x),]
        di<-sqrt((xfirst[1]-xend[1])^2 +
            (xfirst[2]-xend[2])^2)
        return(di)
}
dilin<-unlist(lapply(xyperan, dd))


# R code
# Luis P. F. Garcia 2018
# Split the time series as flat tables and apply fft

dst <- function(data) {
  c(summary(data), kurtosis(data), skewness(data), gMean(data),
    hMean(data), IQR(data))
}

dwt <- function(data) {
  aux = wavelets::dwt(data, filter="haar")
  return(aux@W$W1)
}

dft <- function(data) {
  aux = fft(data)#/length(data)
  sapply(aux, function(i) {
    signif(Mod(i), 4)
  })
}

magnitude <- function(x, y, z) {
  sqrt(x^2 + y^2 + z^2)
}

label <- function(data) {
  names(which.max(summary(data$class)))
}

static <- function(data, size) {
  aux = seq(1, nrow(data) - size, by=size)
  lapply(aux, function(i) {
    data[i:(i + size - 1),]
  })
}

slide <- function(data, size) {
  aux = seq(1, nrow(data) - size, by=size/3)
  lapply(aux, function(i) {
    data[i:(i + size - 1),]
  })
}

window <- function(data, wtype, ftype, size) {

  aux = eval(call(wtype, data, size))
  tmp = t(sapply(aux, function(i) {
     eval(call(ftype, magnitude(i$x, i$y, i$z)))
  }))

  if(!is.null(data$class)) {
    class = sapply(aux, label)
    tmp = data.frame(tmp, class)
  }

  tmp = data.frame(tmp)
  return(tmp)
}


### This code was written by for the LMIC global report andd edited for the covid19 model

# Load Required Packages and Source Functions
library(tidyverse)
library(readxl)
library(socialmixr)
library(dfoptim)
source("utils/get-ar.r")
#----------------------------------------------------------------------------------------------------
# Loading in Population Data and Severity Parameters
demog <- readRDS("usa/data/us_states_wide.rds")
pop_columns <- 3:20
severity_inputs <- readRDS('data/severity-inputs.rds')
IFRs <- severity_inputs$IFR_adj

# Extract relevant contact matrix
#   Note: Only limited countries have contact matrices available.
contact_mat <- contact_matrix(polymod, countries = "United Kingdom",
                              age.limits = seq(0, 75, by = 5))$matrix

# Set Parameters for Optimisation
R <- 3.28
guess_hom <- 0.85 # guess homogeneous attack rate
guess_modifier <- 0.7 # guess a lower bound for extent age-specific matrix alters average attack rate
reiterates <- 3
iterates <- 10000
restarts <- 10
tol <- 1e-07
init <- 1

states <- demog$Region
IFR <- vector(length = length(states))

for (i in 1:length(states)){
  # Extract Population
  raw_state_pop <- unlist(demog[demog$Region == states[i], pop_columns])
  state_pop <- c(raw_state_pop[1:15], sum(raw_state_pop[16:18]))

  # Processing the Contact Matrix to Generate a Probability Matrix
  # (i.e. Likelihood a person in each age group mixes with people in a different age group)
  MIJ <- t(sapply(seq(state_pop),function(x){
    contact_mat[x,]*state_pop[x]
  }))
  adjust_mat<-(MIJ+t(MIJ))/2
  new_mix_mat<-t(sapply(seq(state_pop),function(x){
    adjust_mat[x,]/state_pop[x]
  }))
  c_mat<-t(sapply(seq(state_pop),function(x){
    new_mix_mat[x,]/sum(new_mix_mat[x,])
  }))

  ai <- rowSums(new_mix_mat)
  ng_eigen <- Re(eigen(new_mix_mat)$val[1])
  rmod <- R/ng_eigen*ai
  tot_pop <- sum(state_pop)

  # Running an Optimiser to Get the Number Infected by Age for Each Age Group
  x <- get_AR(R = R, rmod = rmod, c_mat = c_mat, demog = state_pop, init = init, guess_hom = guess_hom,
              guess_modifiers = guess_modifier, iterates = iterates, reiterates = reiterates,
              restarts = restarts, tol = tol)

  # Number infected and attack rate for 5 year age bands up to 75+
  number_inf_by_age <- x$par

  # Splitting up 75+ into 75-80 and 80+ to incorporate the age-specific IFRs for these two
  # groups that we have
  infs_75_80 <- number_inf_by_age[16] * raw_state_pop[16]/(sum(raw_state_pop[16:18]))
  infs_80_plus <- number_inf_by_age[16] * sum(raw_state_pop[17:18])/(sum(raw_state_pop[16:18]))
  number_inf_by_age[16] <- infs_75_80
  number_inf_by_age[17] <- infs_80_plus

  # Calculating the number of Deaths in Each Age Group
  deaths <- number_inf_by_age * IFRs
  IFR[i] <- sum(deaths)/sum(number_inf_by_age)
}

ifrs <- data.frame("state" = states, "IFR" = IFR)


results <- c()
stdErr <- c()
sumHisto <- c()
approxMeanAmplitude = 0
numberOfSamples = length(data) - 11
for (i in 11:length(data)) {
  historyData <- data[1:i]
  sumHisto <- c(sumHisto, sum(historyData))
  fitDn <- tryCatch({nlsLM(historyData~a*pnorm(1:i, mean = m, sd = sd), start=list(m=10,sd=2,a=100))},
                    error = function(e) {print(e)})
  aCur = as.list(coef(fitDn))$a
  aCurStdErr = summary(fitDn)$coefficients[3,2]
  print(aCur)
  stdErr <- c(stdErr, aCurStdErr)
  results <- c(results, aCur)
}

plot(results, type = 'l')
points(stdErr)
amplitudeMean <- weighted.mean(results, sumHisto * results / stdErr)
print('weightedAmplitudeMean')
print(amplitudeMean)

invStdErrNorm <- normalize.vector(1/stdErr)

print('Var Std Err. Amplitude Weighted')
#varStdErrAmplitude <- var(abs(results - amplitudeMean)*(sum(stdErr)/(stdErr*mean(stdErr))))
varStdErrAmplitude <- var(abs(results - amplitudeMean)*invStdErrNorm/length(stdErr))
print(varStdErrAmplitude)

abline(amplitudeMean, 0)


# Library
library(dlyr)
library(readr)
library(ggplot2)

prog_book <- read.csv("https://raw.githubusercontent.com/safesit23/INT214-Statistics/main/datasets/prog_book.csv")

glimpse(prog_book)

prog_book %>%
  filter(Type == "Hardcover" & Rating >= 4) %>%
  select(-Description,-Number_Of_Pages) %>%
  glimpse()

prog_book %>%
  filter(Type == "Hardcover" & Rating >= 4) %>%
  select(Book_title,Rating) %>%
  arrange(desc(Rating))

## 3.1 Displays the top 10 books of the books with the highest rating.
prog_book %>%
  select(Rating,Book_title) %>%
  arrange(desc(Rating)) %>%
  top_n(10)

## 3.2 Displays the price of books with the highest and lowest ratings.
prog_book %>%
  filter(Rating == max(prog_book$Rating)| Rating == min(prog_book$Rating)) %>%
  select(Rating,Book_title,Price)

## 3.3 Display How many types of books are there? And how many books are there in each type
prog_book %>% count(Type)

## 3.4 Displays titles and descriptions of books that are type as Boxed Set - Hardcover.
prog_book %>%
  filter(Type == "Boxed Set - Hardcover") %>%
  select(Book_title, Description) %>% glimpse()

##3.5 Displays the cheapest and most expensive prices of Paperback books.
prog_book %>%
  filter(Type == "Paperback") %>%
  summarise(most_expensive = max(Price),most_cheapest = min(Price))

##3.6 Displays books type Kindle Edition  that are rating above average by descending order
prog_book %>% summarise(mean(Rating))

prog_book %>% select(Book_title,Rating,Type) %>%
  filter(Rating > mean(Rating) & Type == "Kindle Edition") %>%
  arrange(desc(Rating))

## Graph 1
prog_book %>%
  filter(Rating > mean(Rating))%>%
  ggplot(aes(x=Rating,y=Price))+geom_point(aes(color= Type ))+geom_smooth()

## Graph 2
prog_book %>%
  ggplot(aes(x=Type)) +
  geom_bar(colour = 5, fill = "white") +
  ggtitle("Books each Type") +
  xlab("type of books") + ylab("quantity of books")


library("latticeExtra")
library("Hmisc")
library("data.table")
library("foreign")

#setwd("X:/Palloni_Datasets/BOOKLA-DATA-2013/Latin America Mortality Database/Life Tables 85+")
setwd("C:/Users/Hiram/Box Sync/Beltran-Sanchez/Uncertainty in LAMBdA estimates")
#dat<-data.frame(read.dta("E0_LA1850-2010_wei_long.dta",convert.factors=F))
#tmp<-read.dta("E0_LA1850-2010_wei_long.dta",convert.factors=T)
#dat<-data.frame(dat,author.lab=tmp$author,ctry.lab=tmp$ctry,sex.lab=tmp$sex)
#rm(tmp)
#datos<-dat
#save(datos,file="Ex_0_5_60_and_prob.RData")
load("Ex_0_5_60_and_prob.RData")

bst<-function(sample.size,datos){
  out<-NULL
  yrs<-sort(unique(datos$myear))
  for(yr in 1:length(yrs)){#yr=1;sample.size=500
   cat("Country:",datos$ctry[1],", Year:",yrs[yr],"\n")
   foo<-subset(datos,myear==yrs[yr])
   if(dim(foo)[1]>1){
   tmp<-sample(foo$Ex,sample.size,replace=T,prob=foo$wei)
   ot<-c(median(tmp),quantile(tmp,probs=c(0.25,0.75)),yrs[yr])
   }
   if(dim(foo)[1]==1) {ot<-c(foo$Ex,NA,NA,yrs[yr])}
   out<-rbind(out,ot);rownames(out)<-NULL
   }
   data.frame(ctry=datos$ctry[1],myear=out[,4],Ex=out[,1],Q25=out[,2],Q75=out[,3])
}

set.seed(87654321)
ages<-c(0,5,60)
sample<-1000
ctry.list<-unique(dat$ctry)
boots.ex<-NULL
for(ct in 1:length(ctry.list)){#ct=1
  out<-data.frame(bst(sample.size=sample,dat=subset(dat,ctry==ctry.list[ct] & sex==1 & age==ages[1])),sex=1,age=ages[1])
  out<-rbind(out,data.frame(bst(sample.size=sample,dat=subset(dat,ctry==ctry.list[ct] & sex==2 & age==ages[1])),sex=2,age=ages[1]))
  out<-rbind(out,data.frame(bst(sample.size=sample,dat=subset(dat,ctry==ctry.list[ct] & sex==1 & age==ages[2])),sex=1,age=ages[2]))
  out<-rbind(out,data.frame(bst(sample.size=sample,dat=subset(dat,ctry==ctry.list[ct] & sex==2 & age==ages[2])),sex=2,age=ages[2]))
  out<-rbind(out,data.frame(bst(sample.size=sample,dat=subset(dat,ctry==ctry.list[ct] & sex==1 & age==ages[3])),sex=1,age=ages[3]))
  out<-rbind(out,data.frame(bst(sample.size=sample,dat=subset(dat,ctry==ctry.list[ct] & sex==2 & age==ages[3])),sex=2,age=ages[3]))
  boots.ex<-rbind(boots.ex,out)
}
boots.ex$ctry.lab<-boots.ex$ctry
boots.ex$ctry.lab<-factor(boots.ex$ctry.lab,levels=sort(unique(dat$ctry)),labels=levels(dat$ctry.lab))
boots.ex$sex<-factor(boots.ex$sex,levels=1:2,labels=c("Male","Female"))

theme.novpadding <-list(layout.heights =list(top.padding=0, main.key.padding=0, key.axis.padding=0, axis.xlab.padding=0,
                                             xlab.key.padding=0, key.sub.padding=0, bottom.padding=0.2),
                        layout.widths = list(left.padding=0.1, key.ylab.padding=0, ylab.axis.padding=0,
                                             axis.key.padding=0,  right.padding=0))

#setwd("X:/Hiram/Book Mortality in LAC")
#pdf("Brazil_Boostrap_e0_e5_e60_by_sex.pdf",width=11.5,height=6,pointsize=7)
xYplot(Cbind(Ex,Q25,Q75)~myear | paste("Age ",age,sep=''),data=subset(boots.ex,ctry.lab=="Brazil"),
       groups=sex,ylim=c(0,80),
       col=c("blue","red"),lty=1,lwd=2,par.strip.text=list(cex=1.2,lines=1.3,font=2),pch=c(20),
       par.settings=theme.novpadding,between=list(x=0.2,y=0.2),#key=key.leg,
       xlab=list("Year",font=2),ylab=list("Life expectancy with inter-quartile range",font=2),
       scales=list(alternating=1,y=list(alternating=3,font=2,cex=1),
                  x=list(alternating=3,rot=90,at=seq(1800,2010,20),labels=as.character(seq(1800,2010,20)),font=2,cex=1)),
       panel=function(x,y,...){
         panel.abline(h=seq(10,90,10),col="black",lty=2)
         panel.abline(v=seq(1840,2010,10),col="black",lty=2)
         #panel.abline(v=seq(1850,2010,50),col="grey",lty=1)
         panel.xYplot(x,y,...)
       })
#dev.off()

#setwd("Z:/Brasil")
#pdf("presentation/Boostrap_e0-e5-e60_by_sex-country.pdf",width=8.5,height=6,pointsize=7)
ylimit<-list(c(18,83),c(30,78),c(0,25))
for(ag in 1:length(ages)){#ag=2
 fig1<-xYplot(Cbind(Ex,Q25,Q75)~myear | ctry.lab,data=subset(boots.ex,sex=="Male" & age==ages[ag]),ylim=ylimit[[ag]],
       col=c("blue"),lty=1,lwd=1,par.strip.text=list(cex=0.9,lines=1.3,font=2),pch=c(20),layout=c(4,5),
       par.settings=theme.novpadding,between=list(x=0.2,y=0.2),#key=key.leg,
       xlab="Periodo",ylab=list(paste("e(",ages[ag],") con rango inter-cuartil",sep=''),font=2),
       scales=list(alternating=1,y=list(alternating=3),x=list(alternating=3)),
       #main=c(paste("Males: e(",ages[ag],") estimate drawing a sample of ",sample," with replacement by year-country",sep='')),
       main=c("Hombres"),
       panel=function(x,y,...){
         panel.abline(h=seq(10,90,10),col="black",lty=3)
         panel.abline(v=seq(1840,2010,10),col="black",lty=3)
         panel.abline(v=seq(1850,2010,50),col="grey",lty=1)
         panel.xYplot(x,y,...)
       })
 fig2<-xYplot(Cbind(Ex,Q25,Q75)~myear | ctry.lab,data=subset(boots.ex,sex=="Female" & age==ages[ag]),ylim=ylimit[[ag]],
       col=c("blue"),lty=1,lwd=1,par.strip.text=list(cex=0.9,lines=1.3,font=2),pch=c(20),layout=c(4,5),
       par.settings=theme.novpadding,between=list(x=0.2,y=0.2),#key=key.leg,
       xlab="Periodo",ylab=list(paste("e(",ages[ag],") con rango inter-cuartil",sep=''),font=2),
       scales=list(alternating=1,y=list(alternating=3),x=list(alternating=3)),
       #main=c(paste("Females: e(",ages[ag],") estimate drawing a sample of ",sample," with replacement by year-country",sep='')),
       main=c("Mujeres"),
       panel=function(x,y,...){
         panel.abline(h=seq(10,90,10),col="black",lty=3)
         panel.abline(v=seq(1840,2010,10),col="black",lty=3)
         panel.abline(v=seq(1850,2010,50),col="grey",lty=1)
         panel.xYplot(x,y,...)
       })
 print(fig1)
 print(fig2)
}
#dev.off()


# create an LD decay plot from ngsLD output

require(data.table)
require(RColorBrewer)

######################
# calculate LD decay
######################

# read in data (gatk loci only)
datCan40 <- fread('analysis/ld.Can_40.gatk.gz')
datCan14 <- fread('analysis/ld.Can_14.gatk.gz')
dat07 <- fread('analysis/ld.Lof_07.gatk.gz')
dat11 <- fread('analysis/ld.Lof_11.gatk.gz')
dat14 <- fread('analysis/ld.Lof_14.gatk.gz')

# add column names
nms <- c('pos1', 'pos2', 'dist', 'r2', 'D', 'Dprime', 'r2em')
setnames(datCan14, nms)
setnames(datCan40, nms)
setnames(dat14, nms)
setnames(dat11, nms)
setnames(dat07, nms)

# calculate averages within bins (like Bario et al. 2016 eLife)
stp1 <- 5 # step size for small distances
thresh <- 50 # use stp2 above this distance
stp2 <- 500

dat14[, distclass := floor(dist/stp1)*stp1 + stp1/2] # calculate a distance class
dat14[dist > thresh, distclass := floor(dist/stp2)*stp2 + stp2/2] # calculate a distance class for distances above thresh
dat11[,distclass:=floor(dist/stp1)*stp1+stp1/2]
dat11[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2]
dat07[,distclass:=floor(dist/stp1)*stp1+stp1/2]
dat07[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2]
datCan40[,distclass:=floor(dist/stp1)*stp1+stp1/2]
datCan40[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2]
datCan14[,distclass:=floor(dist/stp1)*stp1+stp1/2]
datCan14[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2]

bins14 <- dat14[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass] # average within distance classes
bins11 <- dat11[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]
bins07 <- dat07[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]
binsCan40 <- datCan40[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]
binsCan14 <- datCan14[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]

bins14[,r2se:=r2sd/r2n]
bins11[,r2se:=r2sd/r2n]
bins07[,r2se:=r2sd/r2n]
binsCan40[,r2se:=r2sd/r2n]
binsCan14[,r2se:=r2sd/r2n]

setkey(bins14, distclass)
setkey(bins11, distclass)
setkey(bins07, distclass)
setkey(binsCan40, distclass)
setkey(binsCan14, distclass)

# label by population
bins14[,pop:='LOF_S_14']
bins11[,pop:='LOF_S_11']
bins07[,pop:='LOF_07']
binsCan40[,pop:='CAN40']
binsCan14[,pop:='CAN14']

# merge
bins <- rbind(bins07, bins11, bins14, binsCan40, binsCan14)

# write out
write.csv(bins, file='analysis/ld_decay_ngsLD.gatk.csv')

###############
# plot
###############
bins <- fread('analysis/ld_decay_ngsLD.gatk.csv')
cols <- brewer.pal(5, 'Set1')
cex=0.5

# plot binned data
quartz(width=3, height=3)
# pdf(width=3, height=3, file='figures/ld_decay_ngsLD.pdf')
par(mai=c(0.5, 0.5, 0.3, 0.05), cex.axis=0.7, las=1, mgp=c(1.5, 0.3, 0), tcl=-0.15)
bins[pop=='LOF_07',plot(distclass, r2ave, ylim=c(0,0.7), type='o', xlab='Distance (bp)', ylab='Average correlation (r2)', cex=cex, main='LD decay', log='x', col=cols[1])]
bins[pop=='LOF_S_11',lines(distclass, r2ave, type='o', cex=cex, col=cols[2])]
bins[pop=='LOF_S_14',lines(distclass, r2ave, type='o', cex=cex, col=cols[3])]
bins[pop=='CAN40',lines(distclass, r2ave, type='o', cex=cex, col=cols[4])]
bins[pop=='CAN14',lines(distclass, r2ave, type='o', cex=cex, col=cols[5])]

bins[pop=='LOF_07',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[1]), by=distclass] # 95% CI. too small to be visible
bins[pop=='LOF_S_11',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[2]), by=distclass]
bins[pop=='LOF_S_14',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[3]), by=distclass]
bins[pop=='CAN40',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[4]), by=distclass]
bins[pop=='CAN14',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[5]), by=distclass]

legend('topright', legend=c('LOF_07', 'LOF_S_11', 'LOF_S_14', 'CAN40', 'CAN14'), col=cols, pch=1, lty=1, bty='n', cex=0.6)

dev.off()


library(ggplot2)
library(reshape2)
library(RColorBrewer)
library(gridExtra)

printvar <- function(v) {
  	name <- deparse(substitute(v))
  	print(paste(name, ":", v))
}

dir <- paste(getwd(), "../../../../Thesis_data","sirs-varimages", sep = "/")
filelist <- list.files(dir)

source("stanbootmean.r")

nTrials <- length(filelist)
first <- TRUE
fctr <- 0

for (filenum in 1:length(filelist)) {

	filename <- filelist[filenum]
	filepath <- paste(dir, filename, sep = "/")

	if (filename != "thread-0.RData" & filename != "varimages.old") {

		fctr <- fctr + 1
		print(paste(fctr, filename))

		e <- new.env()
		load(filepath, e)

		## get sizing info from first file
		if (first) {

			stepsAhead 	<- get("stepsAhead", e)
			T 		   	<- get("T", e)
			Tlim 	   	<- get("Tlim", e)
			nTraj 	   	<- get("nTraj", e)
			datlen 	   	<- get("datlen", e)
			steps 		<- get("steps", e)

			truetraj <- matrix(NA, nrow = nTrials, ncol = stepsAhead)
			if2traj <- matrix(NA, nrow = nTrials, ncol = stepsAhead)
			hmctraj <- matrix(NA, nrow = nTrials, ncol = stepsAhead)
			smaptraj <- matrix(NA, nrow = nTrials, ncol = stepsAhead)

			hmctraj2 <- matrix(NA, nrow = nTrials, ncol = stepsAhead)

			if2times 	<- numeric(nTrials)
			hmctimes 	<- numeric(nTrials)
			smaptimes 	<- numeric(nTrials)

			if2covdata <- data.frame(matrix(NA, nTrials, 6))
			names(if2covdata) <- c("mean10", "lower10", "upper10", "mean45", "lower45", "upper45")
			hmccovdata <- data.frame(matrix(NA, nTrials, 6))
			names(hmccovdata) <- c("mean10", "lower10", "upper10", "mean45", "lower45", "upper45")

			first <- FALSE

		}

		## True trajectory
		trueproj <- get("sdeout_true", e)[(Tlim+2):(T+1),'I']
		truetraj[fctr,] <- trueproj

		## IF2
		parabootdata <- get("if2_paraboot_data", e)[,paste("counts", 2:(T-Tlim+1), sep = "")]
		parabootdata <- parabootdata[complete.cases(parabootdata),]
		if2proj <- apply(parabootdata, 2, mean)
		if2traj[fctr,] <- if2proj
		if2times[fctr] <- get("if2time", e)[['user.self']]
		# coverage
		# try 90%
		real10 	 <- trueproj[10]
		real45 	 <- trueproj[45]
		quants10 <- quantile(parabootdata[,10], probs = c(0.05, 0.95), na.rm = TRUE)
		quants45 <- quantile(parabootdata[,45], probs = c(0.05, 0.95), na.rm = TRUE)
		mean10   <- if2proj[10] - real10
		diff10 	 <- quants10 - real10
		mean45 	 <- if2proj[45] - real45
		diff45 	 <- quants45 - real45
		if2covdata[fctr,] <- c(mean10, diff10, mean45, diff45)

		## HMCMC
		hmcbootdata <- get("bootstrapdata", e)[,(Tlim+2):(T+1)]
		hmcproj <- apply(hmcbootdata, 2, mean)
		hmctraj[fctr,] <- hmcproj
		hmctimes[fctr] <- get("hmctime", e)[['user.self']]
		# test
		#stanfit <- get("fit", e)
		#hmcbootdata2 <- stanbootmean(stanfit, nTraj, 500.0, Tlim, steps)[,(Tlim+2):(T+1)]
		#hmcproj2 <- apply(hmcbootdata2, 2, mean)
		#hmctraj2[fctr,] <- hmcproj2
		real10 	 <- trueproj[10]
		real45 	 <- trueproj[45]
		quants10 <- quantile(hmcbootdata[,10], probs = c(0.05, 0.95), na.rm = TRUE)
		quants45 <- quantile(hmcbootdata[,45], probs = c(0.05, 0.95), na.rm = TRUE)
		mean10   <- hmcproj[10] - real10
		diff10 	 <- quants10 - real10
		mean45 	 <- hmcproj[45] - real45
		diff45 	 <- quants45 - real45
		hmccovdata[fctr,] <- c(mean10, diff10, mean45, diff45)

		## S-map
		smapproj <- get("predictions", e)
		smaptraj[fctr,] <- smapproj
		smaptimes[fctr] <- get("smaptime", e)[['user.self']]

	}
}

## trim
if2traj   <- if2traj[1:fctr,]
hmctraj   <- hmctraj[1:fctr,]
smaptraj  <- smaptraj[1:fctr,]
truetraj  <- truetraj[1:fctr,]
if2times  <- if2times[1:fctr]
hmctimes  <- hmctimes[1:fctr]
smaptimes <- smaptimes[1:fctr]

#temp
#hmctraj2  <- hmctraj2[1:fctr,]

## average times
if2meantime <- mean(if2times)
hmcmeantime <- mean(hmctimes)
smapmeantime <- mean(smaptimes)

printvar( if2meantime )
printvar( hmcmeantime )
printvar( smapmeantime )

if2sse <- colMeans((abs(if2traj - truetraj)^2))
hmcinds <- complete.cases(hmctraj)
hmcsse <- colMeans((abs(hmctraj[hmcinds,] - truetraj[hmcinds,])^2))
smapsse <- colMeans((abs(smaptraj - truetraj)^2))

#temp
#hmcinds2 <- complete.cases(hmctraj2)
#hmcsse2 <- colMeans((abs(hmctraj2[hmcinds2,] - truetraj[hmcinds2,])^2))

if2sseraw 	<- (abs(if2traj - truetraj)^2)
if2quant  	<- t(apply(if2sseraw, 2, quantile, probs = c(0.025,0.975)))
hmcsseraw 	<- (abs(hmctraj[hmcinds,] - truetraj[hmcinds,])^2)
hmcquant  	<- t(apply(hmcsseraw, 2, quantile, probs = c(0.025,0.975)))
smapsseraw 	<- (abs(smaptraj - truetraj)^2)
smapquant 	<- t(apply(smapsseraw, 2, quantile, probs = c(0.025,0.975)))

quantdf <- data.frame(time = 1:dim(if2quant)[1], if2 = log(if2quant), hmc = log(hmcquant), smap = log(smapquant))
#quantdf[quantdf < 0] <- 0
quantplot <- ggplot(quantdf, aes(x = time)) +
				geom_ribbon(aes(ymin = quantdf[,"if2.2.5."], ymax = quantdf[,"if2.97.5."]), alpha = 0.01) +
				geom_ribbon(aes(ymin = quantdf[,"hmc.2.5."], ymax = quantdf[,"hmc.97.5."]), alpha = 0.02) +
				geom_ribbon(aes(ymin = quantdf[,"smap.2.5."], ymax = quantdf[,"smap.97.5."]), alpha = 0.03) +
				theme_bw()

## SSE plot
##########################################################################################

df <- data.frame(time = 1:(T-Tlim), if2 = log10(if2sse), hmc = log10(hmcsse), smap = log10(smapsse))
plotdata <- melt(df, id = "time")

q <- qplot(data = plotdata, x = time, y = value, geom = "line", color = variable, xlab = "Weeks ahead", ylab = expression(SSE~(log[10]))) +
		scale_color_grey(labels = c("IF2","HMCMC","S-map")) +
		theme_bw() +
		theme(legend.title=element_blank())

ggsave(q, filename = "sseplot.pdf", width = 6.5, height = 4)

#df2 <- data.frame(time = 1:(T-Tlim), if2 = log(if2sse), hmc = log(hmcsse2), smap = log(smapsse))
#plotdata2 <- melt(df2, id = "time")

#q2 <- qplot(data = plotdata2, x = time, y = value, geom = "line", color = variable, xlab = "Weeks ahead", ylab = "Average error (log)") +
#		scale_color_grey(labels = c("IF2","HMCMC","S-map")) +
#		theme_bw() +
#		theme(legend.title=element_blank())

# ggsave(q2, filename = "sseplot2.pdf", width = 6.5, height = 4)

# times plot

timedf <- data.frame(if2 = if2times, hmc = hmctimes, smap = smaptimes)
timedata <- melt(timedf)
timeplot <- ggplot(timedata, aes(factor(variable, ordered = TRUE), value)) +
				geom_boxplot() +
				scale_x_discrete(labels = c("IF2", "HMCMC", "S-map")  ) +
				labs(x = "", y = "Time (seconds)") +
				coord_flip() +
				theme_bw()

ggsave(timeplot, filename = "timeplot.pdf", width = 6.5, height = 4)

#save.image("fsim.RData")

## Let's try this coverage plot thing
##########################################################################################

inds <- complete.cases(hmccovdata)
nCovSets <- sum(inds)

if2pdraw <- if2covdata[inds,][1:nCovSets,]
hmcpdraw <- hmccovdata[inds,][1:nCovSets,]

## 10 weeks ahead
##

pd10if2 <- data.frame(setnum = 1:nCovSets, method = rep("if2",nCovSets), if2pdraw[order(if2pdraw[,"mean10"]),])
pd10hmc <- data.frame(setnum = 1:nCovSets, method = rep("hmc",nCovSets), hmcpdraw[order(if2pdraw[,"mean10"]),])
cnames <- names(pd10if2)
pd10if2melted <- melt(pd10if2, id = cnames)
pd10hmcmelted <- melt(pd10hmc, id = cnames)
pd10 <- rbind(pd10if2melted, pd10hmcmelted)

pd <- position_dodge(0.5)
cov10plot <- ggplot(pd10, aes(x = setnum, color = method)) +
					geom_hline(aes(yintercept = 0)) +
					geom_errorbar(aes(ymin = lower10, ymax = upper10), width = 0, position = pd) +
					geom_point(aes(y = mean10), position = pd) +
					labs(x = "", y = "Estimate - True") +
					theme_bw() +
					scale_color_grey() +
					theme(axis.ticks.x=element_blank(),
					      axis.text.x=element_blank(),
					      legend.position='none')

## 45 weeks ahead
##

pd45if2 <- data.frame(setnum = 1:nCovSets, method = rep("if2",nCovSets), if2pdraw[order(if2pdraw[,"mean45"]),])
pd45hmc <- data.frame(setnum = 1:nCovSets, method = rep("hmc",nCovSets), hmcpdraw[order(if2pdraw[,"mean45"]),])
cnames <- names(pd45if2)
pd45if2melted <- melt(pd45if2, id = cnames)
pd45hmcmelted <- melt(pd45hmc, id = cnames)
pd45 <- rbind(pd45if2melted, pd45hmcmelted)

pd <- position_dodge(0.5)
cov45plot <- ggplot(pd45, aes(x = setnum, color = method)) +
					geom_hline(aes(yintercept = 0)) +
					geom_errorbar(aes(ymin = lower45, ymax = upper45), width = 0, position = pd) +
					geom_point(aes(y = mean45), position = pd) +
					labs(x = "Data set", y = "Estimate - True") +
					theme_bw() +
					scale_color_grey() +
					theme(axis.ticks.x=element_blank(),
					      axis.text.x=element_blank(),
					      legend.position='none')

## save combined plot
##
pdf("coverage.pdf", width = 6.5, height = 4)
grid.arrange(cov10plot, cov45plot, ncol = 1, nrow = 2)
dev.off()


## Eduwin Pakpahan <epakpahan@gmail.com>

require(rms)
require(haven)

d <- read_dta("pakpahan.dta")

fit <- cph(Surv(data_dftime, data_demfu) ~ data_age, ties="breslow", data=d,
           surv=TRUE, x=T, y=T, time.inc=1200)
fit

cal <- calibrate(fit, u=1200, B=120)
plot(cal, subtitles=FALSE)

cal_KM <- calibrate(fit, cmethod='KM', u=1200, m=10, B=40)

plot(cal_KM, add=TRUE)


custom_density_function <-
function(age) {
  res <- density(age)
  return (data.frame(x=res$x, y=res$y))
}

set.seed(1234);
custom_density_function(rnorm(100)^2)


require(ggplot2) # for plotting
require(ggpubr) # for violin plots
require(gridExtra) # for combining plots
require(RColorBrewer) # to define color scales
require(ggrepel) # for plot labeling

# Plot full aragonite dataset with regressions ------------------------------------------------------------

# Build custom color scales for full dataset plot
colorscale <- unlist(brewer.pal(length(unique(dat$Analysis)), "Set1"))
names(colorscale) <- unique(dat$Analysis[order(dat$Temp)])

uniquesamples <- data.frame(samplename = unique(violin_data$sample),
    Analysis = sapply(strsplit(unique(violin_data$sample), split = "_"), "[", 2)
) # Link sample to Analysis
fillscale <- colorscale[match(uniquesamples$Analysis, names(colorscale))]
names(fillscale) <- uniquesamples$samplename

Aragonite_D47_plot <- ggplot(data = dat, aes(10^6 / (Temp + 273.15) ^ 2 , D47)) +
# Regressions
    geom_ribbon(data = D47m_poly_MC_result,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "lightblue",
        alpha = 0.3) +
    geom_line(data = D47m_poly_MC_result,
        aes(x = x, y = fit),
        color = "lightblue",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_ribbon(data = D47m_York_result,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "orange",
        alpha = 0.3) +
    geom_line(data = D47m_York_result,
        aes(x = x, y = fit),
        color = "orange",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_ribbon(data = D47m_lowT_York_result,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "blue",
        alpha = 0.3) +
    geom_line(data = D47m_lowT_York_result,
        aes(x = x, y = fit),
        color = "blue",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = Anderson21,
        aes(x = Temp, y = D47),
        color = "black",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = MeinickeICDES[1:1001, ],
        aes(x = Temp, y = D47),
        color = "black",
        linetype = "dotted",
        cex = 1,
        alpha = 1) +
#    geom_line(data = Guo09,
#        aes(x = Temp, y = D47_cc),
#        color = "blue",
#        linetype = "dashed",
#        cex = 1,
#        alpha = 0.5) +
#    geom_line(data = Guo09,
#        aes(x = Temp, y = D47_ar),
#        color = "darkgreen",
#        linetype = "dashed",
#        cex = 1,
#        alpha = 0.5) +
# Violin plots
    geom_violin(data = violin_data[which(!violin_data$outlier), ],
        aes(10^6 / (Temp + 273.15) ^ 2,
            y = D47,
            fill = sample),
            kernel = "rectangular",
            scale = "width",
            position = "identity",
            width = .1,
            cex = 0,
            alpha = 0.2,
            color = NA,
            trim = FALSE,
            show.legend = FALSE) +
# Aliquot datapoints
    geom_point(data = dat[which(!dat$D47_outlier), ],
        alpha = 0.2,
        cex = 1,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47,
            color = Analysis,
            shape = type
        )) +
#    geom_pointrange(data = dat[which(dat$D47_outlier), ],
#        alpha = 0.2,
#        cex = 0.5,
#        aes(x = 10^6 / (Temp + 273.15) ^ 2,
#            y = D47,
#            ymin = D47 - 2 * D47_SD,
#            ymax = D47 + 2 * D47_SD,
#            color = "outliers",
#            shape = type)) +
# Aggregated sample data
    geom_pointrange(data = D47stats,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47_mean,
            ymin = D47_mean - CL95,
            ymax = D47_mean + CL95,
            color = Analysis,
            shape = type),
        cex = 1,
        alpha = 1) +
    geom_errorbarh(data = D47stats,
        aes(xmin = 10^6 / ((Temp + 2 * Temp_SD) + 273.15) ^ 2,
        xmax = 10^6 / ((Temp - 2 * Temp_SD) + 273.15) ^ 2,
        y = D47_mean,
        color = Analysis),
        cex = 1,
        alpha = 1) +
# Plot layout
    ylim(0, max(D47stats$D47_mean + D47stats$CL95)) +
    scale_x_continuous(10 ^ 6 / T ^ 2 ~ "(K)",
        breaks = seq(0, 13.5, 1),
        minor_breaks = seq(0, 13.5, 0.25),
        sec.axis = sec_axis(~ sqrt(1e6 / .) - 273.15,
            "Temperature (°C)",
            breaks = temp_breaks,
            labels = temp_labs)) +
    ggtitle(expression("Arctica islandica "~Delta[47]~" vs Temperature")) +
    labs(x = 10 ^ 6 / T ^ 2 ~ "(K)",
        y = Delta * Delta[47] ~ "(\u2030"~"I-CDES)",
        colour = "Legend") +
    scale_colour_manual(values = colorscale) +
    scale_fill_manual(values = fillscale) +
    scale_shape_manual(values = c(15:20)) +
    theme_bw()

# Add zoom in for low temperatures----------------------------------------------
Aragonite_D47_plot_lowT <- Aragonite_D47_plot +
    ylim(0.3, 0.8) +
    scale_x_continuous(10 ^ 6 / T ^ 2 ~ "(K)",
        breaks = seq(0, 13.5, 0.5),
        minor_breaks = seq(0, 13.5, 0.25),
        sec.axis = sec_axis(~ sqrt(1e6 / .) - 273.15,
            "Temperature (°C)",
            breaks = temp_breaks,
            labels = temp_labs_lowT),
        limits = c(7, 13.5)) +
    ggtitle(expression("Arctica islandica "~Delta[47]~" vs Temperature")) +
    theme(legend.position = "none")

combined_plots_Aragonite <- grid.arrange(Aragonite_D47_plot + theme(legend.position = "none"),
    Aragonite_D47_plot_lowT,
    ncol = 1)


############################################################################
# Preamble
############################################################################

### set working directory
# This will set your working rirectory to the place where the scipt is. Note: Only relevant for
# r-script files ()endlng with .r). R-Notebooks ()ending with .rmd) by default take
setwd("folder1/foler2/final_folder") # Change that. Copy&Past your directory path, for example ""

### Cleaning the workspace, meaning deleting all previously loaded data (optimal step)
rm(list=ls())

### Loading packages
library(tidyverse) # loads the whole tidyverse, including dplyr, readr, ggplot, etc
library(data.table) # loads the data.table package, in case you use the fread()
library(caret) # for classification and regression
library(skimr) # for nice summary descriptives

set.seed(1337)

############################################################################
# Load data
############################################################################

### Loading the data (we will now load the Data directly from the web)
# If you want you can still use the usual way, downloading the data first manually
cities_url = 'https://github.com/SDS-AAU/M1-2018/raw/master/assignments/assignment_2/cities_predict.csv'

data <- fread(cities_url, data.table = F) %>% as_data_frame()
rm(cities_url)

############################################################################
# data inspection
############################################################################

# Checking the variables
glimpse(data)

# Exploring the data (a bit)
skim(data)

# factorize
data <- data %>%
  mutate(country = make.names(country) %>% as.factor(),
         region = make.names(region) %>% as.factor()) %>%
  select(-place_slug)
# Note: makenames to get rid of the spaces in the countries / regions.. could cause problems otherwise

############################################################################
############################################################################
# data preprocessing for classification
############################################################################
############################################################################

# Split in training and test
index <- createDataPartition(y = data %>% pull(region), p = 0.8, list = FALSE)
training <- data[index,] %>% select(-country)
test <- data[-index,] %>% select(-country)

# Do the preprocessing recipe
library(recipes)
reci <- recipe(region ~ ., data = training) %>%
  step_center(all_numeric(), -all_outcomes()) %>%
  step_scale(all_numeric(), -all_outcomes()) %>%
  prep(data = training)

# Split in x/y & train/test
x_train <- bake(reci, newdata = training) %>% select(-region)
x_test  <- bake(reci, newdata = test) %>% select(-region)
y_train <- training %>% pull(region)
y_test  <- test %>% pull(region)

# Remove what we dont need anymore
rm(index, reci)

############################################################################
# Predicting the region ( classification)
############################################################################

### Define carets traincontrol object
ctrl.class <- trainControl(method = "cv",
                           number = 5, # Number of CV's
                           classProbs = TRUE, # Include probability of class prediction
                           summaryFunction = multiClassSummary) # Which type of summary statistics to deliver

### Predict (multinomial logit)
fit.multinom <- train(x = x_train,
                   y = y_train,
                   trControl = ctrl.class,
                   method = "multinom",
                   tuneLength = 5)
fit.multinom
ggplot(fit.multinom)

### Prediction & Confusion matrix
pred.multinom <- predict(fit.multinom, newdata = x_test)

table(y_test, pred.multinom)
confusionMatrix(y_test, pred.multinom)

############################################################################
############################################################################
# data preprocessing for regression
############################################################################
############################################################################

# Split in training and test
index <- createDataPartition(y = data %>% pull(nomad_score), p = 0.8, list = FALSE)
training <- data[index,]
test <- data[-index,]

# Do the preprocessing recipe
library(recipes)
reci <- recipe(nomad_score ~ ., data = training) %>%
  step_center(all_numeric(), -all_outcomes()) %>%
  step_scale(all_numeric(), -all_outcomes()) %>%
  step_dummy(all_nominal(), -all_outcomes()) %>%
  step_zv(all_predictors(), -all_outcomes()) %>%
  prep(data = training)

# Split in x/y & train/test
x_train <- reci %>% bake(newdata = training) %>% select(-nomad_score)
x_test  <- reci %>% bake(newdata = test) %>% select(-nomad_score)
y_train <- training %>% pull(nomad_score)
y_test  <- test %>% pull(nomad_score)

# Remove what we dont need anymore
rm(index, reci)

############################################################################
# Predicting the nomad score(regression)
############################################################################

### Define carets traincontrol object
ctrl.reg<- trainControl(method = "cv",
                        number = 5)

### Predict (linear model lm)
fit.lm <- train(x = x_train,
                y = y_train,
                trControl = ctrl.reg,
                method = "glm",
                family = "gaussian")
fit.lm

# RMSE LM
pred.lm <- predict(fit.lm, newdata = x_test)
sqrt(mean( (y_test - pred.lm ) ^ 2)) # Ignore the warning...


 DGTTRF Example Program Results

 Details of factorization

  Second superdiagonal of U
   -1.0000   1.9000   8.0000

  First superdiagonal of U
    2.3000  -5.0000  -0.9000   7.1000

  Main diagonal of U
    3.4000   3.6000   7.0000  -6.0000  -1.0154

  Multipliers
    0.8824   0.0196   0.1401  -0.0148

  Vector of interchanges
         2        3        4        5        5


library(haven)
library(lme4)
library(tictoc)

# Path to LMMPaper directory (must be filled in)
LMMdir <- #...

# Read in reduced dataset
reducedat <- as.data.frame(read.csv(paste(LMMdir, Platform$file.sep, 'data', .Platform$file.sep, 'SATExample', .Platform$file.sep, 'school67.csv', sep="")))

# Work out response and factors
y <- as.matrix(reducedat$math)
tchrfac <- as.factor(reducedat$tchrid)
studfac <- as.factor(reducedat$studid)

# Work out design
x1 <- as.matrix(reducedat$year)

# Run model
m1 <- lmer(y ~ x1 + (1|tchrfac) + (1|studfac),REML=FALSE)
devfun1 <- lmer(y ~ x1 + (1|tchrfac) + (1|studfac),REML=FALSE,devFunOnly = TRUE)

# Time model
tic('lmer time')
tmp <- optimizeLmer(devfun1)
t <- toc()

# Fixed effects and fixed effects variances
fixef(m1)
summary(m1)$coef[, 2, drop = FALSE]

# RFX variances and residual variance
as.matrix(Matrix::bdiag(VarCorr(m1)))
resid <- as.data.frame(VarCorr(m1))[3,4]#as.data.frame(vc,order="lower.tri")

# Log-likelihood
logLik(m1)


#Precip Evt Separation function

Precip_Evt_Sep= function(dt,T_intv,IntE_P,units='mins')
    #dt:       data of time and rain
    #T_intv:   Time interval of the time series (mins)
    #IntE_P:   Inter event period
    #           (time step based your time interval
    #            For example: in a 5 min time interval series
    #            a 4 hour inter event period is corresponding to
    #            48 for IntE_P)
    # output:
    #   Odd Evt_lab: Rain event
    #   Even Evt_lab: Dry event
{
  #The header of time and rain should be
  # Time    Rain

    dt %<>% arrange(Time)

    # print out the gaps with NA Rain
    print('Here are all the gaps with NA rain.')
    dt %>%
        filter(is.na(Rain)) %>%
        arrange(Time) %>%
        mutate(lag=as.numeric(Time-lag(Time),units=units)) %>%
        mutate(Gap_St=ifelse(lag>T_intv | is.na(lag),'Start','NA')) %>%
        mutate(Gap_End=ifelse(lead(lag)>T_intv | is.na(lead(lag)),'End','NA')) %>%
        mutate(Gap_Lab=(Gap_St=='Start')+(Gap_End=='End')) %>%
        mutate(Gap_n=(cumsum(Gap_Lab)+1) %/% 2) %>%
        group_by(Gap_n) %>%
        summarise(Start=min(Time),
                  End=max(Time)) %>%
        mutate(Duration_hr=as.numeric(End-Start,units=units)) %>%
        print

    #generate rain events

    data.frame(
        Time=c(min(dt$Time)-minutes(T_intv),
                max(dt$Time)+minutes(T_intv))
        ) %>%
        bind_rows(dt) %>%
        Regular_Time(T_intv) %>%
        replace_na(list(Rain=0)) %>%
        mutate(Cum_Precip_4hr_L=roll_sum(Rain,IntE_P+1,align='left',fill=0),
               Cum_Precip_4hr_R=roll_sum(Rain,IntE_P+1,align='right',fill=0)) %>%
        mutate(St_wet=ifelse(lag(Cum_Precip_4hr_R)==0 & Rain>0,1,0),
               St_dry=ifelse(lag(Cum_Precip_4hr_L)>0 & Cum_Precip_4hr_L==0 & Rain==0,1,0)) %>%
        replace_na(list(St_wet=0,St_dry=0)) %>%
        mutate(Evt_lab=St_wet+St_dry) %>%
        mutate(Evt_lab=cumsum(Evt_lab)) %>%
        select(Time,Rain,Evt_lab) %>%
        return
}


rangeExpand <- function(text) {
  lst <- gsub("(\\d)-", "\\1:", unlist(strsplit(text, ",")))
  unlist(sapply(lst, function (x) eval(parse(text=x))), use.names=FALSE)
}

rangeExpand("-6,-3--1,3-5,7-11,14,15,17-20")
 [1] -6 -3 -2 -1  3  4  5  7  8  9 10 11 14 15 17 18 19 20


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 8, 2016

# clear; Rscript rlist.r; rm *~
# ref: http://www.programiz.com/r-programming/list

# 5 data types in R : vectors, matrix, list, data frame and a factor

#########################################################################################################
#   LIST CREATION
#########################################################################################################

cat("\nCreating a List")
cat("\nList can be created using the list() function.  \n")

x <- list("a"=2.5, "b"=TRUE, "c"=1:3)
x # $a  $b  $c
typeof(x) # [1] "list"
length(x) # [1] 3
str(x)    # List of 3 $ a: num 2.5 $ b: logi TRUE $ c: int [1:3] 1 2 3
cat("\nIn this example, a, b and c are called tags which makes it easier to reference the components \n")

cat("\nWe can create the same list without the tags as follows \n")
x <- list(2.5,TRUE,1:3)
x # [[1]]  [[2]]  [[3]]

#########################################################################################################
#   LIST ELEMENTS ACCESSING
#########################################################################################################
#cat("\nAccessing Components in List\n")
x <- list("name"="Bhishan", "age"=30, "speaks"="English","Nepalese")
x[c(1:2)]    # index using integer vector
x[-2]        # using negative integer to exclude second components
x[c(T,F,F)]  # index using logical vector

#cat("\nUse of [""] operator to access elements\n")
cat("\n \n")