library(zoo)
library("ggplot2")
library(gridExtra)
library(grid)
library(qdapTools)

setwd("C:/Code/climData/glaser2019")

hhi <- read.csv("csv/hhi_summer_1000_2019.csv", sep=",", na = "NA")

half  <- read.csv("csv/tmb_folgen_5_10.csv", sep=",")
quart <- read.csv("csv/tmb_folgen_6_8.csv", sep=",")

both2 <- merge(hhi,half, by=c("year"))
both4 <- merge(hhi,quart, by=c("year"))

new2 <- subset(both2, both2$year<1996 & both2$year>1499)
old2 <- subset(both2, both2$year<1500 & both2$year>999)

old2 <- subset(old2, old2$hhi != 0.0)
new2 <- subset(new2, new2$hhi != 0.0)

old2 <- subset(old2, old2$count > 0.0)
new2 <- subset(new2, new2$count > 0.0)

new4 <- subset(both4, both4$year<1996 & both4$year>1499)
old4 <- subset(both4, both4$year<1500 & both4$year>999)

old4 <- subset(old4, old4$hhi != 0.0)
new4 <- subset(new4, new4$hhi != 0.0)

old4 <- subset(old4, old4$count > 0.0)
new4 <- subset(new4, new4$count > 0.0)

df <- data.frame(y = new4[,"hhi"], x = new4[,"davg"])
df <- subset(df, !is.na(df$x))
mx <- lm(y ~ x, df);
slope <- unname(coef(mx)[2])
eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2,
                 list(a = format(unname(coef(mx)[1]), digits = 3),
                      b = format(unname(coef(mx)[2]), digits = 5),
                      r2 = format(summary(mx)$r.squared, digits = 3)))
eq <- as.character(as.expression(eq))

p <- ggplot(data = df, aes(x = x, y = y)) +
  theme_classic(base_size=60) +
  scale_x_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-3.5,3.5)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3)) +
  geom_hline(aes(yintercept=0)) +
  geom_vline(aes(xintercept=0)) +
  labs(x="tmb impact", y="HHI", title="", subtitle="") +
  geom_smooth(method = "lm", se=TRUE, color="cyan", formula = y ~ x) +
  geom_point(color="#0000AA", alpha=0.3, size=5) +
  geom_text(x = 2, y = -4, label = eq, parse = TRUE, size=15)

p

df <- data.frame(y = old4[,"hhi"], x = old4[,"davg"])
df <- subset(df, !is.na(df$x))
mx <- lm(y ~ x, df);
slope <- unname(coef(mx)[2])
eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2,
                 list(a = format(unname(coef(mx)[1]), digits = 3),
                      b = format(unname(coef(mx)[2]), digits = 5),
                      r2 = format(summary(mx)$r.squared, digits = 3)))
eq <- as.character(as.expression(eq))

p <- ggplot(data = df, aes(x = x, y = y)) +
  theme_classic(base_size=60) +
  scale_x_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-3.5,3.5)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3)) +
  geom_hline(aes(yintercept=0)) +
  geom_vline(aes(xintercept=0)) +
  labs(x="tmb impact", y="HHI", title="", subtitle="") +
  geom_smooth(method = "lm", se=TRUE, color="cyan", formula = y ~ x) +
  geom_point(color="#0000AA", alpha=0.3, size=5) +
  geom_text(x = 2, y = -2, label = eq, parse = TRUE, size=15)

p


library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(stats)
library(matrixStats)
# We require a specific version of GJRM:
# remotes::install_version("GJRM", "0.2-2")
library(GJRM)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load and prepare the serosurvey data for model fit
source("code/analysis/wave3/create_serosurvey_data_for_model_fit.r")

############################
# Parametric sample selection bivariate probit fit

# Define regressors list
demographic_regressors <- "agegroup + male"
sociodemographic_regressors <- "agegroup + male + highereduc"
infection_regressors <- "lives_alone + washing_hands_more + was_sick + selftested_covid + district"
basic_regressors <- "agegroup + male + highereduc + lives_alone + was_sick + selftested_covid + district"

# Fit the models with given scenarios
regression_scenarios <- c("demographic", "sociodemographic", "infection", "basic")

# Define serological tests to consider
serological_tests <- c("IgG_or_M_testD", "IgA_or_G_or_M_testC", "testC_and_testD", "testC_or_testD")

# Fit the models with given regressors
for(scenario in regression_scenarios) {

	# Debug: scenario <- "demographic"; serotest <- "IgG_or_M_testD"

	regressors_used <- get(paste0(scenario, "_regressors"))

	for(serotest in serological_tests) {

		model_fit <- estimate_bivariate_selection(data = serosurvey_data, subset_condition = NULL, selection_type = "2step", agreementvar = "agreed", clinicvisitvar = "agreed_and_tested", outcomevar = serotest, regressors = regressors_used, semiparametric_age = F, exclusion_restriction_clinicvisit = NULL, error_distribution = "N", surveyweightsvar = "raking_weight")

		# Save to an R object with a naming convention
		# Example: out.demographic.IgG_or_M_testD
		assign(paste("out", scenario, serotest, sep = "."), model_fit)

		print(paste0("Fit model ", scenario, ", test ", serotest))

	}

}

############################
# Prevalence estimation

# Set test characteristics (after own test validation)
## Genetico CoronaPass (after own test validation)
sensitivity_iga_g_m_genetico <- 0.920
specificity_iga_g_m_genetico <- 1

## Vector-best (after own test validation)
sensitivity_igg_m_vector <- 0.939
specificity_igg_m_vector <- 1

## Another option: assume unitary sensitivity and specificity
#sensitivity_igg_m_vector <- specificity_igg_m_vector <- sensitivity_iga_g_m_genetico <- specificity_iga_g_m_genetico <- 1

######## Create an object with prevalence results from different regression models

# Specify which prevalences to estimate
prevalence_types <- c("naive", "univariate")

# Initiate an object to store the results
prevalence_by_model <- data.table()

for(scenario in regression_scenarios) {

	for(serotest in serological_tests) {

		for(prevalence_type in prevalence_types) {

			for( surveyweight in c("no", "raking") ) {

				# Debug: scenario <- "demographic"; serotest <- "IgG_or_M_testD"; prevalence_type <- "univariate"; surveyweight <- "no"

				# Retrieve the specified model
				model <- get(paste("out", scenario, serotest, sep = "."))

				# Variables in selection and outcome equations
				n_selection <- nrow(model$fit$gam1$model)
				n_outcome <- nrow(model$fit$gam2$model)

				# Set test characteristics
				test_sensitivity <- ifelse(grepl("testB", serotest), sensitivity_igg_abbott, ifelse(grepl("testC", serotest), sensitivity_iga_g_m_genetico, ifelse(grepl("testD", serotest), sensitivity_igg_m_vector, 1)))
				test_specificity <- ifelse(grepl("testB", serotest), specificity_igg_abbott, ifelse(grepl("testC", serotest), specificity_iga_g_m_genetico, ifelse(grepl("testD", serotest), specificity_igg_m_vector, 1)))

				# Consider a special case when we
				# perform logical OR or AND on tests
				## testC OR testD
				if( serotest == "testC_or_testD") {

					test_sensitivity <- 0.939
					test_specificity <- 1

				}
				## testC AND testD
				if( serotest == "testC_and_testD") {

					test_sensitivity <- 0.920
					test_specificity <- 1

				}

				# Specify survey weights for prevalence computation
				if( !is.null(model$fit$survey_weights_visit) & surveyweight != "no" ) {

					if (prevalence_type == "naive") {

						survey_weights <- model$fit$survey_weights_outcome

					} else {

						survey_weights <- model$fit$survey_weights_visit

					}

				} else {

					survey_weights <- NULL
				}

				# Adjust the prevalence with respect to test quality
				# and store the unadjusted version as well
				for( adjusted in c(T, F) ) {

					adjusted_prevalence <- adjust_prev_test_chars(prev_modified(model$fit, type = prevalence_type, sw = survey_weights, delta = T), sensitivity = ifelse(adjusted, test_sensitivity, 1), specificity = ifelse(adjusted, test_specificity, 1))

					# Append to an object
					prevalence_by_model <- rbind(prevalence_by_model,
							data.table(	scenario = scenario,
										serotest = serotest,
										prevalence_type = prevalence_type,
										surveyweight = surveyweight,
										sensitivity = adjusted_prevalence$sensitivity,
										specificity = adjusted_prevalence$specificity,
										lowerbound = adjusted_prevalence$res[1],
										pointest = adjusted_prevalence$res[2],
										upperbound = adjusted_prevalence$res[3],
										n_selection = n_selection,
										n_outcome = n_outcome,
										rho = as.numeric(summary(model$fit)$theta),
										rhoci = list(as.numeric(summary(model$fit)$CItheta))
									),
								fill = T)

				}

			}

		}
	}

}

# Round the results
prevalence_by_model[, c("lowerbound", "pointest", "upperbound", "rho") := lapply(.SD, function(x) { round(x*100, 1) }), .SDcols = c("lowerbound", "pointest", "upperbound", "rho") ]

# Save point
save(prevalence_by_model, file = "estimates/wave3/prevalence_by_model.rdata", compress = "xz")


################################################################################################################
#3. FAZA: VIZUALIZACIJA PODATKOV - GRAFI
################################################################################################################

#require(ggplot2) #ggplot, geom_col, scale_fill_manual, facet_grind,facet_wrap
#require(dplyr) #group_by, top_n, desc (uredi od najvišje do najnižje ocene), select, mutate, summarise, recode, filter
#library(tidyverse) #nisem uporabila
#library(scales) #izračun deleža; percent
#library(wesanderson) #barva grafa
#library(reshape2) #nisem uporabila
#library(tidyr) #gathe (ekvivalneten) pivot_longer

#=============================================================================================================
#1. KAKO SE JE SKOZI OLIMPISKI CIKEL SPREMINJALA VREDNOST OCEN (SKUPNE IN D).
#______________________________________________________________________________________________________________
#iz vsake tekme bom izbrala 10 najvišjih ocen (neglede na rekvizit),
#primerjala D s končno oceno (za 5. najvišjo oceno-prikaz na grafu),
#izračunala medijano in povprečno vrednost za vsako tekmo.
#----------------------------------------------------------------------------

#---------------------------------------------------------------------------
#PRIPRAVA PODATKOV
#----------------------------------------------------------------------------
induvidualne_viz <- induvidualne #da ne bi kaj pokvarili v prvotni tabeli

induvidualne_viz %>%
  #----------------------------------------------------------------------------
  #izracunamo koliko % ocene predstavlja D
  #----------------------------------------------------------------------------
   add_column(delez =percent(induvidualne_viz$D/induvidualne_viz$koncna_ocena, accuracy = 0.01))%>% #iz scales
  #----------------------------------------------------------------------------
  #izberemo 10 najboljših za vsako tekmo
  #---------------------------------------------------------------------------
   group_by(tekma) %>% #dplyr
   top_n(10, koncna_ocena) %>% #dplyr
   arrange(desc(koncna_ocena)) %>% #desc iz dplyer uredi od najvišje do najnižje ocene
   select(-c(tekmovalka, drzava, E, Pen.)) %>% #dplyr; te stolpci nas ne bodo zanimali
   mutate(ranking = 1:10)-> induvidualne_viz #dplyr
#View(induvidualne_viz)

#---------------------------------------------------------------------------
#PRIPRAVA PODATKOV ZA graf1
#---------------------------------------------------------------------------

# V dat SHRANIMO STOLPCE KI JIH BOMO POTREBOVALI PRI TEJ ANALIZI
#--------------------------------------------------------------------------
dat <- data.frame(
  D = induvidualne_viz$D,
  koncna_ocena = induvidualne_viz$koncna_ocena,
  ranking = as.factor(induvidualne_viz$ranking),
  tekma = as.factor(induvidualne_viz$tekma)
)

#POVPREČJE
#----------------------------------------------------------------------------
dat %>%
  group_by(tekma)%>%
  summarise(D=mean(D), koncna_ocena =mean(koncna_ocena))%>% #dplyer; uporaba združevalne funkcije na dveh stolpcih
  gather("Stat", "Value",-tekma) %>% #tidyr; pivot_longer;
  #združi stolpca D in koncna_ocena - imena zapiše v stolpec stat, pod value pa vrednosti.
  add_column(ranking = "povprečje")-> dat_mean
#View(dat_mean)

#MEDIANA
#----------------------------------------------------------------------------
dat %>%
  group_by(tekma)%>%
  summarise(D=median(D), koncna_ocena=median(koncna_ocena))%>%
  gather("Stat", "Value", -tekma) %>%
  add_column(ranking = "mediana")-> dat_mediana
#View(dat_mediana)

#V dat_D SHRANIMO SPREMENJENO dat NUMERIČNE STOLPCE DAMO V ENEGA,
#DODAMO NOV STOLPEC stat Z VREDNOSTJO D IN koncna_ocena
#-----------------------------------------------------------------------------
dat_D <- dat %>%
  gather("Stat", "Value", -ranking, -tekma)
#View(dat_D)

#ZDRUŽIMO TABELE
#-----------------------------------------------------------------------------
dat_graf1 <- rbind(dat_D, dat_mean, dat_mediana)
#View(dat_graf1)

value <- dat_graf1$Value #za ipis vrednosti na grafu
#------------------------------------------------------------------------------
#GRAF
#------------------------------------------------------------------------------
graf1 <- ggplot(dat_graf1, aes(x = ranking, y = Value, fill = Stat)) +
  geom_col(position = "dodge") +
  #------------------------------------------------------------
  #DEKORACIJA LEGENDE
  #------------------------------------------------------------
  scale_fill_manual(values=c("slateblue2","lightpink"),  #!niso mi ok barve
                    labels = c("D", "KONČNA OCENA")
                    )+
  #legend("topright", legend = c("D", "KONCNA OCENA"), cex = 0.75)+
  #--------------------------------------------------------
  #SKALA NA Y OSI
  #--------------------------------------------------------
  #scale_y_continuous(breaks=dat_D$Value)+ #preveč natlačen
  #scale_y_continuous(breaks=c(10:26))+
  #---------------------------------------------------------
  #NASLOV, TEXT NA OSEH
  #---------------------------------------------------------
  ggtitle("DVIG OCEN SKOZI OLIMPIJSKI CIKEL 2017 - 2021")+
  xlab("mesto uvrstitve") +
  ylab("ocena")+
  #theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))+
  geom_text(aes(label = value, #navpična vrednost na grafu
                angle = 90,
                vjust = 0.25,
                hjust=1,
                #color = "white",
                ))+
  #--------------------------------------------------------
  #TRIJE GRAFKI
  #--------------------------------------------------------
  facet_grid(.~tekma)+
  #--------------------------------------------------------
  #OZADJE-da se znebimo sivega ozadja
  #--------------------------------------------------------
  theme_bw() +
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(), #mislim da je bolje da sedaj ni vodoravnih črt
        strip.background = element_blank(),
        panel.border = element_blank(),
        #----------------------------------------------------------------------
        #NAPISI PRI X OSI, IZBRIS Y OSI
        #----------------------------------------------------------------------
        axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1),
        #axis.title.x = "mesto uvrstitve",
        axis.text.y=element_blank(),
        axis.ticks=element_blank(), #izbris črtic na oseh
        #----------------------------------------------------------------------
        #NASLOV GRAFA NA SREDINI
        #----------------------------------------------------------------------
        plot.title = element_text(hjust=0.5),
        #----------------------------------------------------------------------
        #DEKORACIJA LEGENDE
        #----------------------------------------------------------------------
        legend.justification = c("left", "top"),
        legend.position = "top",
        legend.key.size = unit(0.25, 'cm'),
        legend.title = element_blank(),
        legend.text = element_text(size = 6, colour = "black"))

print(graf1)

#==================================================================================================================
#3. GRAF VREDNOSTI TEŽIN Z REKVIZITOM (2018,2019)
#__________________________________________________________________________________________________________________
#graf ki prikazuje koliko ima kakšna tekmovalka točk pri težinah z rekvizitom,
#problem je da ne vemo kater rekvizit je to bomo delili grafe, tekmo-color
#Kijeva ni ker nisem dobila tako podrobnih rezultatov

#------------------------------------------------------------------------
#SKRAJŠAMO IMENA TEKMOVALK ZA LEPŠI PREGLED
#-------------------------------------------------------------------------
wcg_graf3 <- wcg #da ne uničimo tabele
wcg_graf3$tekmovalka <- recode(wcg_graf3$tekmovalka #dplyr
                    ,"SELEZNEVA Ekaterina" = "SELEZNEVA" #KAJ JE = V KAJ ŽELIMO SPREMENITI
                    ,"ASHRAM Linoy" =  "ASHRAM"
                    ,"AVERINA Dina" = "AVERINA D."
                    ,"ZELIKMAN Nicol" = "ZELIKMAN"
                    ,"KALEYN Boryana" = "KALEYN"
                    ,"AGIURGIUCULESE Alexandra" = "AGIURGIUCULESE"
                    ,"HALKINA Katsiaryna" ="HALKINA"
                    ,"SALOS Anastasiia" = "SALOS"
                    ,"AVERINA Arina" = "AVERINA A."
                    ,"BALDASSARRI Milena" = "BALDASSARRI"
                    ,"NIKOLCHENKO Vlada" = "NIKOLCHENKO"
                    ,"GRISKENAS Evita" = "GRISKENAS"
                    ,"HARNASKO Alina" = "HARNASKO"
                    ,"ZENG Laura" = "ZENG"
                    ,"TASEVA Katrin" = "TASEVA"
                    ,"SOLDATOVA Aleksandra" = "SOLDATOVA"
                    ,"VLADINOVA Neviana" = "VLADINOVA"
                    ,"PAZHAVA Salome" = "PAZHAVA"
                    ,"MINAGAWA Kaho" = "MINAGAWA")
#View(wcg_graf3)

#--------------------------------------------------------------------------------------
#GRAF
#--------------------------------------------------------------------------------------
graf3 <- ggplot(data = wcg_graf3, mapping = aes(x = tekmovalka, y = DA, fill = tekma)) +
  geom_col(position = "dodge")+
  ggtitle("VREDNOSTI TEŽIN Z REKVIZITOM AD")+
  labs(x="tekmovalke", y="DA") +
  facet_wrap( ~ rekvizit, ncol=5) +
  #------------------------------------------------------------------
  # PREGLEDNEJŠA X OS
  #------------------------------------------------------------
  scale_y_continuous(breaks=c(2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, 9, 9.5, 10))+
  theme_minimal()+
  theme(axis.text.x = element_text(angle = 90, vjust = 1, hjust=1, size = 4.5),
        #------------------------------------------------------------
        #DA JE NASLOV NA SREDINI
        #------------------------------------------------------------
        plot.title = element_text(hjust=0.5)
  )

print(graf3)

#======================================================================================================
#4. PRI KATEREM REKVIZITU TEKMOVALKE DOBIJO NAJVEČJI ODBITEK ZA IZVEDBO?
#______________________________________________________________________________________________________
#------------------------------------------------------------------------------------------------------
#PRIPRAVA PODATKOV
#------------------------------------------------------------------------------------------------------
#iz tabele induvidualne_finali izberemo max, min (GLEDE NA E), mediano in povprečje
#neglede na tekmo, za vsak rekvizit posebaj
induvidualne_E <- induvidualne_finali # da ne pokvarimo tabele

#najboljši E
#--------------------------
max_E <- induvidualne_E %>%
  group_by(rekvizit) %>%
  summarise(Value = max(E)) %>% #dplyr
  add_column(nacin = "max")

#najslabši E
#--------------------------
min_E <- induvidualne_E %>%
  group_by(rekvizit) %>%
  summarise(Value = min(E))%>%
  add_column(nacin = "min")

#mediana E
#-------------------------
me_E <- induvidualne_E %>%
  group_by(rekvizit)%>%
  summarise(Value = median(E))%>%
  add_column(nacin = "mediana")

#povprečje E
#-------------------------
av_E <- induvidualne_E %>%
  group_by(rekvizit)%>%
  summarise(Value = mean(E))%>%
  add_column(nacin = "povprečje")

#združimo
#--------------------------
induv_graf4 <- rbind(max_E, min_E, me_E, av_E)
#View(induv_graf4) #!!!preveč decimalk

#------------------------------------------------------------------------------------------------------
#GRAF
#------------------------------------------------------------------------------------------------------
graf4 <- ggplot(induv_graf4, aes(x=nacin, y=Value)) +
  #------------------------------------------------------------------------
  #LOLIPOP
  #------------------------------------------------------------------------
  geom_segment( aes(x=nacin, xend=nacin, y=0, yend=Value), color="grey") +
  geom_point( size=7.5, color=alpha("orange", 0.3), fill=alpha("orange", 0.3), alpha=0.7, shape=21, stroke=2)+
  #-----------------------------------------------------------------------
  #IZPIS VREDNOSTI V BUNKICAH
  #--------------------------------------------------------------------------
  geom_text(aes(label = round(Value,2), #navpična vrednost na grafu
                angle = 90,
                vjust = 0.25,
                hjust=0.5,
  ),size = 2.5)+
  #--------------------------------------------------------------------------
  #DEKORACIJA
  #--------------------------------------------------------------------------
  theme_light() +
  ggtitle("KAKO SE IZVEDBENA OCENA E SPREMINJA GLEDE NA REKVIZIT")+
  theme(
    panel.grid.major.x = element_blank(),
    panel.border = element_blank(),
    axis.ticks.x = element_blank(),
    axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=0.5, size = 8),
    axis.ticks.y = element_blank(),
    axis.text.y = element_blank(),
    #------------------------------------------------------------
    #DA JE NASLOV NA SREDINI
    #------------------------------------------------------------
    plot.title = element_text(hjust=0.5)
  ) +
  xlab("") +
  ylab("vrednost izvedbenega odbitka E")+
  #---------------------------------------------------------------------------
  #GRAFKI ZA VSAK REKVIZIT
  #---------------------------------------------------------------------------
  facet_grid(.~rekvizit)

print(graf4)

#===================================================================================================
#5. ALI JE DVIG OCENE D VPLIVAL NA POVEČANJE ODBITKA E
#___________________________________________________________________________________________________
#Zanima me ali se 'splača' otežiti sestavo in s tem povečati vrednost D, glede na posledičen padec ocene E.
#pogledali si bomo ocene ene tekmovalke-Linoy Ashram, (*v sofiji le v dveh finalih)
#--------------------------------------------------------------------------------------------------

#--------------------------------------------------------------------------------------------------
#PRIPRAVA PODATKOV
#--------------------------------------------------------------------------------------------------
induvidualne_graf5 <- induvidualne_finali %>%
  filter(tekmovalka == "ASHRAM Linoy") %>% #dplyr
  select(tekma,rekvizit, E, D) #dplyr
#View(induvidualne_graf5)

#---------------------------------------------------------------------------------------------------
#E in D moram zložit skupaj, in dodati stolpec alij je to D ali E ocena
#---------------------------------------------------------------------------------------------------
induv_graf5 <- induvidualne_graf5 %>%
  pivot_longer(c("E","D"), names_to = "ocena", values_to = "vrednosti") #tidyr, pivot_longer(c(stolpci ki jih želimo združiti), samo imena stolpcev)

#---------------------------------------------------------------------------------------------------
#KRAJ TEKME NAS NE ZANIMA- ta korak ni potreben
#---------------------------------------------------------------------------------------------------
induv_graf5$tekma <- recode(induv_graf5$tekma #dplyr
                               ,"2018 Sofia" = "2018" #KAJ JE = V KAJ ŽELIMO SPREMENITI
                               ,"2019 Baku" = "2019"
                               ,"2020 Kijev" = "2020")

#View(induv_graf5)

#---------------------------------------------------------------------------------------
#GRAF
#---------------------------------------------------------------------------------------
graf5 <- ggplot(induv_graf5, aes(x = tekma, y = vrednosti, colour = ocena)) +
  geom_point() +
  facet_grid(.~rekvizit) +
  #------------------------------------------------------------------------
  #VREDNOSTI NAD PIKICAM
  #------------------------------------------------------------------------
  geom_text(aes(label = vrednosti, #navpična vrednost na grafu
                #angle = 90,
                vjust = 1.50,
                hjust=0.5,
  ),size = 2.5) +
  #------------------------------------------------------------------------
  # OZADJE
  #-----------------------------------------------------------------------
theme_bw() +
  theme(#panel.grid.major = element_blank(), #navpične črte
        #panel.grid.minor = element_blank(), #vodoravne črte
        strip.background = element_blank(), #siv pravokotniki pri imenih grafkov
        #panel.border = element_blank(), #obkroži grafke
        #----------------------------------------------------------------------
        #NAPISI PRI X OSI, IZBRIS Y OSI
        #----------------------------------------------------------------------
        axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1),
        axis.title.x = element_blank(),
        axis.text.y=element_blank(),
        axis.ticks=element_blank()
  )+
  #-----------------------------------------------------------------------------
  # NASLOV
  #-----------------------------------------------------------------------------
  ggtitle("VPLIV DVIGA OCENE D NA POVEČANJE
          ODBITKA E PRI TEKMOVALKI LINOY ASHRAM")+
  theme(plot.title = element_text(hjust=0.5))
print(graf5)


#' ---
#' title: Results
#' output: word_document
#' ---

#+ echo=F
library(dplyr)
library(xlsx)

source("init if necessary.r")

n.herders = length(unique(dyads$Ego.ID))
n.givers  = length(unique(dyads.subset$Ego.ID))

finnmark_gifts.total = dyads %>%
  filter(grepl("Finnmark*", PopName)) %>%
  group_by(SameHerdingGroup) %>%
  summarise(gifts = sum(GiftGiven)) %>%
  mutate(pc = round( (gifts / sum(gifts)) * 100, 1))

finnmark_gifts.to_group = finnmark_gifts.total %>% filter(SameHerdingGroup==1) %>% select(pc) %>% as.numeric(.)

tibet_gifts.total = dyads %>%
  filter(grepl("Tibet*", PopName)) %>%
  group_by(SameHerdingGroup) %>%
  summarise(gifts = sum(GiftGiven)) %>%
  mutate(pc = round( (gifts / sum(gifts)) * 100, 1))

tibet_gifts.to_group = tibet_gifts.total %>% filter(SameHerdingGroup==1) %>% select(pc) %>% as.numeric(.)

# reciprocities
finnmark.stats = net.stats %>%
  filter(grepl("^k.*", Site)) %>%
  summarise(recip.min = round( min(reciprocity)*100, 2), recip.max = round( max(reciprocity)*100, 2),
            assort.min = round(min(assortativity.hg), 2), assort.max = round(max(assortativity.hg), 2))

tibet.stats = net.stats %>%
  filter(!grepl("^k.*", Site)) %>%
  summarise(recip.min = round( min(reciprocity)*100, 2), recip.max = round( max(reciprocity)*100, 2),
            assort.min = round(min(assortativity.hg), 2), assort.max = round(max(assortativity.hg), 2))

#' In total, `r n.givers` herders living in six study sites gave `r sum(d.long$GiftGiven)` gifts. Overall our sample contained `r n.herders` herders in `r nrow(dyads.subset)` dyads. Reindeer herders in Finnmark gave `r finnmark_gifts.to_group`% of their `r sum(finnmark_gifts.total$gifts)` gifts to members of the same herding group, while yak herders in Tibet gave `r tibet_gifts.to_group`% of `r sum(tibet_gifts.total$gifts)` gifts to members of the same group (Figure...).
#'
#' Finnmark: `r finnmark.stats$recip.min`-`r finnmark.stats$recip.max`% of gifts were reciprocated. Assortment on herding group: `r finnmark.stats$assort.min`-`r finnmark.stats$assort.max`

#+ echo=F
post = as.data.frame(m.herd.deg)
post.sex = quantile(post$Sexb, probs=c(0.5, 0.025, 0.975))
post.age = quantile(post$Age.z, probs=c(0.5, 0.025, 0.975))

#' Females had smaller herds compared to males ($\Beta$=`r round(post.sex[1], 3)`; 95% credible interval [`r round(post.sex[2], 3)`, `r round(post.sex[3], 3)`]), while older herders owned more animals ($\Beta$=`r round(post.age[1], 3)`; 95% CI [`r round(post.age[2], 3)`, `r round(post.age[3], 3)`]).

#+ echo=F
mod_kara = net.stats %>% filter(Site=="karasjok") %>% select(modularity) %>% as.numeric(.)
mod_kara_prop = net.stats.rnd %>% filter(Site=="karasjok" & modularity < mod_kara) %>% summarise(p = n() / nrow(net.stats.rnd)) %>% as.numeric(.)

mod_kauto = net.stats %>% filter(Site=="kautokeino") %>% select(modularity) %>% as.numeric(.)
mod_kauto_prop = net.stats.rnd %>% filter(Site=="kautokeino" & modularity < mod_kauto) %>% summarise(p = n() / nrow(net.stats.rnd)) %>% as.numeric(.)

#' `r round(mod_kara_prop * 100, 1)`% of random modularity scores < observed score in Karasjok; `r round(mod_kauto_prop * 100, 1)`% of random modularity scores < observed score in Kautokeino

#+ echo=F
vpc.herd.sum = round(vpc.herd.deg$vpc * 100, 1)

#' Between-subject differences accounted for almost all variance in predicting standardised herd size (`r vpc.herd.sum[2]`%); there was almost no variation between sites (`r vpc.herd.sum[1]`%).

#+ echo=F
# calculate proportions of gifts given to non-kin and kin
dyads.gifts = dyads.subset %>%
  filter(GiftGiven == 1) %>%
  mutate(r.desc = factor( case_when(
    .$r > 0  ~ "Kin",
    .$r == 0 ~ "Non-kin"
  ), levels=c("Non-kin", "Kin"))) %>%
  group_by(PopName, r.desc) %>%
  summarise(n = n()) %>%
  mutate(Prop = n / sum(n)) %>%
  ungroup()

kauto_prop = dyads.gifts %>%
  filter(PopName=="Norway: Kautokeino" & r.desc=="Kin") %>%
  select(Prop) %>%
  as.numeric(.)

kara_prop = dyads.gifts %>%
  filter(PopName=="Norway: Karasjok" & r.desc=="Non-kin") %>%
  select(Prop) %>%
  as.numeric(.)

tibet_props = dyads.gifts %>%
  filter(grepl("Tibet", PopName) & r.desc=="Non-kin") %>%
  select(Prop) %>%
  range(.)

#' Proportion of gifts to kin in Kautokeino: `r round(kauto_prop * 100, 1)`%
#'
#' Proportion of gifts to non-kin in Karasjok: `r round(kara_prop * 100, 1)`%
#'
#' Range of non-kin gift proportions in Tibet: `r round(tibet_props[1] * 100, 1)`% – `r round(tibet_props[2] * 100, 1)`%

#+ echo=F
library(ineq)

ginis = dyads %>%
  select(Alter.ID, Alter.HerdSize, PopName) %>%
  distinct() %>%
  group_by(PopName) %>%
  summarise(cv = sd(Alter.HerdSize, na.rm=T) / mean(Alter.HerdSize, na.rm=T),
            gini = ineq(Alter.HerdSize, type="Gini"))

gini_finnmark = ginis %>%
  filter(grepl("Finnmark", PopName)) %>%
  select(gini) %>%
  range(.)

gini_tibet = ginis %>%
  filter(grepl("Tibet", PopName)) %>%
  select(gini) %>%
  range(.)

#' Finnmark Gini range: `r round(gini_finnmark[1], 3)` – `r round(gini_finnmark[2], 3)`
#'
#' Tibet Gini range: `r round(gini_tibet[1], 3)` – `r round(gini_tibet[2], 3)`


rm(list = ls())

# input path
fileName="~/ImageJ/JunctionDet_v11.log"

conn=file(fileName, open="r")
linn=readLines(conn)
# contains membership functions that fuzzify input variables and the decision
# results are fuzzy sets for each
# line 1 theta
# line 2 h_low[theta]
# line 3 h_mid[theta]
# line 4 h_hgh[theta]
# line 5 x ranging [0,1]
# line 6 Q_YES
# line 7 Q_MAYBE
# line 8 Q_NO

# export pdf
pdf(file='~/ImageJ/h_LOW.pdf', width = 20, height = 8) # in cm

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(4.2, 4.0, 0.5, 0.5))

# line 1
lineNr = 1; t <- unlist(strsplit(linn[lineNr], split=" ")); xName = t[1]
angA <- vector()
for (j in 2:length(t)){
  angA <- c(angA, as.numeric(t[j]))
}

# line 2
lineNr = 2; t <- unlist(strsplit(linn[lineNr], split=" ")); yName = t[1]
profileA <- vector()
for (j in 2:length(t)){
  profileA <- c(profileA, as.numeric(t[j]))
}

# plot this line
plot(angA, profileA, xlab=xName, ylab=yName, col="black", type="l", lwd=1, cex.axis=1.5) # , main="my_plot"
box()
grid()
lines(angA, profileA, xlab=xName, ylab=yName, col="black", type="o", lwd=1)
minProfileA = min(profileA)

# line 3,4 peaks A
lineNr = 3;
t <- unlist(strsplit(linn[lineNr], split=" "))
peakAnglesA <- vector()
for (j in 2:length(t)){
  peakAnglesA <- c(peakAnglesA, as.numeric(t[j]))
}

lineNr = 4;
t <- unlist(strsplit(linn[lineNr], split=" "))
peakValuesA <- vector()
for (j in 2:length(t)){
  peakValuesA <- c(peakValuesA, as.numeric(t[j]))
}

for (i in 1:length(peakValuesA)){
    segments(peakAnglesA[i], minProfileA, peakAnglesA[i], peakValuesA[i], col="red", lwd="4")
}

dev.off()

close(conn)


# read SMS.std and present results
#Read.SMS.std()

a<-Read.SMS.std()
head(a)

# sort parameter uncertanties
b<-a[order(abs(a$CV.round)),]
b<-subset(b,select=c(-area,-predator,-prey, -fleet,-parNo,-index,-no))
head(b,20)
tail(b,20)

#remove output variables
dim(b)
b<-b[-grep('M2_sd',b$name),]
b<-b[-grep('hist_SSB',b$name),]
b<-b[order(abs(b$CV.round)),]
b$CV.Pct<-round(b$CV.round)
rownames(b)<-NULL
b<-subset(b,select=c( name,value,std, CV.Pct, species, year, quarter, age))

head(b,20)
tail(b,40)

tail(b,10)

bb<-data.frame(CV.abs=abs(b$CV.round),n=1:dim(b)[[1]])
bb<-subset(bb,CV.abs<50)
X11()
plot(x=bb$n,y=bb$CV.abs,ylab='CV %',xlab='')

bb<-subset(bb,CV.abs<100)
plot(x=bb$n,y=bb$CV.abs,ylab='CV %',xlab='')

bstom<-subset(b,name %in% c("vulnera","init_stl_other_suit_slope","init_season_overlap","var_size_ratio_ini[1]","Stom_var[1]","init_pref_size_ratio[1]"))

subset(bstom,select=c(-species,-year,-quarter,-age ))

dim(b)
sort(unique(b$name))

b$name
subset(a,name=='init_season_overlap')

aa<-subset(a,name=='log_exploi_pattern')
aa$exp=exp(aa$value)
aa

unique(a$name)

a$significant<- abs(a$value-1)>2*a$std

a<-Read.SMS.std()
aa<-subset(a,name=='hist_SSB')
round(tapply(aa$CV.round,list(aa$year,paste(aa$species,sp.names[aa$species],sep='.')),sum,na.rm=T),1)
aa<-subset(a,name=='avg_F')
round(tapply(aa$CV.round,list(aa$year,paste(aa$species,sp.names[aa$species],sep='.')),sum,na.rm=T),1)

aa<-droplevels(subset(a,name=='M2_sd0'))
round(tapply(aa$CV.round,list(aa$year,paste(aa$species,sp.names[aa$species],sep='.')),sum,na.rm=T),1)
aa<-subset(a,name=='M2_sd1')
round(tapply(aa$CV.round,list(aa$year,paste(aa$species,sp.names[aa$species],sep='.')),sum,na.rm=T),1)
aa<-subset(a,name=='M2_sd2')
round(tapply(aa$CV.round,list(aa$year,paste(aa$species,sp.names[aa$species],sep='.')),sum,na.rm=T),1)

#############################################################################
# CV of SSB, F or recruitment, calculated from mean and standard deviations

plot.CV<-function(paper=FALSE,nox=1,noy=1,var.name='hist_SSB',legends=T,legend.x=NULL,legend.y=NULL,ylim=NULL) {
tit<-F
tmp<-Read.SMS.std()

if (var.name=='hist_SSB') {in.var.name<- "hist_SSB"; titl<-"CV of SSB";}
if (var.name=='F') {in.var.name<- "avg_F"; titl<-"CV of mean F";}
if (var.name=='Rec') {in.var.name<- "rec_sd"; titl<-"CV of recruitment";}
if (var.name=='M2_sd0') {in.var.name<- 'M2_sd0'; titl<-"CV of M2 age 0";}
if (var.name=='M2_sd1') {in.var.name<- 'M2_sd1'; titl<-"CV of M2 age 1";}
if (var.name=='M2_sd2') {in.var.name<- 'M2_sd2'; titl<-"CV of M2 age 2";}

a<-droplevels(subset(tmp,name==in.var.name,drop=TRUE))
if (is.null(a$species)) a$species<-1
a<-data.frame(Species=sp.names[a$species],Species.no=a$species,Year=a$year,
               value=a$value,std=a$std,CV=a$std/a$value*100)

CV.obs<-tapply(a$CV,list(a$Year,a$Species),sum,na.rm=T)
print(t(round(t(CV.obs),1)))

if (paper) dev<-"png" else dev<-"screen"
noxy<-nox*noy

year.obs<-as.numeric(dimnames(CV.obs)[[1]])
sp.nam<-dimnames(CV.obs)[[2]]
max.CV.obs<-max(CV.obs,na.rm=T)
spno<-sort(unique(a$Species.no))
sp.indx<-0
for (sp in spno) {
  sp.indx<-sp.indx+1
  #if (paper) {
    if (sp==spno[1]) {
    newplot(dev,nox,noy,filename=paste("CV_",in.var.name,sep=''),Portrait=T,w8=8,w11=9);
      plot(year.obs,CV.obs[,sp.indx],xlab=" ",ylab="CV (%)",type='b',ylim=c(0,ifelse(is.null(ylim),max.CV.obs,ylim)),lty=sp.indx,col=sp.indx,pch=sp.indx,lwd=2 )
      if (legends) legend(x=ifelse(is.null(legend.x),min(year.obs),legend.x),y=ifelse(is.null(legend.y),1,legend.y),
                           sp.nam,col=1:length(spno),ncol=4,pch=1:nsp,text.col=1,lwd=2,lty=1:length(spno))
    }
    else lines(year.obs,CV.obs[,sp.indx],col=sp.indx,type='b',pch=sp.indx,lwd=2,lty=sp.indx)
  #}
}
if (paper) cleanup()
}

plot.CV(paper=T,nox=1,noy=1,var.name='hist_SSB',legends=T,legend.y=39)
plot.CV(paper=T,nox=1,noy=1,var.name='F',legends=T,legend.y=55)
plot.CV(paper=T,nox=1,noy=1,var.name='Rec',legends=T,legend.y=150)
plot.CV(paper=T,nox=1,noy=1,var.name='Rec',legends=T,legend.y=5,ylim=35)

plot.CV(paper=T,nox=1,noy=1,var.name='M2_sd0',legend.y=30)
plot.CV(paper=T,nox=1,noy=1,var.name='M2_sd1')
plot.CV(paper=T,nox=1,noy=1,var.name='M2_sd2')
#############################################################################
# CV of SSB and F bar on the same graph. Only really works for single species runs
#
# needs an update!!!!

l.model.y<-SMS.control@last.year.model
a<-read.table(file.path(data.path,"sms.std"),comment.char = "#",header=FALSE,skip=1)
tmp<-data.frame(index=a$V1,name=a$V2, value=a$V3,  std=a$V4,CV=a$V4/a$V3*100 )

obs<-subset(tmp,name=="hist_SSB",drop=TRUE)
yobs<-nrow(obs)/(nsp-first.VPA+1)

a<-data.frame(Species=rep(sp.names[first.VPA:length(sp.names)],each=yobs),
              Year=rep(seq(l.model.y-yobs+1,l.model.y),(nsp-first.VPA+1)),
               value=obs$value,std=obs$std,CV=obs$CV)

CV.ssb<-tapply(a$CV,list(a$Year,a$Species),sum,na.rm=T)
year.ssb<-as.numeric(dimnames(CV.ssb)[[1]])

obs<-subset(tmp,name=="avg_F",drop=TRUE)
yobs<-nrow(obs)/(nsp-first.VPA+1)

a<-data.frame(Species=rep(sp.names[first.VPA:length(sp.names)],each=yobs),
              Year=rep(seq(l.model.y-yobs+1,l.model.y),(nsp-first.VPA+1)),
               value=obs$value,std=obs$std,CV=obs$CV)

CV.F<-tapply(a$CV,list(a$Year,a$Species),sum,na.rm=T)
year.F<-as.numeric(dimnames(CV.F)[[1]])
nox<-1; noy<-2;
paper<-FALSE

if (paper) dev<-"wmf" else dev<-"screen"
noxy<-nox*noy

#Maximum observed CV for setting graph limits
max.CV <-max(CV.F,CV.ssb)
if(nsp>1) {
        warning("Can't plot SSB and F on same graph for more than one species.")
   } else {
        newplot(dev,nox,noy,filename="CV_F,SSB");
        par(mar=c(4,4,2,3))
        plot(range(year.ssb,year.F),c(0,max.CV),xlab="",ylab="CV (%)",type='n',ylim=c(0,max.CV))
        lines(year.F,CV.F[,1],xlab=" ",ylab="CV (%)",type='b',ylim=c(0,max.CV),lty=1,col=1,pch=1,lwd=2 )
        lines(year.ssb,CV.ssb[,1],type="b",lty=1,col=1,pch=2,lwd=2 )
        legend("topleft",legend=c("F.bar","SSB"),col=1,ncol=2,pch=1:2,text.col=1,lwd=2,lty=1)
        grid()
}
if (paper) cleanup()

N<-subset(tmp,name=="term_N",drop=TRUE)
N.next<-subset(tmp,name=="term2_N",drop=TRUE)
N.next[1,'CV']<-NA

if (dim(N)[[1]]>0 | dim(N.next)[[1]]>0) {
  control<-read.FLSMS.control()
  fa<-control@first.age
  la<-control@species.info[1,'last-age']

  a<-data.frame(age=seq(fa,la),N=N$value,          CV.N=N$CV)
  b<-data.frame(age=seq(fa+1,la),N.next=N.next$value,CV.N.next=N.next$CV)
  ab<-merge(a,b)
  max.CV<-max(ab$CV.N,ab$CV.N.next,na.rm=T)
  plot(ab$age,ab$CV.N,xlab="age",ylab="CV (%)",type='n',ylim=c(0,max.CV))
  lines(ab$age,ab$CV.N,xlab=" ",ylab="CV (%)",type='b',ylim=c(0,max.CV),lty=1,col=1,pch=1,lwd=2 )
  lines(ab$age,ab$CV.N.next,type="b",lty=1,col=1,pch=2,lwd=2 )
  legend("top",legend=c("N 1. Jan 2008","N 1. Jan 2009"),col=1,ncol=2,pch=1:2,text.col=1,lwd=2,lty=1)
  grid()
  if (paper) cleanup()
}
########################################################################

plot.CV<-function(paper=FALSE,nox=1,noy=1,var.name='hist_SSB',newPlot=T,tit=T,outfile='Uncertanties',w8=8,w11=10,pointsize=12) {

  if (paper) dev<-"png" else dev<-"screen"
  noxy<-nox*noy

  if (plot.ref.lines) ref<-Read.reference.points()

  tmp<-Read.SMS.std()
  tmp$name[tmp$name=="next_SSB"]<-'hist_SSB'
  a<-subset(tmp,name==var.name & species>0 ,drop=TRUE)
  a$Species<-sp.names[a$species]
  a<-subset(a,Species!="Saithe",drop=TRUE)

  if (var.name=='hist_SSB')  ytitl<-"SSB (1000 t)"  else if (var.name=='avg_F') ytitl<-"mean F"  else if (var.name=='rec_sd') ytitl<-"Recruitment (10^6)" else if (var.name=='M2_sd0' | var.name=='M2_sd1' | var.name=='M2_sd2') ytitl<-"M2"  else stop("name must be hist_SSB or avg_F")

  if (var.name=='rec_sd') {
      a$value<-a$value/1000
      a$std<-a$std/1000
  }
  if (var.name=='hist_SSB') {
      a$value<-a$value/1000
      a$std<-a$std/1000
  }

  if (newPlot) newplot(dev,nox,noy,filename=outfile,w8=w8,w11=w11,Portrait=TRUE,pointsize=pointsize);
       par(mar=c(3,5,1,2))  #c(bottom, left, top, right)

  by(a,list(a$species),function(x) {
      minval<-min(x$value-2*x$std*2,0)
      maxval<-max(x$value+2*x$std*2)
      plot( x$year,x$value,xlab='',ylab=ytitl,ylim=c(minval,maxval),type='b')
      if (tit) title(main=x[1,]$Species)

       # print(aaa[2,'Cod',,1])
      lines(x$year,x$value-2*x$std,lty=2)
      lines(x$year,x$value+2*x$std,lty=2)
     # lines(x$year,aaa[2,x[1,"Species"],as.character(1975:2000),2],col=2,lty=5) # from plot_M2_uncertanty_MCMC
     # lines(x$year,aaa[3,x[1,"Species"],as.character(1975:2000),2],col=2,lty=5) # from plot_M2_uncertanty_MCMC
     if (plot.ref.lines) {
       sp<-x$species[1]
       if (var.name=='avg_F') {
        if (ref[sp,"Flim"]>0) abline(h=ref[sp,"Flim"],lty=2,lwd=2)
        if (ref[sp,"Fpa"]>0) abline(h=ref[sp,"Fpa"],lty=3,lwd=2)
       }
       if (var.name=='hist_SSB') {
          Blim<-ref[sp,"Blim"]/1000; Bpa<-ref[sp,"Bpa"]/1000
          if (Blim>0) abline(h=Blim,lty=2,lwd=2)
          if (Bpa>0) abline(h=Bpa,lty=3,lwd=2)
       }
     }

  })
  if (dev!="screen") cleanup();
}

#
#plot.CV(paper=FALSE,nox=2,noy=2,var.name='M2_sd0')

plot.ref.lines<-F
plot.CV(paper=TRUE,nox=2,noy=4,var.name='M2_sd0',outfile='Uncertanties_M2_age0')
plot.CV(paper=TRUE,nox=2,noy=1,var.name='M2_sd1',outfile='Uncertanties_M2_age1',w8=8,w11=5,pointsize=8)
plot.CV(paper=TRUE,nox=2,noy=2,var.name='M2_sd2',outfile='Uncertanties_M2_age2')

plot.CV(paper=T,nox=1,noy=3,var.name='avg_F',newPlot=T,tit=T)
plot.CV(paper=T,nox=1,noy=3,var.name='hist_SSB',newPlot=F,tit=F)
plot.CV(paper=T,nox=1,noy=3,var.name='rec_sd',newPlot=F,tit=F)

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

tmp<-Read.SMS.std()

a<-subset(tmp,name %in% c("hist_SSB","avg_F","rec_sd") ,drop=TRUE)
a<-data.frame(Species=sp.names[a$species],Year=a$year, variable=a$name,
               value=a$value,std=a$std,CV=a$std/a$value*100)

a$titl<- ifelse (a$variable=='hist_SSB',"SSB", ifelse(a$variable=='avg_F',"Average F",ifelse(a$variable=='rec_sd', "Recruitment",'error')))

pp<-function(x){
  cleanup()
  trellis.device(device = "windows",
                 color = T, width=6, height=8,pointsize = 10,
                 new = TRUE, retain = FALSE)

  xyplot( CV~Year|titl,groups=Species, data=x,
    type='b',lwd=1 , layout=c(1,3), ylab='Coefficient of Variation (%)',
     between = list(y = c(1, 1),x = c(1, 1)),
     strip = strip.custom( bg='white'),par.strip.text=list(cex=0.9, lines=1.7),
     auto.key = list(space = "bottom", points = T, lines = F,cex=0.9, columns = 3,title='Species') ,

      scales = list(x = list( cex=0.8,relation='same'), y= list(cex=0.8),alternating = 1,relation='free')
  )
}

pp(a)

pp(droplevels(subset(a,Year>=1985 & (Species %in% c('Cod','Haddock','Whiting','Saithe')))))
pp(droplevels(subset(a,Year>=1985 & !(Species %in% c('Cod','Haddock','Whiting','Saithe','Plaice','Sole')))))

pp(droplevels(subset(a,Year>=1985 & !(Species %in% c('Cod','Haddock','Whiting','Saithe','Plaice','Sole')))))


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     21.10.2019
#modificado: 06.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")
library("nycflights13")

#2.1. filter()

#2.1.1.
flights %>%
  filter(arr_delay > 120)

#2.1.2.
flights %>%
  filter(dest %in% c("IAH","HOU"))

#2.1.3.
flights %>%
  filter(arr_delay > 120 & dep_delay <=0)

#2.1.4.
flights %>%
  filter(between(dep_time, 0, 600))

#2.2. arrange()

#2.2.1.
flights %>%
  arrange(desc(dep_delay))  %>%
  select(dep_delay)

#2.2.2.
flights %>%
  mutate(speed = distance/air_time*60) %>%
  arrange(speed)  %>%
  select(speed)

#2.2.3.
flights %>%
  arrange(desc(distance)) %>%
  select(distance)

flights %>%
  arrange(desc(distance)) %>%
  select(distance)

#2.2.4.
flights %>%
  arrange(desc(is.na(air_time))) %>%
  select(air_time)

##2.3. select()

#2.3.1.
flights %>%
  select(year:day,day)

#2.3.2.
vars1 <- c("year","years")
flights %>%
  select(one_of(vars1))
vars2 <- c("year","month","day","time")
flights %>%
  select(one_of(vars2))

##2.4. mutate()

#2.4.1.
flights %>%
  transmute(dep_time = dep_time,
            dep_hours = dep_time%/%100,
            dep_minutes = dep_time%%100)
flights %>%
  transmute(dep_time = dep_time,
            dep_hours = ifelse(nchar(dep_time)==3,
			                   as.numeric(substr(dep_time,1,1)),
			                   as.numeric(substr(dep_time,1,2))),
            dep_minutes = ifelse(nchar(dep_time)==3,
			                     as.numeric(substr(dep_time,2,3)),
			                     as.numeric(substr(dep_time,3,4))))

#2.4.2.
flights %>%
  transmute(dep_delay = dep_delay,
            dep_delay2 = (dep_time%/%100 - sched_dep_time%/%100)*60 +
			              dep_time%%100 - sched_dep_time%%100)

##2.5. summarize()

#2.5.1.
flights %>%
  group_by(year,month,day) %>%
  summarize(first_flight = min(dep_time,na.rm=TRUE),
            last_flight = max(dep_time,na.rm=TRUE))

#2.5.2.
flights %>%
  group_by(dest) %>%
  summarize(n_carriers = n_distinct(carrier))

#2.5.3.
flights %>%
  group_by(dep_time < 500) %>%
  summarize(n_flights = n())

#2.5.4.
flights %>%
  group_by(year,month,day) %>%
  summarize(prop_flights = mean(arr_delay > 60,na.rm=TRUE))


match_metrics <- function(df1,df2,col1,col2,samplesize){
# df1 is the dataframe of the first concept (only first column will be used)
# df2 is the dataframe of the first concept  (only first column will be used)
# col1 is the column name from df1 to match
# col2 is column name from df12 to match
# samplesize is the sample size randomly selected from df1
library(stringdist)

if(samplesize < nrow(df1)) {
  idx<-sample(1:nrow(df1),samplesize)
  df1 <- df1[idx,]
  df1<-as.data.frame(df1)
}
if(ncol(df1) == 1){
	names(df1)[1]<-col1
}
cmd1<-paste("c1<-as.character(unique(df1$",col1,"))",sep="")
eval(parse(text=cmd1))

cmd2<-paste("d<-as.character(unique(df2$",col2,"))",sep="")
eval(parse(text=cmd2))

r <- data.frame(item=character(), match=character(),similarity=numeric(),appliedmethod = character(),stringsAsFactors=FALSE)
r<-best_match(r,c1,d,method="lv",q=1,p=0)
r<-best_match(r,c1,d,method="dl",q=1,p=0)
r<-best_match(r,c1,d,method="qgram",q=3,p=0)
r<-best_match(r,c1,d,method="cosine",q=3,p=0)
r<-best_match(r,c1,d,method="osa",q=1,p=0)
r<-best_match(r,c1,d,method="jw",q=1,p=0.1)
r<-best_match(r,c1,d,method="lcs",q=1,p=0)
r<-best_match(r,c1,d,method="soundex",q=1,p=0)
r<-best_match(r,c1,d,method="jaccard",q=3,p=0)
return(r)
}

best_match <- function(r,c1,d,method=method,q,p){
methods<-list()
methods[["lv"]]<-"Levenshtein"
methods[["dl"]]<-"Damerau-Levenshtein"
methods[["qgram"]]<-"q-gram"
methods[["cosine"]]<-"Cosine q-gram"
methods[["osa"]]<-"Optimal string aligment"
methods[["jw"]]<-"Jaro-Winker"
methods[["lcs"]]<-"Longest common substring"
methods[["jaccard"]]<-"Jaccard q-gram"
methods[["soundex"]]<-"Soundex"
n<-length(c1)
m<-stringdistmatrix(c1,d,method=method,q=q,p=p,weight=c(d=1,i=0.95,s=0.9,t=0.85))

j<-nrow(r)
for (i in 1:n){
  i.min<-min(m[i,],na.rm=TRUE)
  j<-j+1
  ind<-which(m[i,]== i.min)[1]
  sim<-stringsim(c1[i],d[ind],method=method,q=q,p=p)
  r[j,1]<-c1[i]
  r[j,2]<-d[ind]
  r[j,3]<-sim
  r[j,4]<-methods[[method]]
}
r$similarity<-round(r$similarity,2)
r<-r[order(r$item,-r$similarity,r$match,r$appliedmethod),]
return(r)
}


#  James Rekow

disconnectedSubgraphs = function(g, v, numSubgraphs, numSample = 100, maxIters = 100){

  #  ARGS: g - input graph
  #        v - number of vertices in the output graphs
  #        numSample - number of elements to keep at each stage of breadth-first search, in order to
  #                    speed up program and minimize memory usage
  #        maxIters - maximum number of attempts at creating the desired number of disconnected subgraphs
  #
  #  RETURNS: vList - a list of numSample disconnected subgraphs of g with v vertices, or NULL
  #                   if no such subgraphs exist. That is, each element of v is a vector of
  #                   vertices corresponding to a subgraph whose adjacency matrix is the
  #                   v x v zero matrix

  #  create adjacency matrix for connectivity graph
  adjMat = as.matrix(get.adjacency(g, type = "both"))

  #  get number of vertices in g
  numVertices = vcount(g)

  #  create a matrix whose columns are the unique pairs of indices of vertices in conGraph
  pairMat = combn(numVertices, 2)

  produceSubgraphs = function(x = NULL){

    #  ARGS:
    #
    #  RETURNS: vList - a list of at most numSample completely disconnected subgraphs. It may return
    #                   fewer than that if it didn't find that many on this attempt, or NULL if it
    #                   found no completely disconnected subgraphs on this attempt
    #
    #  NOTE: this function starts with a single vertex, and then performs the following algorithm:
    #        for each subgraph in vList (which have numCurrentV vertices), create a list of all
    #        subgraphs of conGraph that have numCurrentV + 1 vertices and include the given subgraph.
    #        Create a list that aggregates all of the new subgraphs corresponding to each current
    #        subgraph in vList, and set vList equal to this new list. Then remove all of the subgraphs
    #        in vList that are not completely disconnected. If there are no elements left in vList after
    #        this process, return NULL. Otherwise, randomly select numSample subgraphs from vList, with
    #        replacement, and discard the others. Increment numCurrentV by 1. Repeat until numCurrentV
    #        is equal to v.
    #
    #  NOTE: The above algorithm is similar to breadth first search modified to discard all but a
    #        fixed number of nodes at each step in order to make the problem tractable

    #  create a list of all pairs of vertices
    vList = lapply(as.list(1:choose(numVertices, 2)), function(i) pairMat[ , i])

    isDisconnected = function(vVec){

      #  ARGS: vVec - vector of vertices contained in subgraph, where it is known that vVec without
      #               it's last element forms a completely disconnected subgraph
      #
      #  RETURNS: TRUE/FALSE depending on whether or not the vertices in vVec form a completely
      #           disconnected subgraph

      #  number of vertices in vVec
      numV = length(vVec)

      #  create vector of vertices which are already known to form a completely disconnected subgraph
      disconnectedV = vVec[-numV]

      #  check whether there are any edges connecting the newest vertex to the previous disconnected
      #  vertices
      disconnected = !any(adjMat[ , vVec[numV]][disconnectedV] == 1)

      return(disconnected)

    } #  end isDisconnected function

    #  remove all vertex vectors which correspond to subgraphs containing at least one edge from vList
    vList = vList[unlist(lapply(vList, isDisconnected))]

    createNewVList = function(vList, numVertices){

      #  ARGS: vList - input vList
      #
      #  RETURNS: newVList - a list of all of the elements in vList with each element of 1:M not in
      #           a given vList appended to vList separately

      expandVVec = function(vVec, numVertices){

        #  create vector of potential vertices
        baseV = 1:numVertices

        #  select elements from baseV which are not already present in vVec
        #newV = baseV[-which(baseV %in% vVec)] - deprecated
        newV = baseV[-vVec]

        #  create a list of new vertex vectors, where each element is a vector that is vVec with one
        #  element of newV appended to it, and each element in newV corresponds to exactly one vector
        #  in this newly created list
        vAppendedList = lapply(as.list(newV), function(x) append(vVec, x))

        return(vAppendedList)

      } #  end expandVVec function

      #  create new list of vertex vectors
      newVList = unlist(lapply(vList, function(vVec) expandVVec(vVec = vVec,
                                                      numVertices = numVertices)), recursive = FALSE)

      return(newVList)

    } #  end createNewVList function

    #  return NULL if every pair of vertices has an edge between them (i.e. g is completely
    #  connected)
    if(length(vList) == 0){
      return(NULL)
    } #  end if

    #  track the number of vertices in each vector of vertices in vList
    numCurrentV = 2

    #  grow the size of the vertex vectors in vList iteratively
    while(numCurrentV < v){

      #  if there are no vectors in vList, return NULL
      if(length(vList) == 0){
        return(NULL)
      } #  end if

      #  append new values to each vector in vList
      vList = createNewVList(vList = vList, numVertices = numVertices)

      #  remove vectors from vList that correspond to subgraphs with at least one edge
      vList = vList[unlist(lapply(vList, isDisconnected))]

      #  if a value for numSample is specified, randomly select that many vectors from vList at each step
      #  the problem is computationally intractable without this step
      if(!is.null(numSample)){
        vList = sample(vList, numSample, replace = TRUE)
      } #  end if

      #  if there are no completely disconnected subgraphs in vList with numCurrentV vertices,
      #  return NULL
      if(length(vList) == 0){
        vList = NULL
        break
      } #  end if

      #  increment the number of vertices
      numCurrentV = numCurrentV + 1

    } #  end while loop

    return(vList)

  } #  end produceSubgraphs function

  #  list to store vertex vectors
  vList = list()

  #  count the number of iterations so the function can terminate if it iterates too many times
  iter = 0

  #  produce the vertex vectors for vList until the desired number of subgraphs have been created, or
  #  the number of iterations reaches maxIters
  while(length(vList) < numSubgraphs && iter <= maxIters){

    #  produce a new subgraph
    newSubs = produceSubgraphs()

    #  add new subgraph to vList
    vList = append(vList, newSubs)

    #  increment number of iterations
    iter = iter + 1

  } #  end while loop

  #  randomly select the desired number of vertex vectors from the created vList (which may
  #  be too long before this step)
  vList = sample(vList, numSubgraphs)

  return(vList)

} #  end disconnectedSubgraphs function


library(tibble)

x <- c(5,5,5,13,7,11,11,9,8,9)
y <- c(11,8,4,5,9,5,10,5,4,10)
data <- tibble(x, y)
# [Cruzeiro do Sul - Data Science] Comparação entre os conjuntos de dados

boxplot(data, main="Comparação entre os conjuntos 'x' e 'y'")


library(ggplot2)
library(tidyverse)

# Load data
setwd("./data/event_scores")
file_names <- dir()
data <- do.call(rbind, lapply(file_names, read.csv, header = FALSE))

setwd("../event_matchdata")
file_names <- dir()
kda_data <- do.call(rbind, lapply(file_names, read.csv, header = FALSE))

setwd("../event_scores_tagged")
file_names <- dir()
kda_stomps <- do.call(rbind, lapply(file_names, read.csv, header = FALSE))
kda_stomps$stomps <- ifelse(kda_stomps$V1 >= 13, # if bo1
  ifelse(kda_stomps$V1 - kda_stomps$V2 <= 3, FALSE, TRUE), #process a bo1
  ifelse(kda_stomps$V2 == 0, TRUE, FALSE)) # otherwise, process a bo3
kda_data$stomps <- kda_stomps$stomps
kda_data$col <- ifelse(kda_data$stomps == TRUE, "steelblue", "brown2")

# Sanity check just in case there's differences in the data you need to find
#kda_stomps$in_kda_data <- ifelse(kda_data$V1 == kda_stomps$V3, TRUE,
# FALSE)

# Competitive graph in general case
bo3 <- subset(data, V1 < 3)
bo3_stomps <- subset(bo3, V2 == 0)
bo3_close <- subset(bo3, V2 == 1)

stomps_vs_close <- data.frame(type = c("close", "stomps"),
                              number = c(nrow(bo3_close),
                                     c(nrow(bo3_stomps))))
p <- ggplot(data = stomps_vs_close, aes(x = type, y = number)) +
            geom_bar(stat = "identity", fill = "steelblue") + theme_minimal()

p + ggtitle("Competitive vs non-competitive matches") +
  theme(plot.title = element_text(hjust = 0.5))

# Histogram of bo1 win differentials
bo1 <- subset(data, V1 > 3)
bo1$diff <- bo1$V1 - bo1$V2
bo1_dist <- as.data.frame(table(bo1$diff))
bo1_dist <- bo1_dist %>% rename(Difference = Var1)
p <- ggplot(data = bo1_dist, aes(x = Difference, y = Freq)) +
            geom_bar(stat = "identity", fill = "steelblue") + theme_minimal()
p + ggtitle("Distribution of difference in score on match termination") +
  theme(plot.title = element_text(hjust = 0.5))

# Competitive graph in finals case
finals_data <- do.call(rbind, lapply(c("205.csv", "251.csv", "198.csv",
  "66.csv", "40.csv", "274.csv", "40.csv", "256.csv", "280.csv"),
  read.csv, header = FALSE))
finals_stomps <- subset(finals_data, V2 == 0)
finals_close <- subset(finals_data, V2 == 1)
stomps_vs_close <- data.frame(type = c("close", "stomps"),
                              number = c(nrow(finals_close),
                                     c(nrow(finals_stomps))))
p <- ggplot(data = stomps_vs_close, aes(x = type, y = number)) +
            geom_bar(stat = "identity", fill = "steelblue") + theme_minimal()

p + ggtitle("Competitive vs non-competitive matches in finals matches") +
  theme(plot.title = element_text(hjust = 0.5))

# kda analysis
kd_rat_win <- (kda_data$V2 / kda_data$V3)
a_rat_win <- (kda_data$V4 / kda_data$V5)
kda_rat_win <- ((kda_data$V2 + kda_data$V4) / (kda_data$V3 + kda_data$V5))
kd_rat_lose <- (kda_data$V3 / kda_data$V2)
a_rat_lose <- (kda_data$V5 / kda_data$V4)
kda_rat_lose <- ((kda_data$V3 + kda_data$V5) / (kda_data$V2 + kda_data$V4))

boxplot(kd_rat_win, a_rat_win, kda_rat_win, kd_rat_lose,
        a_rat_lose, kda_rat_lose, main = "Distribution of Teams' KDAs",
  xlab = "KDAs", ylab = "Ratios", notch = TRUE,
  col = (c("dodgerblue4", "deepskyblue2", "steelblue",
           "brown4", "brown2", "brown3")),
  names = c("Winning KD", "Winning Assist Ratio", "Winning KDA",
            "Losing KD", "Losing Assist Ratio", "Losing KDA"))

# A/D analysis
ad_rat_win <- (kda_data$V4 / kda_data$V3)
ad_rat_lose <- (kda_data$V5 / kda_data$V2)

boxplot(ad_rat_win, ad_rat_lose, main = "Distribution of Team Coordination",
  xlab = "A/D", ylab = "Ratio", notch = TRUE,
  col = (c("deepskyblue2", "brown2")),
  names = c("Winning Coordination", "Losing Coordination"))

# Does coordination track more with stomps than raw kills?
plot(kda_data$V2, kda_data$V3, main = "Winner KD Plot, Colored with Stomp(blue)/No stomp(red)",
   xlab = "Deaths", ylab = "Kills", pch = 19, col=kda_data$col)

plot(kda_data$V4, kda_data$V3, main = "Winner Coordination Plot, Colored with Stomp(blue)/No stomp(red)",
   xlab = "Deaths", ylab = "Assists", pch = 19, col=kda_data$col)
abline(h = 175, col="purple")

plot(kda_data$V5, kda_data$V2, main = "Loser Coordination Plot, Colored with Stomp(blue)/No stomp(red)",
   xlab = "Deaths", ylab = "Assists", pch = 19, col=kda_data$col)
segments(10, 83, 50, 83, col="purple")
segments(45, 180, 200, 285, col="purple")


library(shiny)
library(matrixcalc)
library(plotly)

ui <- fluidPage(
  titlePanel("Plug-in demo"),
  sidebarLayout(
    sidebarPanel(
      h3("The first class specs"),
      h6("Expected value, μ"),
      fluidRow(
        column(6,
               numericInput("mu11", value = 1.825, label = "μ1")
        ),
        column(6,
               numericInput("mu12", value = 1.825, label = "μ2")
        )
      ),
      h6("Covariance matrix, Σ"),
      fluidRow(
        column(6,
               numericInput("E11", value = 1.5, label = "Σ (1,1)")
        ),
        column(6,
               numericInput("E12", value = 0.25, label = "Σ (1,2)")
        )
      ),
      fluidRow(
        column(6,
               numericInput("E13", value = 0.25, label = "Σ (2,1)")
        ),
        column(6,
               numericInput("E14", value = 1.5, label = "Σ (2,2)")
        )
      ),
      textOutput("err"),

      h3("The second class specs"),
      h6("Expected value, μ"),
      fluidRow(
        column(6,
               numericInput("mu21", value = 4.57, label = "μ1")
        ),
        column(6,
               numericInput("mu22", value = 4.57, label = "μ2")
        )
      ),
      h6("Covariance matrix, Σ"),
      fluidRow(
        column(6,
               numericInput("E21", value = 2.36, label = "Σ (1,1)")
        ),
        column(6,
               numericInput("E22", value = 0.11, label = "Σ (1,2)")
        )
      ),
      fluidRow(
        column(6,
               numericInput("E23", value = 0.11, label = "Σ (2,1)")
        ),
        column(6,
               numericInput("E24", value = 2.36, label = "Σ (2,2)")
        )
      ),
      sliderInput("ratio", min = 0, max = 100, value = 35, label = "Class ratio"),
      h6("Lambdas, λ"),
      fluidRow(
        column(6,
               numericInput("la1", value = 1, label = "λ1")
        ),
        column(6,
               numericInput("la2", value = 1, label = "λ2")
        )
      )
    ),
    mainPanel(
      fluidRow(
        column(6, plotlyOutput(outputId = "p1")),
        column(6, plotlyOutput(outputId = "p2"))
      )
    )
  )
)


# Heat map data for severity Mid to higher severity"

# Setting
```{r}

# reset
rm(list=ls(all=TRUE))

# library
library(data.table)
library(dplyr)
library(psych)
library(caret)
library(gam)
library(RSNNS)
library(e1071)
library(ranger)
library(randomForest)
library(xgboost)

# Directory
setwd(".")

# Get data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

# Train Test
Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible
Data_test <- data.frame(Data_test)

```

# define functions
```{r}

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 2)
	return(RMSE)
}

MAE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAE <- Dif %>% abs() %>% mean()	%>% round(., 2)
	return(MAE)
}

MAPE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAPE <- mean(abs(Dif/Obs)*100) %>% round(., 2)
	return(MAPE)
}

```

# data for heatmap
```{r}

# load models
Model <- readRDS("gamSpline_temp.rds")

# get predicted values
Data_train$Pred <- predict(Model, Data_train)
Data_train$Pred <- ifelse(Data_train$Pred < 0, 0, Data_train$Pred)

# get predicted values
Data_test$Pred <- predict(Model, Data_test)
Data_test$Pred <- ifelse(Data_test$Pred < 0, 0, Data_test$Pred)

########
Data_test %>%
group_by(ID) %>%
summarise(Obs = sum(SeverityHigherMid), Pred = sum(Pred)) %>%
data.table()%>%
print() %>%
fwrite(., "Out_heatmap_sever.csv")

```


#' xpose
#'
#' Transpose a matrix-like thing. In addition to supporting
#' the new classes, this method is slightly more efficient
#' than R's \code{t()} for matrix types.
#'
#' @details
#' For a matrix input, we use a block algorithm.
#'
#' @param x
#' A banded matrix.
#'
#' @return
#' A matrix-like object of the same type as the input.
#'
#' @keywords LinAlg
#' @export
xpose <- function(x) UseMethod("xpose", x)

xpose_err <- function(x)
{
  if (class(x) == "ZeroMat" || class(x) == "DiagMat" || class(x) == "SymMat")
    stop(paste("a", class(x), "matrix is its own transpose"))
}

#' @export
xpose.BandMat <- xpose_err

#' @rdname xpose
xpose.SymMat <- xpose_err

#' @export
xpose.GenBandMat <- function(x)
{
  dim <- getdim(x)
  k <- kdim(x)

  out <- .Call(R_xpose_band, getData(x), dim[1L], dim[2L], k[1L], k[2L])
  genbandmat(out, rev(dim), k[2L], k[1L])
}

#' @export
xpose.matrix <- function(x)
{
  if (!is.numeric(x) && !is.logical(x))
    stop("argument 'x' must contain numeric, integer, or logical data")

  dims <- dim(x)
  if (any(dims == 1L))
  {
    dim(x) <- rev(dims)
    return(x)
  }

  .Call(R_xpose_full, x)
}


# train a random forest on original or transformed data

library( randomForest )
library( caTools )

ntrees = 100

# change the file names
train_file = 'data/train.csv'
validation_file = 'data/test.csv'
label_index = 1

train <- read.csv( train_file, header = F )
validation <- read.csv( validation_file, header = F )

x_train = train[, -label_index]
y_train = train[, label_index]

x_validation = validation[, -label_index]
y_validation = validation[, label_index]

###

rf <- randomForest( x_train, as.factor( y_train ), ntree = ntrees, do.trace = 1 )

p <- predict( rf, x_validation, type = 'prob' )
probs =  p[,2]

p_binary <- predict( rf, validation[,-1] )

accuracy = sum( p_binary == y_validation ) / length( p_binary )
cat( "accuracy:", accuracy, "\n" )

auc = colAUC( probs, ( y_validation + 1 ) / 2 )
auc = auc[1]
cat( "auc:", auc, "\n" )


data <- read.delim("/home/roland/Workspace/adventofcode-2021/01.sonar-sweep/input.txt", header = FALSE, sep = ",")[,1]

n <- 0
for (x in 2:length(data)) {
    if (data[x - 1] < data[x]) {
        n <- n + 1
    }
}

print(paste("Result:", n))


context("Checking shuffling function")

# Packages I depend on
suppressMessages({
  library(dplyr, quietly = TRUE)
  library(magrittr, quietly = TRUE)
})

# Function to generate random set of bites
gen_bites <- function(nrows = 10, nids = 2) {
  data.frame(
    times = cumsum(sample.int(100, nrows, TRUE)),
    ids   = sample.int(nids, nrows, TRUE)
  )
}

# Computing the interval sets
get_intervals <- function(x) {
  x %>%
    `colnames<-`(c("times", "ids")) %>%
    group_by(ids) %>%
    arrange(times) %>%
    mutate(
      interval  = times - lag(times)
      ) %>%
    split(f=.$ids) %>%
    lapply("[[", "interval") %>%
    lapply(sort)
}

test_that("it works", {

  # Generating data
  set.seed(6665)
  bites0 <- gen_bites(nrows = 100)
  bites1 <- shuffle_bites(bites0)

  ans0 <- get_intervals(bites0)
  ans1 <- get_intervals(bites1)

  # Intervals are preserved
  expect_equal(ans0, ans1)

  # Variables are different (at least one)
  expect_true(any(bites0$times != bites1[,1]))
  expect_true(any(bites0$ids != bites1[,2]))

})

# Checking uniformity ----------------------------------------------------------

# Function to encode the shuffle
shuffle_wrap <- function(dat) {
  paste0(shuffle_bites(dat)[,1], collapse="")
}

test_that("Is uniform", {

  # Deterministic data
  dat <- cbind(
    time = c(0, 1, 3, 6),
    ids  = rep(1, 4)
  )

  n <- 5e4
  ans <- replicate(n, shuffle_wrap(dat))
  ans <- table(ans)/n

  expect_equivalent(
    as.vector(ans), rep(1/6, 6), tolerance = .005)
})

test_that("Is uniform 2", {

  # Deterministic data
  dat <- cbind(
    time = c(0, 1, 3, 6, 10, 11),
    ids  = c(1, 1, 2, 1, 2, 2)
  )

  n <- 5e4
  ans <- replicate(n, shuffle_wrap(dat))
  ans <- table(ans)/n

  expect_equivalent(
    as.vector(ans), rep(1/4, 4), tolerance = .005)
})


# x = read.table("/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Experiments/ZubairAbid_20171076_prp_20200924.txt")
x = read.table("/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Experiments/prp-r/shelly.txt")

RT1 = x[,8]
RT2 = x[,9]
correct = x[,10]==1 & x[,11]==1
soa = x[,7]
# RT1 = RT1 - soa
# RT2 = RT2 - soa

RT2 = RT2 + RT1 - soa

soas = sort(unique(soa))
realdata = x[,1]==2

rt1 = numeric(4)
rt2 = numeric(4)

#rt1[1]=median( RT1[ correct & realdata & soa==soas[1] ] )
#rt1[2]=median( RT1[ correct & realdata & soa==soas[2] ] )
#rt1[3]=median( RT1[ correct & realdata & soa==soas[3] ] )
#rt1[4]=median( RT1[ correct & realdata & soa==soas[4] ] )
rt1[1]=mean( RT1[ correct & realdata & soa==soas[1] ] )
rt1[2]=mean( RT1[ correct & realdata & soa==soas[2] ] )
rt1[3]=mean( RT1[ correct & realdata & soa==soas[3] ] )
rt1[4]=mean( RT1[ correct & realdata & soa==soas[4] ] )

#rt2[1]=median( RT2[ correct & realdata & soa==soas[1] ] )
#rt2[2]=median( RT2[ correct & realdata & soa==soas[2] ] )
#rt2[3]=median( RT2[ correct & realdata & soa==soas[3] ] )
#rt2[4]=median( RT2[ correct & realdata & soa==soas[4] ] )
rt2[1]=mean( RT2[ correct & realdata & soa==soas[1] ] )
rt2[2]=mean( RT2[ correct & realdata & soa==soas[2] ] )
rt2[3]=mean( RT2[ correct & realdata & soa==soas[3] ] )
rt2[4]=mean( RT2[ correct & realdata & soa==soas[4] ] )

r=c(min(c(rt1,rt2)),max(c(rt1,rt2)))
plot( soas, rt1 , col="green" ,ylim=r,type="b",las=1)
lines( soas, rt2 , ylim=r,col="blue",type="b")
legend("topright",c("RT1","RT2"),fill=c("green","blue"))

print( RT2[ correct & realdata & soa==soas[4]] )


summary_large=function(x) {data.frame(c(pastecs::stat.desc(as.numeric(x)),
                                        data.frame(skew=as.numeric(psych::describe((x)))[11],
                                                   kurtosis=as.numeric(psych::describe(x))[12])))
}

firstup <- function(x) {
  substr(x, 1, 1) <- toupper(substr(x, 1, 1))
  x
}

normFunc <- function(x){(x-mean(x, na.rm = T))/sd(x, na.rm = T)}
range01 <- function(x){(x-min(x,na.rm=T))/(max(x,na.rm=T)-min(x,na.rm=T))}
conta_dati=function(x) length(c(which(x$meanTot>0),which(x$Concentration>0)))
is.nan.data.frame <- function(x){do.call(cbind, lapply(x, is.nan))}


#' RSI_index
#'
#' Calculates Relative Strain Index.
#'
#' @param t   numeric Air temperature in degC.
#' @param rh  numeric Relative humidity in percentage.
#' @return RSI index
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references  Lee  DHK  &  Henschel A,1963, Evaluation  of  thermal environment  in  shelters.Rep.  TR 8,  Div.  Occup.  Health,US Dept. Health, Education and Welfare.
#' @export
#'
#'
#'
#'

RSI_index=function(t,rh) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=RSI_index(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


################################################################################
# library(glmnet)

RegressTestPredictionsTrain<- function(method.list,train.name="train",test.name="test") {

	# Calculates ridge regression weights based on the test prediction files made
	#	by other methods, ie, regresses test predictions on the truth
	#	(Note: GetPredictionData function is in the avg_predictions file)
	#
	# Args:
	#	train.name: base name of training data from which splits are created
	# 	method.list: a list, where each element is a list of method args used for
	#   	each prediction to be averaged and the name of each element is the  method
	#
	# Returns:
	#	  A ridge regression model
	#
	# Example usage:
	if(FALSE) {
		features <- c("static","alsfrs","fvc","svc","vital")
		slope.features <- c("alsfrs","fvc","svc","vital")

		glm.args <- list(test.name="test",R=1,pls=FALSE,prune=FALSE,std=FALSE,
						features=features,slope.features=slope.features)
		rf.args <- c(corr.bias=FALSE, glm.args)
		gbm.args <- glm.args
		bag.args <- glm.args
		bart.args <- glm.args
		mblack.args <- glm.args
		mglm.args <- glm.args

		bart10.args <- glm.args; bart10.args$R = 10

		glm.prune.args <- glm.args; glm.prune.args$prune = TRUE
		rf.prune.args <- rf.args; rf.prune.args$prune = TRUE
		gbm.prune.args <- glm.prune.args
		bag.prune.args <- glm.prune.args
		mblack.prune.args <- glm.prune.args
		mglm.prune.args <- glm.prune.args

		method.list<-list(
			"BartTrain"=bart10.args,
			#"BaggingTrain"=bag.args,
			"BartTrain"=bart.args,
			#"GbmTrain"=gbm.args,
			"GlmnetTrain"=glm.args,
			"MboostBlackBoostTrain"=mblack.args,
			"MboostGlmBoostTrain"=mglm.args,
			"RandomForestTrain"=rf.args,
			"GlmnetTrain"=glm.prune.args,
			"RandomForestTrain"=rf.prune.args,
			"MboostBlackBoostTrain"=mblack.prune.args,
			"MboostGlmBoostTrain"=mglm.prune.args
			#"GbmTrain"=gbm.prune.args,
			#"BaggingTrain"=bag.prune.args,
		)

		model<-RegressTestPredictionsTrain(method.list=method.list)
		predictions<-model("test")
	}
	#######################################################################

    # Get prediction data for each method
    num.methods <- length(method.list)
	train.preds<-sapply(1:num.methods,function(i,train.name,test.name,method.list)
		GetPredictionData(names(method.list)[i],train.name,test.name,method.list[i:num.methods]),
		train.name,test.name,method.list)
	colnames(train.preds) <- names(method.list)

    # Get subject ids in same order
    subject.ids<-do.call(rbind,lapply(test.name,GetSubjectIds))

    # Put together prediction data with subject ids
    train.preds<-cbind(subject.ids,train.preds)

    # Add interactions
    # for (i in 2:num.methods) {
    	# for (j in (i+1):(num.methods+1)) {
    		# inter<-train.preds[,i]*train.preds[,j]
	    	# train.preds<-cbind(train.preds,inter)
		# }
    # }

    # Sort by subject id
    train.preds<-train.preds[order(train.preds$subject.id),]

    # Convert to numeric matrix
	train.preds <- as.matrix(train.preds)
	mode(train.preds) <- "numeric"

    # Get TEST targets
    target<-Slopes(GetAlsfrsData(test.name),3,12,"f")

    # Ridge regression
    cv.res <- cv.glmnet(as.matrix(train.preds[,-1]), target, lambda=seq(0,1,.001), alpha=0, nfolds=nrow(train.preds))
    #cv.res <- cv.glmnet(as.matrix(train.preds[,-1]), target, alpha=0, nfolds=nrow(train.preds))

    print(paste("Internal CV error:",sqrt(min(cv.res$cvm))))
    err <- Rmsd(target, predict(cv.res$glmnet.fit,as.matrix(train.preds[,-1]),s=cv.res$lambda.min))
    print(paste("Regression Error on test data:",err))
    print(coef(cv.res))
    print(paste("lambda:",cv.res$lambda.min))

	RegressTestPredictionsPredict<- function(test.name="test",save.preds=TRUE) {
		#	Makes predictions based on a ridge regression on predictions from
		#	other methods
		#
		# Args:
		#	test.name: base name of test data
		# 	save.preds: saves to file if TRUE
		#
		# Returns:
		#	 A matrix of subject ids and corresponding predictions
		#
		# Side effects:
		# 	Writes to a file in the predictions folder

		# Get test prediction data
		test.preds<-sapply(1:num.methods,function(i,train.name,test.name,method.list)
			GetPredictionData(names(method.list)[i],train.name,test.name,method.list[i:num.methods]),
			train.name,test.name,method.list)

		# Add interactions
	    for (i in 2:num.methods) {
    		for (j in (i+1):(num.methods+1)) {
    			inter<-test.preds[,i]*test.preds[,j]
	    		test.preds<-cbind(test.preds,inter)
			}
    	}

    	# Convert to numeric matrix
    	test.preds <- as.matrix(test.preds)
		mode(test.preds) <- "numeric"

       	# Make test predictions
       	predictions<-predict(cv.res$glmnet.fit,test.preds,s=cv.res$lambda.min)

		# Get subject ids for test set
		subject.ids<-GetSubjectIds(test.name)

		predictions <- cbind(subject.ids,predictions)

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("RegressTestPredictionTrain",train.name,test.name,method.list)
			WritePredictions(predictions, out.file)
		}

		return(predictions)
	}

	return(RegressTestPredictionsPredict)
}


# Multifractal analysis of multispecies spatial distributions - Anderson-Darling test

#I use Dq from the simple spatial patterns with uniform and logseries SAD (DqT)

load(".RData")

simul  <- F # variable to perform or not the simulations

oldcd <-getwd()
source("R/Neutral_fun.r")

# Set the location of the binary
#
mfBin <- "~/Dropbox/cpp/SpatialAnalysis/mfsba" # /mfSBA /multiSpeciesSBA

require(pander)
panderOptions('table.split.table',Inf)
panderOptions("table.style", "multiline")
options("scipen"=100, "digits"=4)
knitr::opts_chunk$set(comment = NA)

# Define the function

# test the permutation with Anderson-Darling statistic for Dq
# using the global variable DqT
#
test_ADPerm <-function(type="DqSRS",nsp=8,nsp1=64,maxq=24){

  require(ggplot2)
  require(kSamples)
  require(plyr)
  require(dplyr)

  # select 1 set for comparison
  #
  Dq1<- filter(DqT,Side==256,NumSp==nsp,SAD=="Logseries",Type==type,abs(q)<=maxq) %>%
        group_by(SAD,Type,q) %>% summarize(SD.Dq=sd(Dq),Dq=mean(Dq),count=n(),Curve=paste(type,nsp))%>%
        select(Curve,Dq,SD.Dq,q)

  # Change location add a constant

  Dq2 <- mutate(Dq1,Dq=Dq+mean(Dq)*0.01,Curve=paste(type,nsp,"+ 0.1"))

  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() +  ggtitle("Add a constant")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  # Delete rows with uneven q

  Dq2 <- filter(Dq1,(q%%2)==0) %>% mutate(Curve=paste(type,nsp," even"))

  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Only even q")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  ## small differences in shape but same endings
  #
  # first stretch

  p1 <- 3
  p2 <- nrow(Dq1)-2
  q1 <- Dq1$q[p1]
  q2 <- Dq1$q[p2]
  Dq2 <- filter(Dq1,(q<q1 | q>q2) | q==0)

  sp <-splinefun(Dq2$q,Dq2$Dq)
  Dq2 <- mutate(Dq1,Dq=sp(q),Curve=paste(type,nsp," spline")) #%>% filter(abs
  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Spline with similar endings")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  ## linear shape with same ending
  #
  p1 <- 4
  p2 <- nrow(Dq1)-3
  q1 <- Dq1$q[p1]
  q2 <- Dq1$q[p2]
  D1 <- Dq1$Dq[p1]
  D2 <- Dq1$Dq[p2]

  y <- c(Dq1$Dq[1:(p1-1)],D1 + (D2-D1)/(q2-q1)*(Dq1$q[p1:p2]-q1),Dq1$Dq[(p2+1):nrow(Dq1)])

  Dq2 <- mutate(Dq1,Dq=y,Curve=paste(type,nsp,"linear"))

  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Linear with similar endings")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  ## Diffferent no. species
  #

  Dq2<- filter(DqT,Side==256,NumSp==nsp1,SAD=="Logseries",Type==type,abs(q)<=maxq) %>%
        group_by(SAD,Type,q) %>% summarize(SD.Dq=sd(Dq),Dq=mean(Dq),count=n(),Curve=paste(type,nsp1))%>%
        select(Curve,Dq,SD.Dq,q)

  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Diffferent no. species")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  #
  #
  type1 <- paste0("rnz",type)
  Dq2<- filter(DqT,Side==256,NumSp==nsp,SAD=="Logseries",Type==type1,abs(q)<=maxq) %>%
        group_by(SAD,Type,q) %>% summarize(SD.Dq=sd(Dq),Dq=mean(Dq),count=n(),Curve=paste(type,nsp," rnz")) %>%
        select(Curve,Dq,SD.Dq,q)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Randomized spatial pattern")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  #
  #

  Dq2<- filter(DqT,Side==256,NumSp==nsp,SAD=="Logseries",Type==type1,abs(q)<=maxq) %>%
        group_by(SAD,Type,q) %>% summarize(SD.Dq=sd(Dq),Dq=mean(Dq),count=n(),Curve=paste(unique(Type),unique(NumSp)," sample"))%>%
        select(Curve,Dq,SD.Dq,q)

  Dq2 <- mutate(Dq2,Dq=rnorm(nrow(Dq2),mean=Dq,sd=SD.Dq))

  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Sample from different Dq")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

  #
  #

  Dq2 <- mutate(Dq1,Dq=rnorm(nrow(Dq1),mean=Dq,sd=SD.Dq),Curve=paste(type,nsp," sample"))

  g <- ggplot(rbind(Dq1,Dq2),aes(x=q,y=Dq,colour=Curve)) + theme_bw()+ geom_point() + ggtitle("Sample from the same Dq")
  print(g)
  g <- ggplot(rbind(Dq1,Dq2),aes(x=Dq,colour=Curve))+theme_bw()+stat_ecdf()
  print(g)

  ad <- ad.test(Dq1$Dq,Dq2$Dq,method="simul")
  print(ad)

}

# Test Anderson with 8 sp

test_ADPerm("DqSRS",8,256)

# Test Anderson with 64 sp

test_ADPerm("DqSRS",64,256)

# Test Anderson with 64 sp

test_ADPerm("DqSAD",64,256)


library(jsonlite)
library(ggplot2)
library(zoo)
library(readr)

library(colorspace)
library(gridExtra)

library(plotly)
library(htmlwidgets)

library(sf)
sf_use_s2(FALSE)

library(lubridate)
library(plyr)

library(dplyr)

library(tidyr)

library(reshape2)

Sys.Date()

library("scales")
Sys.setlocale("LC_TIME", "hr_HR.UTF-8")

# get last_date_
load('data/latest/last_date_.Rda')

# get age data
json_data <- fromJSON('data/latest/last_data_po_osobama.json')

step <- 5
n <- 574

population_by_age <- read.csv(file = 'data/cro_population_by_age.csv')

json_data <- json_data %>%  mutate(dob = ifelse(dob < 1901, NA, dob))

json_data$Datum <- as.Date(json_data$Datum, format="%Y-%m-%d")

min_date = min(json_data$Datum)
max_date = max(json_data$Datum)

json_data <- json_data[order(json_data$Datum),]

json_data$dob <- as.Date(paste0(json_data$dob, '-01-01'), format="%Y-%m-%d")

json_data$age <- round(time_length(difftime(json_data$Datum, json_data$dob), "years"))

json_data$age_group <- findInterval(json_data$age, seq(0, 85, by=step))

labels <- paste0(seq(0, 85, by=step), '-', seq(step - 1, 85, by=step), sep='')

labels[length(labels)] = '85+'

counties <- unique(json_data[c("Zupanija")])

f <- list(size = 13, color = "black")

p <- list()
a <- list()
i <-22 # Hrvatska total

current_county_data <- json_data

json_d <- current_county_data %>% group_by(Datum, age_group) %>% tally()

age_reshaped <- pivot_wider(json_d, names_from = age_group, values_from = n) %>%
  mutate_at(vars(-("Datum")), ~replace(., is.na(.), 0))

missing_cols <- setdiff(as.character(c(1:length(labels))), names(age_reshaped))

age_reshaped[missing_cols] <- 0

age_reshaped <- age_reshaped[c('Datum', as.character(1:length(labels)))]

# add missing dates
missing_rows <- as.Date(setdiff(seq.Date(min_date, max_date, by="day"), age_reshaped$Datum))
missing_data <- data.frame(missing_rows)
colnames(missing_data)[1] <- "Datum"

age_reshaped <- rbind.fill(age_reshaped, missing_data)
age_reshaped[is.na(age_reshaped)] <- 0

# sort by date
age_reshaped <- age_reshaped[order(age_reshaped$Datum),]

# calc 7 day sums
age_reshaped_sum7 <- as.data.frame(rollapply(age_reshaped[, names(age_reshaped) != "Datum"], 7, sum, fill=0, align="right"))

current_population <-c(population_by_age[1:nrow(population_by_age) - 1, c(i + 1)])

age_reshaped_sum7[, 1:ncol(age_reshaped_sum7)] <- sweep(age_reshaped_sum7[, 1:ncol(age_reshaped_sum7)], 2, current_population / 100000, `/`)
#
# change column names to age groups
colnames(age_reshaped_sum7)[1:length(labels)] <- labels

age_reshaped_sum7$Datum <- age_reshaped$Datum

data_to_plot <- age_reshaped_sum7 # tail(age_reshaped_sum7, n=n)

d <- melt(data_to_plot, id.vars="Datum")

colnames(d)[2:3] <- c('Dobna_skupina', 'Broj_zadnjih_7_data')

data_to_plot

d

library(tidyverse)

for (j in seq(0, difftime(Sys.Date() - 3, as.Date('2021-08-01'), units = c("days")))) {
  print(j)
  current_date <- as.Date('2021-08-01') + days(j)

  prev_date  = as.Date(current_date) - days(6)

  current_day <- data_to_plot[data_to_plot$Datum <= current_date & data_to_plot$Datum >= prev_date, ]

  cd <- melt(current_day, id.vars="Datum")

  p <- ggplot() +
    geom_point(data=cd[cd$Datum!=max(cd$Datum), ], aes(x=variable, y=value), colour='gray', size=0.8) +
    geom_point(data=cd[cd$Datum==max(cd$Datum), ], aes(x=variable, y=value), size=2) +
    ylab('Broj slučajeva na 100k stanovnika (ukupno u 7 dana)') +
    xlab('Dobna skupina') +
    ylim(0, 2500) +
    labs(title = 'Kretanje broja COVID-19 slučajeva na 100 tisuća stanovnika po dobnim skupinama u Hrvatskoj',
         subtitle=paste(format(as.Date(current_date), "%d.%m.%Y."), 'Crna točka: broj slučajeva u 7 dana do prikazanog datuma, sive točke: sedmodnevni broj slučajeva za 6 dana ranije.'),
         caption = 'Izvori podataka: koronavirus.hr (broj slučajeva), dzs.hr (broj stanovnika po dobnim skupinama, podaci iz 2019.). Autor: Petar Palašek. Inspirirano animacijom: @ProfColinDavis') +
    theme_minimal()
  p

  ggsave(paste('img/anim_dots/anim_', str_pad(j, 6, pad = "0"), sep = '', '.png'),
         plot = p, dpi=300, width=250, height=150, units="mm",
         bg = "white")
}

for (k in seq(40)) {
  ggsave(paste('img/anim_dots/anim_', str_pad(j + k, 6, pad = "0"), sep = '', '.png'),
         plot = p, dpi=300, width=250, height=150, units="mm",
         bg = "white")
}

Sys.setenv(PATH=paste(Sys.getenv("PATH"), "/home/pero/.cargo/bin/", sep=":"))
system(paste("cd img/anim_dots && gifski -o anim_aug_1200.gif anim*.png --width 1200 --fps 8 && cp anim_aug_1200.gif ../", last_date_, "anim_aug_1200.gif", sep=""))


for (i in c(1:100)){
  output = NULL
  flag = TRUE
  if (i %% 3 == 0)  {
    output = cbind(output, "Fizz")
    flag = FALSE
  }
  if (i %% 5 == 0)  {
    output = cbind(output, "Buzz")
    flag = FALSE
  }
  if (flag) {
    output = toString(i)
  }
  cat(output, sep = "\n")
}


runlengthencoding <- function(x)
{
   splitx <- unlist(strsplit(input, ""))
   rlex <- rle(splitx)
   paste(with(rlex, as.vector(rbind(lengths, values))), collapse="")
}

input <- "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"
runlengthencoding(input)


//------------------------------
//
// Write table of true hit resolutions, pull width, and efficiencies from DQM files produced in local mode
//
// Usage:
// .x writeSummaryTable.r("inputFile.root",doEff,doRes,doPull)
//
// Author: N. Amapane
//
//------------------------------
#include <iomanip>

void writeSummaryTable(){
  cout << endl << "Usage: .x writeSummaryTable.r(\"inputFile.root\",doEff,doEffab,doRes,doResab,doPull)" << endl << endl;
}

void writeSummaryTable(TString filename, bool doEff=true, bool doEffab = true, bool doRes=true, bool doResab = true, bool doPull=true,bool doPullabxy=true, bool doSegRes=true, bool doNSeg= true, bool doPar = false) {

  //----------------------------------------------------------------------
  // Configurable options

  // Interval for the fit of residual distributions
  float nsigma = 2.;

  //----------------------------------------------------------------------

  if (! TString(gSystem->GetLibraries()).Contains("Histograms_h")) {
    gROOT->LoadMacro("$CMSSW_BASE/src/Validation/DTRecHits/test/Histograms.h+");
    gROOT->LoadMacro("macros.C");
    gROOT->LoadMacro("ranges.C");
  }

  float cmToMicron = 10000.;

  TFile *file = new TFile(filename);

  TString table = filename.Replace(filename.Length()-5,5,"_summary.txt");
  ofstream f(table,ios_base::out);
  f << fixed;
  f << "# W St sec SL effS1RPhi effS3RPhi effSeg resHit pullHit meanAngle  sigmaAngle meanSegPos sigmaSegPos" << endl;

  // All sectors are collapsed together as of now
  int smin = 0;
  int smax = 0;

  for (int wheel = -2; wheel<3; ++wheel) {
    for (int station =1; station<=4; ++station) {
      for (int sector = smin; sector<=smax; ++sector) {

	if (station!=4 && sector>12) continue;

	double stheta = -1.;
	double sphi = -1.;
	double ptheta = -1.;
	double pphi = -1.;
	double salpha_res = -1.;
	double sbeta_res = -1.;
	double malpha_res = -1.;
	double mbeta_res = -1.;
	double salpha_pull = -1.;
	double sbeta_pull = -1.;
	double malpha_pull = -1.;
	double mbeta_pull = -1.;
	double sx = -1.;
	double sy = -1.;
	double mx = -1.;
	double my = -1.;
	double sx_pull = -1.;
	double sy_pull = -1.;
	double mx_pull = -1.;
	double my_pull = -1.;

	float effS1RPhi=0.;
	float effS3RPhi=0.;
	float effS1RZ=0.;
	float effS3RZ=0.;
	float effSeg = 0;

	HRes1DHit *hResPhi1  = new HRes1DHit(file, wheel, station, 1, "S3");
	HRes1DHit *hResTheta = new HRes1DHit(file, wheel, station, 2, "S3");

	HEff1DHit* hEffS1RPhi= new HEff1DHit(file, wheel, station, 1, "S1");
	HEff1DHit* hEffS3RPhi= new HEff1DHit(file, wheel, station, 1, "S3");
	HEff1DHit* hEffS1RZ=0;
	HEff1DHit* hEffS3RZ=0;

	HRes4DHit* hRes4D= new HRes4DHit(file, wheel, station, 0);
	HEff4DHit* hEff4D = new HEff4DHit(file, wheel, station, 0);

	if (station!=4) {
	  hEffS1RZ=   new HEff1DHit(file, wheel, station, 2, "S1");
	  hEffS3RZ=   new HEff1DHit(file, wheel, station, 2, "S3");
	}

	TCanvas c;

	//--- Hit efficiency
	if (doEff) {
	  if (station!=4) {
	    effS1RZ = hEffS1RZ->hDistRecHit->Integral()/hEffS1RZ->hDistMuSimHit->Integral();
	    effS3RZ = hEffS3RZ->hDistRecHit->Integral()/hEffS3RZ->hDistMuSimHit->Integral();
	  }
	  effS1RPhi = hEffS1RPhi->hDistRecHit->Integral()/hEffS1RPhi->hDistMuSimHit->Integral();
	  effS3RPhi = hEffS3RPhi->hDistRecHit->Integral()/hEffS3RPhi->hDistMuSimHit->Integral();

	  cout << " " << wheel << " " << station << " " << sector <<  " effPhi: " << effS1RPhi << " " << effS3RPhi;
	  if (station!=4) cout <<  " effZ: " << effS1RZ << " " << effS3RZ;
	  cout << endl;
	}

	//--- Segment efficiency
	if (doEffab) {
	  if (station!=4) {

	    effSeg = hEff4D->hBetaRecHit->Integral()/hEff4D->hBetaSimSegm->Integral();

	    cout << " " << wheel << " " << station << " " << sector <<  " effSeg: " << effSeg << endl;

	  }
	}

	//--- Hit resolution
	if (doRes) {
	  if (station!=4) {
	    TH1F* tmpTheta = (TH1F*) hResTheta->hRes->Clone("tmpTheta");
	    tmpTheta->Rebin(2);
	    TF1* ftheta = drawGFit(tmpTheta, nsigma, -2. , 2.);
	    stheta = ftheta->GetParameter("Sigma");
	  }
	  TH1F* tmpPhi = (TH1F*) hResPhi1->hRes->Clone("tmpPhi");
	  tmpPhi->Rebin(2);
	  TF1* fphi = drawGFit(tmpPhi, nsigma, -2. , 2. );
	  sphi = fphi->GetParameter("Sigma");

	  cout << " " << wheel << " " << station << " " << sector  <<  " sphi: " << sphi;
	  if (station!=4) cout  << " stheta: " << stheta ;
	  cout << endl;
	}

	//--- Hit pull
	if (doPull) {
	  if (station!=4) {
	    TH1F* tmpTheta = (TH1F*) hResTheta->hPull->Clone("tmpTheta");
	    TF1* ftheta = drawGFit(tmpTheta, nsigma, -2. , 2.);
	    ptheta = ftheta->GetParameter("Sigma");
	  }
	  TH1F* tmpPhi = (TH1F*) hResPhi1->hPull->Clone("tmpPhi");
	  TF1* fphi = drawGFit(tmpPhi, nsigma, -2. , 2. );
	  pphi = fphi->GetParameter("Sigma");

	  cout << " " << wheel << " " << station << " " << sector
	       <<  " pphi: " << pphi;
	  if (station!=4) {
	    cout  << " ptheta: " << ptheta ;
	  }
	  cout << endl;
	}

	//--- Segment position resolution
	if (doSegRes) {
	  if (station!=4) {
	    TH1F* tmpY = (TH1F*) hRes4D->hResYRZ->Clone("tmpY");
	    TF1* fy = drawGFit(tmpY, nsigma, -2. , 2. );
	    sy = fy->GetParameter("Sigma");
	    my = fy->GetParameter("Mean");
	  }

	  TH1F* tmpX = (TH1F*) hRes4D->hResX->Clone("tmpX");
	  TF1* fx = drawGFit(tmpX, nsigma, -2. , 2.);
	  sx = fx->GetParameter("Sigma");
	  mx = fx->GetParameter("Mean");
	}

	//--- Segment angle resolution
	if (doResab) {
	  if (station!=4) {
	    TH1F* tmpBeta = (TH1F*) hRes4D->hResBeta->Clone("tmpBeta");
	    tmpBeta->Rebin(2);
	    TF1* fbeta = drawGFit(tmpBeta, nsigma, -2. , 2.);
	    sbeta_res = fbeta->GetParameter("Sigma");
	    mbeta_res = fbeta->GetParameter("Mean");
	  }

	  TH1F* tmpAlpha = (TH1F*) hRes4D->hResAlpha->Clone("tmpAlpha");
	  // tmpAlpha->Rebin(2);
	  TF1* falpha = drawGFit(tmpAlpha, nsigma, -2. , 2. );
	  salpha_res = falpha->GetParameter("Sigma");
	  malpha_res = falpha->GetParameter("Mean");

	  cout << " " << wheel << " " << station << " " << sector  <<  " salpha_res: " << salpha_res  << " malpha_res: " << malpha_res;
	  cout  << " sbeta_res: " << sbeta_res  << " mbeta_res: " << mbeta_res;
	  cout << endl;

	}

	// Segment angle pull
	if (doPullabxy) {
	  if (station!=4) {
	    TH1F* tmpBeta = (TH1F*) hRes4D->hPullBetaRZ->Clone("tmpBeta");
	    tmpBeta->Rebin(2);
	    TF1* fbeta = drawGFit(tmpBeta, nsigma, -2. , 2.);
	    sbeta_pull = fbeta->GetParameter("Sigma");
	    mbeta_pull = fbeta->GetParameter("Mean");

	    TH1F* tmpY = (TH1F*) hRes4D->hPullYRZ->Clone("tmpY");
	    tmpY->Rebin(2);
	    TF1* fy = drawGFit(tmpY, nsigma, -2. , 2. );
	    sy_pull = fy->GetParameter("Sigma");
	    my_pull = fy->GetParameter("Mean");
	  }

	  TH1F* tmpAlpha = (TH1F*) hRes4D->hPullAlpha->Clone("tmpAlpha");
	  tmpAlpha->Rebin(2);
	  TF1* falpha = drawGFit(tmpAlpha, nsigma, -2. , 2. );
	  salpha_pull = falpha->GetParameter("Sigma");
	  malpha_pull = falpha->GetParameter("Mean");

	  TH1F* tmpX = (TH1F*) hRes4D->hPullX->Clone("tmpX");
	  tmpX->Rebin(2);
	  TF1* fx = drawGFit(tmpX, nsigma, -2. , 2.);
	  sx_pull = fx->GetParameter("Sigma");
	  mx_pull = fx->GetParameter("Mean");

	  cout << " " << wheel << " " << station << " " << sector  <<  " salpha_pull: " << salpha_pull  << " malpha_pull: " << malpha_pull;
	  cout  << " sbeta_pull: " << sbeta_pull  << " mbeta_pull: " << mbeta_pull;
	  cout  << " sx_pull: " << sx_pull  << " mx_pull: " << mx_pull;
	  cout  << " sy_pull: " << sy_pull  << " my_pull: " << my_pull;
	  cout << endl;

	}

	double ratio=0;

	if (doNSeg) {
	  TH1F* hNs =  hEff4D->hNSeg;
	  double int_1 = hNs->Integral(2,21);
	  double int_2 = hNs->Integral(3,21);
	  ratio = int_2/int_1;
	  //  cout << "int_1: " << int_1 <<" int_2: " << int_2 << " ratio: " << ratio << endl;
	}

	float p0_Phi=0;
	float p1_Phi=0;
	float p2_Phi=0;
	float p0_Theta=0;
	float p1_Theta=0;
	float p2_Theta=0;

	if(doPar){
	  float min_Phi;
	  float max_Phi;
	  float min_Theta;
	  float max_Theta;

	  rangeAngle(abs(wheel), station, 1, min_Phi, max_Phi);
	  TF1 *angleDep_Phi= new TF1("angleDep_Phi","[0]*cos(x+[2])+[1]", min_Phi, max_Phi);
	  angleDep_Phi->SetParameters(0.01,0.001, 0.1);

	  TH1F* hprof_Phi = plotAndProfileX(hResPhi1->hResVsAngle,1,1,1,-0.04, 0.04, min_Phi-0.03, max_Phi+0.03);
	  if((station!=1 ||(station==1 && wheel==0))) angleDep_Phi->FixParameter(2,0.);
	  if((abs(wheel) == 1 ||wheel == -2) && station == 1)  angleDep_Phi->SetParameter(2,-0.12);

	  hprof_Phi->Fit(angleDep_Phi,"RQN");

	  angleDep_Phi->Draw("same");
	  p0_Phi = angleDep_Phi->GetParameter(0);
	  p1_Phi = angleDep_Phi->GetParameter(1);
	  p2_Phi = angleDep_Phi->GetParameter(2);

 	  if (station!=4){
	    rangeAngle(abs(wheel), station, 2, min_Theta, max_Theta);
	    TF1 *angleDep_Theta= new TF1("angleDep_Theta","[0]*cos(x+[2])+[1]", min_Theta, max_Theta);
	    angleDep_Theta->SetParameters(0.01,0.001, 0.1);
	    angleDep_Theta->FixParameter(2,0.);
	    TH1F* hprof_Theta = plotAndProfileX(hResTheta->hResVsAngle,1,1,1,-0.04, 0.04, min_Theta-0.03, max_Theta+0.03);

	    if((wheel==-2 || wheel==2) &&(station == 1 || station == 2)) {
	      angleDep_Theta->FixParameter(0,0.);
	      angleDep_Theta->FixParameter(1,0.);
	    }

	    hprof_Theta->Fit(angleDep_Theta,"RQN");
	    angleDep_Theta->Draw("same");
	    //angleDep_Theta->Draw("same");
	    p0_Theta = angleDep_Theta->GetParameter(0);
	    p1_Theta = angleDep_Theta->GetParameter(1);
	    p2_Theta = angleDep_Theta->GetParameter(2);

	  }
	}

	// Write summary table (one row per SL)
 	int secmin=sector;
 	int secmax=sector;
 	if (sector ==0) {
 	  secmin=1;
 	  secmax=14;
 	}
 	for (int sec = secmin; sec<=secmax; sec++) {
 	  if (station!=4 && sec>12) continue;
	  f                 << wheel << " " << station << " " << sec << " " << 1 << " " << effS1RPhi << " " << effS3RPhi << " " << effSeg << " " << sphi   << " " << pphi << " " << malpha_res <<  " " <<salpha_res  << " " << malpha_pull <<  " " <<salpha_pull << " " << mx_pull <<  " " <<sx_pull << " " << mx << " " << sx << " " <<ratio << " " << p0_Phi << " " << p1_Phi << " " << p2_Phi << endl;
	  if (station!=4) f << wheel << " " << station << " " << sec << " " << 2 << " " << effS1RZ   << " " << effS3RZ   << " " <<  effSeg <<" " << stheta << " " << ptheta << " " << mbeta_res <<  " " <<sbeta_res  << " " << mbeta_pull <<  " " <<sbeta_pull << " " << my_pull <<  " " <<sy_pull << " " << my << " " << sy << " " <<ratio <<" " << p0_Theta << " " << p1_Theta << " " << p2_Theta <<endl;
	  f                 << wheel << " " << station << " " << sec << " " << 3 << " " << effS1RPhi << " " << effS3RPhi << " " << effSeg << " " << sphi   << " " << pphi << " " << malpha_res <<  " " <<salpha_res  << " " << malpha_pull <<  " " <<salpha_pull  << " " << mx_pull <<  " " <<sx_pull << " " << mx << " " << sx <<  " " <<ratio << " " << p0_Phi  << " " << p1_Phi << " " << p2_Phi <<endl;
 	}
      } // sector
    } //station
  } //wheel
}


pdf_file<-"pdf/pyramids_finely_outside_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file,width=12,height=9)

#par(mai=c(0.2,0.1,0.2,0.1),omi=c(0.75,0.2,0.85,0.2),mfcol=c(1,2),cex=0.75,
par(mai=c(0.2,0.1,0.8,0.1),omi=c(0.75,0.2,0.85,0.2),mfcol=c(1,2),cex=0.75,family="Lato Light",las=1)

# Import data and prepare chart

myWomen<-read.csv("myData/women.txt",header =F,sep=",")
for(i in 1:111) colnames(myWomen)[i]<-paste("x",i+1949,sep="")
myMen<-read.csv("myData/men.txt",header =F,sep=",")
for(i in 1:111) colnames(myMen)[i]<-paste("x",i+1949,sep="")

myWSurplus<-(myWomen$x1970-myMen$x1970)
myWSurplus[myWSurplus < 0]<-0
myMSurplus<-(myMen$x1970-myWomen$x1970)
myMSurplus[myMSurplus < 0]<-0

right<-data.frame(myWomen$x1970-myWSurplus,myWSurplus)
left<-data.frame(myMen$x1970-myMSurplus,myMSurplus)

source("scripts/inc_pyramid.r")
mtext("1970",3,line=0,adj=0.5,cex=1,font=3)

myWSurplus<-(myWomen$x2010-myMen$x2010)
myWSurplus[myWSurplus < 0]<-0
myMSurplus<-(myMen$x2010-myWomen$x2010)
myMSurplus[myMSurplus < 0]<-0

right<-data.frame(myWomen$x2010-myWSurplus,myWSurplus)
left<-data.frame(myMen$x2010-myMSurplus,myMSurplus)

source("scripts/inc_pyramid.r")
mtext("2010",3,line=0,adj=0.5,cex=1,font=3)

# Titling

mtext("Age structure of the population in Germany",3,line=2,adj=0,cex=2.25,family="Lato Black",outer=T)
mtext("All values in thousands per year of age.",3,line=-0.5,adj=0,cex=1.25,font=3,outer=T)
mtext("Source: www.destatis.de/bevoelkerungspyramide/",1,line=2,adj=1.0,cex=0.95,font=3,outer=T)
mtext("Outer highlighted areas: surplus of women and men.",1,line=2,adj=0,cex=0.95,font=3,outer=T)
dev.off()


rm(list = ls())
library(limma)

countsFile="allCounts.txt"

l = read.table(countsFile)
k27ac = normalizeQuantiles(cbind(l[[5]], l[[6]], l[[7]], l[[8]])) #H3K27ac
k27me3 = normalizeQuantiles(cbind(l[[9]], l[[10]], l[[11]], l[[12]])) #H3K27me3
me3 = normalizeQuantiles(cbind(l[[13]], l[[14]], l[[15]], l[[16]])) #H3K4me3

me3MED = mean(me3)
getThis2 = which((apply(me3, 1, function(x) any(x >= me3MED))) == TRUE)
k27acMED = mean(k27ac)
getThis3 = which((apply(k27ac, 1, function(x) any(x >= k27acMED))) == TRUE)
k27me3MED = mean(k27me3)
getThis4 = which((apply(k27me3, 1, function(x) any(x >= k27me3MED))) == TRUE)
g = unique(sort(c(getThis2, getThis3, getThis4)))

me3 = me3[g,] + 1
k27ac = k27ac[g,] + 1
k27me3 = k27me3[g,] + 1

k27acL = cbind(log2(k27ac[,2] / k27ac[,1]), log2(k27ac[,3] / k27ac[,2]), log2(k27ac[,4] / k27ac[,3]))
k27me3L = cbind(log2(k27me3[,2] / k27me3[,1]), log2(k27me3[,3] / k27me3[,2]), log2(k27me3[,4] / k27me3[,3]))
me3L = cbind(log2(me3[,2] / me3[,1]), log2(me3[,3] / me3[,2]), log2(me3[,4] / me3[,3]))

write(paste(l[[1]][g], l[[2]][g], l[[3]][g], l[[4]][g], k27acL[,1]*100, k27acL[,2]*100, k27acL[,3]*100, k27me3L[,1]*100, k27me3L[,2]*100, k27me3L[,3]*100, me3L[,1]*100, me3L[,2]*100, me3L[,3]*100, sep = "\t"), file = paste0("allFold.txt"), ncolumns = 1)
write(paste(l[[1]][g], l[[2]][g], l[[3]][g], l[[4]][g], k27ac[,1]-1, k27ac[,2]-1, k27ac[,3]-1, k27ac[,4]-1, k27me3[,1]-1, k27me3[,2]-1, k27me3[,3]-1, k27me3[,4]-1, me3[,1]-1, me3[,2]-1, me3[,3]-1, me3[,4]-1, sep = "\t"), file = paste0("allCountsNorm.txt"), ncolumns = 1)