library(tidyverse)
library(R0)
library(scales)
library(incidence)
library(EpiDynamics)
library(spatstat)

param_dat = expand.grid(
  initial_r0 = seq(2, 3, by = 0.25),
  incubation_period = seq(4, 7, by = 0.5),
  distancing_effect = seq(0.4, 0.7, by = 0.05),
  prop_susceptible = seq(0.3, 0.7, by = 0.1),
  initial_shutdown = c('2020-03-07') %>% as.Date(),
  missing_death_rate = seq(0.30, 0.60, by = 0.05)
)

setwd("~/Public_Policy/Projects/COVID-19")
italy_jh_joined = read_csv('data/jh_joined.csv') %>% filter(country_region == 'Italy') %>%
  filter(cases > 0) %>%
  mutate(
    time = as.numeric(date_upd - min(date_upd)),
    new_deaths = c(deaths[1], diff(deaths, 1)),
    days_since_first_death = as.numeric(date_upd - min(date_upd[deaths > 0])),
    weeks_since_first_death = days_since_first_death %/% 7
  )

italy_jh_joined_weekly_deaths = group_by(italy_jh_joined, weeks_since_first_death) %>%
  summarize(
    obs = n(),
    total_deaths = sum(new_deaths)
  ) %>%
  mutate(
    projected = total_deaths / (obs/7)
  )

run_sir_sim = function(the_row, return_data = F){

  # the_row = param_dat[it,]
  # the_row = these_params
  #
  # the_row = tibble(
  #   initial_r0 = 2.25,
  #   incubation_period = 5,
  #   distancing_effect = 0.6,
  #   prop_susceptible = 0.3,
  #   missing_death_rate = 0.4,
  #   initial_shutdown = as.Date('2020-03-07')
  # )
  initial_r0 = the_row$initial_r0

  distancing_effect = the_row$distancing_effect
  distancing_r0 = initial_r0 * (1- distancing_effect)

  incubation_period = the_row$incubation_period
  gamma = 1/incubation_period

  initial_beta = initial_r0 / incubation_period
  secondary_beta = distancing_r0 / incubation_period

  italy_pop = 60.36e6
  italy_susceptible = italy_pop * the_row$prop_susceptible

  missing_death_rate = the_row$missing_death_rate

  ##### pull in data ####

  initial_shutdown = the_row$initial_shutdown
  first_cases = min(italy_jh_joined$date_upd)
  initial_r0_period = as.numeric(initial_shutdown - first_cases) - 1

  secondary_period = as.numeric(max(italy_jh_joined$date_upd) - initial_shutdown)
  total_time = initial_r0_period + secondary_period - 1 + 60
  time_since_initial_case = as.numeric(max(italy_jh_joined$date_upd) - min(italy_jh_joined$date_upd))

  # covid
  initial_parameters <- c(beta = initial_beta, gamma = gamma)
  initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))

  initial_covid_sir <- SIR(pars = initial_parameters, init = initials, time = 0:initial_r0_period)

  secondary_parameters <- c(beta = secondary_beta, gamma = gamma)
  secondary_initials <- c(S = tail(initial_covid_sir$results$S, 1), I = tail(initial_covid_sir$results$I, 1),
                          R = tail(initial_covid_sir$results$R, 1))

  distancing_covid_sir = SIR(pars = secondary_parameters, init = secondary_initials, time = (initial_r0_period+1):total_time)

  # combine sirs

  est_deaths = function(par, missing_death_rate, return_dat = F) {

    death_rate = par[1]

    combined_sirs =
      tibble(
        time = initial_covid_sir$time,
        S = initial_covid_sir$results$S,
        I = initial_covid_sir$results$I,
        R = initial_covid_sir$results$R,
        model = 'initial'
      ) %>%
      bind_rows(
        tibble(
          time = distancing_covid_sir$time - 1,
          S = distancing_covid_sir$results$S,
          I = distancing_covid_sir$results$I,
          R = distancing_covid_sir$results$R,
          model = 'secondary'
        ) %>%
          filter(time != min(time))
      ) %>%
      mutate(
        new_cases = round(lag(S * italy_susceptible, 1) - S*italy_susceptible),
        deaths = rbinom(length(S), new_cases, prob = death_rate),
        death_timing = rweibull(length(S), 3, 10),
        death_date =  round(time + death_timing),
        days_since_first_death = death_date - min(death_date[deaths > 0], na.rm = T),
        death_week = days_since_first_death %/% 7
      )

    # # [1] 3.005484 7.201339
    # the_weibull = rweibull(1000, the_solution$par[1], the_solution$par[2])
    # #

    sir_weekly_deaths = group_by(combined_sirs, death_week) %>%
      summarize(
        sir_total_deaths = sum(deaths, na.rm = T)
      )

    weekly_comparison = inner_join(italy_jh_joined_weekly_deaths, sir_weekly_deaths,
                                   by = c('weeks_since_first_death' = 'death_week')) %>%
      mutate(
        italy_true_death_estimate = projected / (1-missing_death_rate),
        diff_sir_total_deaths_true = sir_total_deaths - italy_true_death_estimate,
        squared_diff_sir_total_deaths_true = diff_sir_total_deaths_true^2
      )

    # use projected here
    italy_reported_deaths_to_date = sum(weekly_comparison$projected)
    italy_true_death_estimate = italy_reported_deaths_to_date / (1-missing_death_rate)
    sir_deaths_to_date = sum(weekly_comparison$sir_total_deaths)
    difference_sir_true_est = sum(weekly_comparison$squared_diff_sir_total_deaths_true)

    if (return_dat) {
      return(combined_sirs)
    } else {
      return(difference_sir_true_est)
    }
  }

  the_solution = optim(par = 0.01, fn = est_deaths, method = 'Brent', lower = 0.001, upper = 0.05, missing_death_rate = missing_death_rate)

  # > the_solution$par
  # [1] 0.003152483

  sir_dat = est_deaths(the_solution$par, return_dat = T, missing_death_rate = missing_death_rate)
  head(sir_dat)

  sir_weekly_deaths = group_by(sir_dat, death_week) %>%
    summarize(
      sir_total_deaths = sum(deaths, na.rm = T)
    )

  weekly_comparison = inner_join(italy_jh_joined_weekly_deaths, sir_weekly_deaths, by = c('weeks_since_first_death' = 'death_week')) %>%
    mutate(
      italy_true_death_estimate = projected / (1-missing_death_rate),
    )

  return_dat = tibble(
    weekly_correlation = cor(weekly_comparison$projected, weekly_comparison$sir_total_deaths),
    solution_diff = the_solution$value^(1/2),
    solved_ifr = the_solution$par,
    sir_total_deaths = sum(sir_weekly_deaths$sir_total_deaths),
    sir_total_observed_deaths = sum(sir_weekly_deaths$sir_total_deaths) * (1-missing_death_rate),
    sir_observed_to_date = sum(weekly_comparison$sir_total_deaths) * (1-missing_death_rate),
    actual_to_date = sum(weekly_comparison$total_deaths),
    projected_to_date = sum(weekly_comparison$projected),
    actual_projected_not_missing = sum(weekly_comparison$projected) / (1-missing_death_rate)
  )

  if (return_data) {
    return(
      list(
        weekly_comparison = weekly_comparison,
        sir_dat = sir_dat,
        return_dat = return_dat,
        sir_weekly_deaths = sir_weekly_deaths
      )
    )
  } else {
    return(return_dat)
  }
}

all_italy_runs = map(1:nrow(param_dat), function(it){
  print(it/nrow(param_dat))

  run_sir_sim(param_dat[it,])
}) %>%
  bind_rows()

param_dat$it = 1:nrow(param_dat)

all_italy_runs_with_params = inner_join(all_italy_runs %>% mutate(it = 1:nrow(all_italy_runs)), param_dat) %>%
  arrange(solution_diff, -weekly_correlation) %>%
  mutate(
    weekly_correlation = ifelse(weekly_correlation < 0, 0, weekly_correlation)
  )

write.csv(all_italy_runs_with_params,
          'data/all_italy_runs_with_params.csv', row.names = F)

# limit to the most plausible solutions

all_italy_runs_with_params$weekly_correlation %>% hist()
weighted.mean(all_italy_runs_with_params$solved_ifr, all_italy_runs_with_params$weekly_correlation^2)
weighted.quantile(all_italy_runs_with_params$solved_ifr, all_italy_runs_with_params$weekly_correlation^(2), probs=seq(0,1,0.25), na.rm = TRUE)

ggplot(all_italy_runs_with_params, aes(distancing_effect, initial_r0 )) +
  geom_point() +
  # geom_tile(aes(fill = solution_diff, alpha = weekly_correlation^2)) +
  scale_fill_viridis_d(direction = -1)

# get top ten percent as solution set
mean(top_10$solved_ifr)
ggplot(top_10, aes(weekly_correlation, solved_ifr, colour = initial_r0)) +
  geom_point()

weighted.mean(top_10$solved_ifr, top_10$weekly_correlation^2)
weighted.quantile(top_10$solved_ifr, top_10$weekly_correlation^(2), probs=seq(0,1,0.25), na.rm = TRUE)

all_italy_runs_with_params$solution_diff %>% summary()

solution_set = filter(all_italy_runs_with_params, solution_diff <= 1000) %>%
  arrange(-weekly_correlation)
solution_set$solution_diff %>%  hist()

ggplot(solution_set, aes(weekly_correlation^2, solved_ifr)) +
  geom_point(aes(colour = initial_r0))  +
  scale_colour_viridis_c(option = 'C') +
  theme_dark() +
  stat_smooth()

these_params = filter(param_dat, it %in% head(solution_set, 1)$it)
the_dat = run_sir_sim(these_params, T)
names(the_dat)
the_dat$sir_dat
ggplot(the_dat$sir_dat, aes(time, new_cases)) +
  geom_bar(stat = 'identity')
ggplot(the_dat$sir_dat, aes(time, I)) +
  geom_line()

sum(the_dat$sir_dat$new_cases, na.rm = T)
the_dat$sir_weekly_deaths

ggplot(the_dat$sir_weekly_deaths, aes(death_week , sir_total_deaths*(1-these_params$missing_death_rate))) +
  geom_bar(stat = 'identity')

ggplot(the_dat$weekly_comparison, aes(weeks_since_first_death)) +
  geom_area(aes(y = projected), alpha = 0.5) +
  geom_area(aes(y = sir_total_deaths), alpha = 0.5, fill = 'red')

the_dat$sir_weekly_deaths
sum(the_dat$sir_weekly_deaths*(1-these_params$missing_death_rate))

the_dat$weekly_comparison
ggplot(the_dat$sir_dat, aes(death_date, deaths)) +
  geom_bar(stat = 'identity')

weighted.mean(solution_set$solved_ifr, solution_set$weekly_correlation^2)
weighted.quantile(solution_set$solved_ifr, solution_set$weekly_correlation^(2), probs=seq(0,1,0.25), na.rm = TRUE)
head(solution_set, 5) %>% View()

ggplot(solution_set, aes(weekly_correlation, initial_r0, colour = solved_ifr)) +
  geom_point() +
  scale_colour_viridis_c()

head(all_italy_runs_with_params)
names(all_italy_runs_with_params)
avg_by_param

ggplot(all_italy_runs_with_params, aes(initial_r0, solved_ifr, fill = weekly_correlation, alpha = weekly_correlation)) +
  geom_point()
all_italy_runs_with_params$solved_ifr

ggplot(solution_set, aes(initial_r0, distancing_effect, fill = weekly_correlation)) +
  scale_fill_viridis_c() +
  geom_tile() +
  scale_x_continuous(breaks = seq(2, 3, by = 0.25))

filter(solution_set, distancing_effect == 0.6, initial_r0 == 2.25) %>% arrange(-weekly_correlation)
solution_set$initial_r0


R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

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

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

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

[Workspace loaded from ~/.RData]
 install.packages("glmnet")
 install.packages("dplyr")
 install.packages("tidyr")
 install.packages("ggplot2")
 install.packages("caret")
 install.packages("glmnet")
 install.packages("boot")
 install.packages("RColorBrewer")
 install.packages("glmnet")
 install.packages("Metrics")

 library(dplyr)
 library(tidyr)
 library(ggplot2)
 library(caret)
 library(glmnet)
 library(boot)
 library(RColorBrewer)
 library(glmnet)
 library(Metrics)

 fitbit_details <- read.csv("https://raw.githubusercontent.com/ellisp/ellisp.github.io/source/data/fitbit_export_20160806.csv",
                    skip = 1, stringsAsFactors = FALSE) %>%
     mutate(
         Calories.Burned = as.numeric(gsub(",", "", Calories.Burned)),
         Steps = as.numeric(gsub(",", "", Steps)),
         Activity.Calories = as.numeric(gsub(",", "", Activity.Calories)),
         Date = as.Date(Date, format = "%d/%m/%Y")
     )

 fitbit <- fitbit_details

 head(fitbit)

 fitbit$Activity.Calories <- NULL

 fitbit$Date <- NULL

 fitbit$Steps <- fitbit$Steps / 1000

 fitbit$Steps

 panel_correlations <- function(x, y, digits = 2, prefix = "", cex.cor, ...){
 usr <- par("usr"); on.exit(par(usr))
 par(usr = c(0, 1, 0, 1))
 r <- abs(cor(x, y))
 txt <- format(c(r, 0.123456789), digits = digits)[1]
 txt <- paste0(prefix, txt)
 if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
 text(0.5, 0.5, txt, cex = cex.cor * r)
 }

 pairs(fitbit[ , -1], lower.panel = panel_correlations, main = "Pairwise Relationship - Fitbit's Measured Activities")

 ggplot(fitbit, aes(x = Distance / Steps)) + geom_rug() + geom_density() +ggtitle("Stride Length Reverse- Engineered from Fitbit Data", subtitle = "Not all strides identical, due to rounding or other jitter")

 moderate <- lm(Calories.Burned ~ Steps, data = fitbit)

 moderate

 round(coef(moderate))

 plot(moderate, which = 1, bty = "l", main ="Predicted Calories compared with Residuals")

 pacf(resid(moderate), main = "Partial Autocorrelation of residuals from single variable regression")
 grid()

 X <- as.matrix(fitbit[ , -1])

 head(X)

 Y <- fitbit$Calories.Burned

 Y

 set.seed(123)

 alphas <- seq(from = 0, to  = 1, length.out = 10)

 res <- matrix(0, nrow = length(alphas), ncol = 6)

 for(i in 1:length(alphas)){
     for(j in 2:6){
         cvmod <- cv.glmnet(X, Y, alpha = alphas[i])
         res[i, c(1, j)] <- c(alphas[i], sqrt(min(cvmod$cvm)))
     }
 }

 res <- data.frame(res)

 res

 res$average_rmse <- apply(res[ , 2:6], 1, mean)

 res$average_rmse
 [1] 109.2894 108.6945 108.4060 109.9822 111.0122 108.6028 106.0425 108.7103 109.5337 109.7035

 res <- res[order(res$average_rmse), ]

 res

 names(res)[1] <- "alpha"

 res %>%
     select(-average_rmse) %>%
     gather(trial, rmse, -alpha) %>%
     ggplot(aes(x = alpha, y = rmse)) +
     geom_point() +
     geom_smooth(se = FALSE) +
     labs(y = "Root Mean Square Error") +
     ggtitle("Cross Validation best RMSE for differing values of alpha")

 bestalpha <- res[1, 1]

 bestalpha

 crossvalidated <- cv.glmnet(X, Y, alpha = bestalpha)

 moderate1 <- glmnet(X, Y, alpha = bestalpha)

 OLSmodel <- lm(Calories.Burned ~ ., data = fitbit)

 OLSmodel

 coeffs <- data.frame(original = coef(OLSmodel),
                     shrunk =  as.vector(coef(moderate1, s = crossvalidated$lambda.min)),
                     very.shrunk = as.vector(coef(moderate1, s = crossvalidated$lambda.1se)))

 coeffs

 round(coeffs, 3)

 moderate2 <- glmnet(X, Y, lambda = 0)

 moderate2

 round(data.frame("elastic, lambda = 0" = as.vector(coef(moderate2)), "lm" = coef(OLSmodel), check.names = FALSE), 3)

 moderate3 <- glmnet(X[ , -2], Y, lambda = 0)

 moderate3

 moderate4 <- lm(Y ~ X[ , -2])

 moderate4

 round(data.frame("elastic, lambda = 0" = as.vector(coef(moderate3)), "lm" = coef(moderate4), check.names = FALSE), 3)

 > modellingfucn1 <- function(data, i){
     X <- as.matrix(data[i , -1])
     Y <- data[i , 1]
# k-fold cross-validation for glmnet
     crossvalidated <- cv.glmnet(X, Y, alpha = 1, nfolds = 30)
# Fitting a generalized linear model via penalized maximum likelihood
     moderate1 <- glmnet(X, Y, alpha = 1)
# Computing the root mean squared error
     rmse(predict(moderate1, newx = as.matrix(data[ , -1]), s = crossvalidated$lambda.min), data[ , 1])
 }

 elastic_boot <- boot(fitbit, statistic = modellingfucn1, R = 99)

 elastic_boot

 modellingfucn2 <- function(data, i){
     OLSmodel <- lm(Calories.Burned ~ ., data = data[i, ])
     rmse(predict(OLSmodel, newdata = data), data[ , 1])
 }

 lm_boot <- boot(fitbit, statistic = modellingfucn2, R = 99)

 lm_boot

 modellingOLS <- function(data, i){
     mod0 <- lm(Calories.Burned ~ Steps, data = data[i, ])
     rmse(predict(moderate, newdata = data), data[ , 1])
 }

 lmOLS_boot <- boot(fitbit, statistic = modellingOLS, R = 99)

 lmOLS_boot

 round(c("elastic modelling" = mean(elastic_boot$t),
         "OLS modelling" = mean(lm_boot$t),
         "OLS modelling, only one explanatory variable" = mean(lmOLS_boot$t)), 1)
                           elastic modelling                                OLS modelling
                                        95.8                                         99.7
OLS modelling, only one explanatory variable
                                       159.7

 ordering <- c(7,5,6,2,1,3,4)
 par(mar = c(5.1, 4.1, 6.5, 1), bg = "grey90")

 model_scaled <- glmnet(scale(X), Y, alpha = bestalpha)

 the_palette <- brewer.pal(7, "Set1")

 plot(model_scaled, xvar = "dev", label = TRUE, col = the_palette, lwd = 2, main = "Increasing contribution of different explanatory variables\nas penalty for including them is relaxed")

 legend("topleft", legend = colnames(X)[ordering], text.col = the_palette[ordering], lwd = 2, bty = "n", col = the_palette[ordering])

Chapter 04/1Shrinkage Methods - Calories burnt per day.r


png("#42_some_colors_name.png" , width = 480, height = 480 )
par(mar=c(0,0,0,0))
plot(0, 0, type = "n", xlim = c(0, 1), ylim = c(0, 1), axes = FALSE, xlab = "", ylab = "")
line=25
col=5
rect(  rep((0:(col - 1)/col),line) ,  sort(rep((0:(line - 1)/line),col),decreasing=T)   ,   rep((1:col/col),line) , sort(rep((1:line/line),col),decreasing=T),  border = "light gray" , col=colors()[seq(1,line*col)])
text(  rep((0:(col - 1)/col),line)+0.1 ,  sort(rep((0:(line - 1)/line),col),decreasing=T)+0.015 , colors()[seq(1,line*col)]  , cex=1)
dev.off()


# 0 and -0 are recognized but are both printed as simply 0.
1/c(0, -0, Inf, -Inf, NaN)
# Inf -Inf    0    0  NaN


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

#+ echo=F
source("init.r")

library(igraph)
library(spdep)

####################################################################################
## Number and proportion of zhu houses
##
table(hh$zhubo1)  # no. zhu-labelled houses with Mosuo heads

nrow(subset(hh, zhubo1==1)) / nrow(hh)  * 100  # proportion of zhubo houses

####################################################################################
## Join count stats for spatial autocorrelation of zhubo houses
##
# make social networks for each village
# loop over each village separately, saving each adjacency matrix into variables of the form adj.X.village,
# where X is the network type (individual gifts, household gifts, farm work) and village is village number
village_ids = unique(hh$VillageID)
for (village in village_ids) {
  # get unique households as vertices
  # households = unique(subset(hh, Ego.VillageID==village, select=c(Ego.HH, Ego.VillageID, Ego.zhubo1)))
  households = hh %>%
    filter(VillageID==village) %>%
    select(Ego.HH=HH, Ego.VillageID=VillageID, Ego.zhubo1=zhubo1)

  # distance
  dat = subset(hh.dyads, Ego.VillageID==village & !is.na(Distance), select=c(Ego.HH, Alter.HH, Distance))
  g.dist = graph.data.frame(dat, vertices=households, directed=T)        # turn relevant subset into a graph object
  assign( paste("adj", "dist", village, sep="."),
          get.adjacency( g.dist, sparse=F, attr="Distance" ) )           # create adjaceny matrix

  # also create list of witch houses for current village
  assign( paste("zhubo", village, sep="."), households)
}
# clean up
rm(dat, households, village, g.dist, village_ids)

# set up factors
zhubo.1$zhubo = as.factor(zhubo.1$Ego.zhubo1)
zhubo.2$zhubo = as.factor(zhubo.2$Ego.zhubo1)
zhubo.5$zhubo = as.factor(zhubo.5$Ego.zhubo1)
zhubo.6$zhubo = as.factor(zhubo.6$Ego.zhubo1)
zhubo.8$zhubo = as.factor(zhubo.8$Ego.zhubo1)
levels(zhubo.1$zhubo) = c("Non-zhubo", "Zhubo")
levels(zhubo.2$zhubo) = c("Non-zhubo", "Zhubo")
levels(zhubo.5$zhubo) = c("Non-zhubo", "Zhubo")
levels(zhubo.6$zhubo) = c("Non-zhubo", "Zhubo")
levels(zhubo.8$zhubo) = c("Non-zhubo", "Zhubo")

# join-counts per village
lw1 = mat2listw(adj.dist.1)
lw2 = mat2listw(adj.dist.2)
lw5 = mat2listw(adj.dist.5)
lw6 = mat2listw(adj.dist.6)
lw8 = mat2listw(adj.dist.8)
jc.1 = joincount.multi(zhubo.1$zhubo, listw=lw1, zero.policy=T)
jc.2 = joincount.multi(zhubo.2$zhubo, listw=lw2, zero.policy=T)
jc.5 = joincount.multi(zhubo.5$zhubo, listw=lw5, zero.policy=T)
jc.6 = joincount.multi(zhubo.6$zhubo, listw=lw6, zero.policy=T)
jc.8 = joincount.multi(zhubo.8$zhubo, listw=lw8, zero.policy=T)

# print results and calculate p-values
jc.1
2*pnorm(-abs(jc.1[,4]))
jc.2
2*pnorm(-abs(jc.2[,4]))
jc.5
2*pnorm(-abs(jc.5[,4]))
jc.6
2*pnorm(-abs(jc.6[,4]))
jc.8
2*pnorm(-abs(jc.8[,4]))


torn=c();for (i in 1000:9999) { if (i==((i%/%100)+(i%%100))^2 && length(table(strsplit(toString(i),"")))==4) torn<-c(torn,i) }; print(torn)


library(ggplot2)
setwd('c:/nba/')
csvfiles<-"c:/nba/hotcolddata.csv"
MyData <- read.csv(file=csvfiles, header=TRUE, sep=",")
dfp<-data.frame(MyData$'percent.all',MyData$'percent.hot',MyData$'percent.cold')
dfp <- setNames(dfp, c("all","hot","cold"))
dfps <- stack(dfp)
dfps<-setNames(dfps, c("shot.successrate","shot.type"))

myColors<-c("green","blue","red")
m <- ggplot(dfps, aes(x=shot.successrate))
m <- m + geom_density(aes(fill=factor(shot.type)), size=0.01, alpha=.25) +
  scale_fill_manual(values=myColors)+theme_classic(base_size = 10, base_family = "Helvetica")+labs(x = "shot success rate", y = "density")
tiff("plot1.tiff",width = 900, height = 900, res = 200)
m
dev.off()
##densityplot for shooting percentage
##dot plot range vs hot-diff and cold-diff
library(reshape)
dfp2<-data.frame(MyData$'range',MyData$'range.diff.hot',MyData$'range.diff.cold')
dfp2<-setNames(dfp2, c("range","hot","cold"))
dfpm <- melt(dfp2, id.vars = "range")
dfpm<-setNames(dfpm, c("range","shot.type","diff"))
myr <- lm(diff ~ shot.type*range, data = dfpm)
tiff("plot2.tiff",width = 900, height = 900, res = 200)
p<-ggplot(dfpm, aes(range, diff, colour = shot.type)) +
  geom_point() +
  scale_colour_manual(values = c("red", "blue"))+theme_classic(base_size = 10, base_family = "Helvetica")+labs(x = "average shot distance (feet)", y = "shot distance shift (feet)")+geom_smooth(method="lm", se=FALSE)
p
dev.off()


# aula 6 - árvores de decisão

d <- read.csv("train.csv")
dTest <- read.csv("test.csv")

View(d)

install.packages("party")
library(party)

#Árvore com 1 variável
mod <- ctree(Survived~Sex, data=d)
plot(mod, type="simple")

# Árvore com 2 variáveis
mod <- ctree(Survived~Sex+Pclass, data=d)
plot(mod, type="simple")

#Árvore com 3 variáveis
mod <- ctree(Survived~Sex+Pclass+Age, data=d)
plot(mod, type="simple")

#ML Classificador AD
d <- read.csv("train.csv")
# Separação base treino e teste
set.seed(44)
va <-sample(nrow(d))
treino <- d[va[1:691],]
teste <- d[va[692:891],]

# Modelagem
#mod <- ctree(Survived~Sex+Pclass+Embarked, data=treino)
#mod <- ctree(Survived~Sex+Pclass+Age+Embarked, data=treino)
#mod <- ctree(Survived~Sex+Pclass+Age, data=treino)
#mod <- ctree(Survived~Sex+Pclass, data=treino)
#mod <- ctree(Survived~Sex+Pclass+Age+Fare, data=treino)
mod <- ctree(as.factor(Survived)~Sex+Pclass+Embarked+Sibsp+Parch, data=treino)
plot(mod, type="simple")
#Previsão em teste

p <- predict(mod, newdata=teste)
prev <- ifelse(p<=.407,0,1)
cbind(prev,teste$Survived)

# Matriz de confusão
# cm - A.K.A - Confusion Matrix
cm <- table(p, teste$Survived)
Precision <- cm[2,2]/ ( cm[1,2] + cm[2,2])
Recall <- cm[2,2]/ ( cm[2,1] + cm[2,2])
accuracy <- (cm[1,1] + cm[2,2] )/ nrow(teste)
cm
accuracy
Precision
Recall


library(npowerPrioR)
scenario <- 1
source(paste("data_regression_NIG_scenario_", scenario, ".r", sep = ""))
summary(lm(y_0 ~ -1 + X_0))

lm.data <- list(
  N0 = N_0,
  P = P,
  X0 = X_0,
  y0 = y_0,
  mu_beta = rep(0, P),
  lambda_0 = solve(vb * diag(P)),
  alpha0 = as,
  beta0 = bs,
  a_0 = NULL
)

invlambda0 <- solve(lm.data$lambda_0)
###
get_mal_NIG_regression <- function(y0, X0, n0, mu0, lambda0, alpha0, beta0, a_0){
  P <- ncol(X0)
  if(length(mu0) != P) stop("mu0 is not the same dimension as X")
  Xstar <- sqrt(a_0) * X0
  ystar <- sqrt(a_0) * y0
  lambda_n <- t(Xstar)%*%Xstar + lambda0
  mu_n <- solve(lambda_n) %*% (lambda0%*%mu0 + t(Xstar)%*%ystar)
  alpha_n <-  as + (n0*a_0)/2
  beta_n <- beta0 + .5 * ( t(ystar)%*%ystar + t(mu0)%*%lambda0%*%mu0 - t(mu_n)%*%lambda_n%*%mu_n )
  det0 <- det(lambda0)
  det1 <- det(lambda_n)
  ans <- -(a_0 * n0/2) * log(2*pi) + .5 * (log(det0) - log(det1)) + (alpha0 * log(beta0) - alpha_n * log(beta_n) ) + (lgamma(alpha_n)-lgamma(alpha0))
  return(ans)
}
#
l_a0 <- function(x) {
  get_mal_NIG_regression(
    y0 = lm.data$y0,
    X0 = lm.data$X0,
    n0 = lm.data$N0,
    mu0 = lm.data$mu_beta,
    lambda0 = invlambda0,
    alpha0 = lm.data$alpha0,
    beta0 = lm.data$beta0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)
l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

#########
J <- 20

adaptive.ca0.estimates <- read.csv(paste("../data/constant_data/RegressionNIG_logCA0_adaptive_J=", J,
                                         "_scenario_", scenario, ".csv", sep = ""))
maxA <- max(adaptive.ca0.estimates$a0)
ylims <- range(c(adaptive.ca0.estimates$lc_a0, adaptive.ca0.estimates$deriv_lc))

curve(l_a0_p, 1E-4, maxA, lwd = 3, lty = 2, col = 2,
      ylab = "", xlab = expression(a[0]), cex.lab = 3, cex.axis = 2.5, ylim = ylims)
abline(h = 0, lwd = 2 , lty = 3)
curve(l_a0, 0, maxA, lwd = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$lc_a0, cex = 1.5, pch = 16)
curve(l_a0_pp, 0, maxA, lwd = 3, col = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$second_deriv_lc, cex = 1.5, col = 3, pch = 16)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$deriv_lc,
       pch = 16, cex = 1.5, col = 2)
legend(x = "topright", legend = c("l(a_0)", "l'(a_0)", "l''(a_0)"),
       col = 1:3, lwd = 2, bty = 'n', cex = 1.5)

adaptive.ca0.estimates$true_la0 <- l_a0(adaptive.ca0.estimates$a0)
adaptive.ca0.estimates$norm_error <- (adaptive.ca0.estimates$lc_a0- adaptive.ca0.estimates$true_la0)/adaptive.ca0.estimates$true_la0

adaptive.ca0.estimates
mean(abs(adaptive.ca0.estimates$norm_error[-1]))

#######
midpoint_integrate_la0 <- function(x_preds, fit){
  ## takes a grid of values for the input and a fit object that gives predictions (GLM, GAM, etc) and
  ## Gives the integrated function
  n <- length(x_preds)
  delta <- (x_preds[2]-x_preds[1])
  midpoints <- 0.5*(x_preds[2:n] + x_preds[1:(n-1)])
  ans <-  cumsum(predict(fit, newdata = data.frame(a0 = midpoints))) * delta
  ans <- c(0, ans)
  return(ans)
}

fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)
deriv.gam.fit <- mgcv::gam(deriv_lc ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)

K <- 20000
pred_a0s <- seq(0, maxA, length.out = K)

preds.gam  <- get_band(fit.gam, xpred = pred_a0s)
deriv.preds <- midpoint_integrate_la0(pred_a0s, deriv.gam.fit)

true.lca0s <- l_a0(pred_a0s)

gam.preds.list <- list(
  gam =  data.frame (a0 = pred_a0s, lca0 = preds.gam$mean, dev = preds.gam$mean - true.lca0s, lwr = preds.gam$lwr,
                     upr = preds.gam$upr, approximating_function = "gam", design = "adaptive"),
  derivative = data.frame (a0 = pred_a0s, lca0 = deriv.preds, dev = deriv.preds - true.lca0s, lwr = NA, upr = NA,
                           approximating_function = "gam-derivative", design = "adaptive_numerical")
)

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

## RMSE
lapply(gam.preds.list, function(pred) sqrt(mean( (pred$lca0 - true.lca0s)^2 )) )
## MAD
lapply(gam.preds.list, function(pred) mean( abs(pred$lca0 - true.lca0s) ))

## RMSE, a0 < 1
lapply(gam.preds.list, function(pred) sqrt(mean( (pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1])^2 )) )
## MAD, a0 < 1
lapply(gam.preds.list, function(pred) mean( abs(pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1]) ))

### Exporting

forplot_ca0 <- do.call(rbind, gam.preds.list)

write.csv(forplot_ca0,
          file = paste("../data/constant_data/fitted_predictions_lca0_RegressionNIG_scenario_", scenario, ".csv", sep = ""),  row.names = FALSE)

library(ggplot2)

p0 <- ggplot(data = forplot_ca0, aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = adaptive.ca0.estimates, mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p0

p1 <- ggplot(data = subset(forplot_ca0, approximating_function == "gam"),
             aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = adaptive.ca0.estimates, mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p1

ggsave(p0,
  filename = paste("../figures/estimates_log_ca0_RegressionNIG_scenario_", scenario, ".pdf", sep = ""), dpi = 300)


estbound <- function(model) {
  # summary(model) prints estimates which can be accessed as model$coefficient[#]
  # confint(model) prints 95% upper / lower bounds on estimates
  # econfint(model) prints estimates and 95% upper / lower bounds on estimates
  bounds <- confint(model)
  estbound <- cbind( c(model$coefficient),
                     bounds[,1:ncol(bounds)],
                     summary(model)$coefficients[,"Pr(>|t|)"]
  )
  colnames(estbound)[1] <- "estimates"
  colnames(estbound)[4] <- "Pr(>|t|)"
  estbound
}

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


cat(sapply(as.integer(readLines(tail(commandArgs(), n=1))), function(s) {
  r <- 0
  while (s > 0) {
    s <- bitwAnd(s, s - 1)
    r <- r + 1
  }
  r
}), sep="\n")


cat("#### Test estimateV str, spl & dev for orange with asreml4\n")
test_that("Orange_estimateV_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  # Orange tree data from asreml examples
  data(orange)

  ##Indepedent slope and intercept - with str
  asreml.options(design = TRUE)
  asreml.obj <- asreml(circ ~x,
                       random= ~ str( ~Tree/x, ~diag(2):id(5)) + spl(x) + spl(x):Tree,
                       knot.points = list(x = c(118,484,664,1004,1231,1372,1582)),
                       data = orange, maxiter = 30)
  summary(asreml.obj)$varcomp
  G.g <- kronecker(diag(asreml.obj$vparameters[1:2]), mat.I(5))
  V.g <- asreml.obj$design[,3:12] %*% G.g %*% t(as.matrix(asreml.obj$design[,3:12]))
  V.g <- V.g + asreml.obj$vparameters["spl(x)"] * asreml.obj$design[,13:17] %*%
    t(as.matrix(asreml.obj$design[,13:17]))
  V.g <- V.g + asreml.obj$vparameters["spl(x):Tree"] * asreml.obj$design[,18:42] %*%
    t(as.matrix(asreml.obj$design[,18:42]))
  V.g <- asreml.obj$sigma2 * (V.g + mat.I(nrow(orange)))
  V <- estimateV(asreml.obj)
  testthat::expect_true(all(abs(V - V.g) < 1e-06))

  asreml.obj <- asreml(circ ~x,
                       random= ~ str( ~Tree/x, ~idh(2):id(Tree)) + spl(x) + spl(x):Tree,
                       knot.points = list(x = c(118,484,664,1004,1231,1372,1582)),
                       data = orange, maxiter = 30)
  summary(asreml.obj)$varcomp
  V <- estimateV(asreml.obj)
  testthat::expect_true(all(abs(V - V.g) < 1e-06))

  #Add dev
  asreml.obj <- asreml(circ ~ x,
                       random = ~ str( ~Tree/x, ~diag(2):id(5)) + spl(x) + spl(x):Tree + dev(x),
                       knot.points = list(x = c(118,484,664,1004,1231,1372,1582)),
                       data = orange, maxiter=20)
  summary(asreml.obj)$varcomp
  G.g <- kronecker(diag(asreml.obj$vparameters[1:2]), mat.I(5))
  V.g <- asreml.obj$design[,3:12] %*% G.g %*% t(as.matrix(asreml.obj$design[,3:12]))
  V.g <- V.g + asreml.obj$vparameters["spl(x):Tree"] * asreml.obj$design[,18:42] %*%
    t(as.matrix(asreml.obj$design[,18:42]))
  V.g <- V.g + asreml.obj$vparameters["dev(x)"] * asreml.obj$design[,43:49] %*%
    t(as.matrix(asreml.obj$design[,43:49]))
  V.g <- asreml.obj$sigma2 * (V.g + mat.I(nrow(orange)))
  V <- estimateV(asreml.obj)
  testthat::expect_true(all(abs(V - V.g) < 1e-06))

  ##Correlated slope and intercept + fixed Season
  asreml.obj <- asreml(circ ~ x + Season,
                       random = ~ str( ~Tree/x, ~us(2,init=c(5.0,-0.01,0.0001)):id(5)) +
                         spl(x) + spl(x):Tree + dev(x),
                       knot.points = list(x = c(118,484,664,1004,1231,1372,1582)),
                       data = orange, maxiter=20)
  summary(asreml.obj)$varcomp
  G.g <- kronecker(matrix(asreml.obj$vparameters[c(1,2,2,3)], nrow = 2), mat.I(5))
  V.g <- asreml.obj$design[,5:14] %*% G.g %*% t(as.matrix(asreml.obj$design[,5:14]))
  V.g <- V.g + asreml.obj$vparameters["spl(x)"] * asreml.obj$design[,15:19] %*%
    t(as.matrix(asreml.obj$design[,15:19]))
  V.g <- V.g + asreml.obj$vparameters["spl(x):Tree"] * asreml.obj$design[,20:44] %*%
    t(as.matrix(asreml.obj$design[,20:44]))
  V.g <- asreml.obj$sigma2 * (V.g + mat.I(nrow(orange)))
  V <- estimateV(asreml.obj)
  testthat::expect_true(all(abs(V - V.g) < 1e-06))

  #random slope
  asreml.obj <- asreml(circ ~x,
                       random= ~ Tree + Tree:x + spl(x) + dev(x),
                       knot.points = list(x = c(118,484,664,1004,1231,1372,1582)),
                       data = orange, maxiter=30)
  summary(asreml.obj)$varcomp
  V.g <- asreml.obj$vparameters["Tree"] * asreml.obj$design[,3:7] %*%
    t(as.matrix(asreml.obj$design[,3:7]))
  V.g <- V.g + asreml.obj$vparameters["Tree:x"] * asreml.obj$design[,8:12] %*%
    t(as.matrix(asreml.obj$design[,8:12]))
  V.g <- V.g + asreml.obj$vparameters["dev(x)"] * asreml.obj$design[,18:24] %*%
    t(as.matrix(asreml.obj$design[,18:24]))
  V.g <- asreml.obj$sigma2 * (V.g + mat.I(nrow(orange)))
  testthat::expect_warning(V <- estimateV(asreml.obj))
  testthat::expect_true(all(abs(V - V.g) < 1e-06))

  #Overall spline and deviations based on factor - fails because cannot have a factor in dev
  testthat::expect_error(asreml.obj <-
                           asreml(circ ~x ,
                                  random= ~ str( ~Tree/x, ~diag(2):id(5)) + spl(X) + dev(X),
                                  knot.points = list(x = c(118,484,664,1004,1231,1372,1582)),
                                  data = orange))

  asreml.options(design = FALSE)

})


#' Get GEE identity Co-Variance Matrix
#'
#' Calculates GEE identity variance co-variance matrix.
#'
#' @param p.vec vector of probabilities
#' @param rho overdispersion parameter
#' @param dat matrix of multinomial clusters
#'
#' @return matrix of covariance
get_var_ident <- function (p.vec, rho, dat) {
  n <- dim(dat)[[2]]  # dimensions of multinom
  m <- n - 1  # order of multinom
  ni <- rowSums(dat) # cluster sizes
  num.clus <- dim(dat)[[1]]

  # helper vars
  rho.sq <- rho ^ 2
  dispi <- ni * (1 + (ni - 1) * rho.sq)
  p.mat <- matrix(p.vec, num.clus, m, byrow = TRUE)

  r.vec <- dat[, 1:m] - ni * p.mat
  var.mat <- diag(p.vec, m) - p.vec %*% t(p.vec)
  var.mat.inv <- solve(var.mat)

  Bi <- var.mat.inv * sum(ni ^ 2 / dispi)
  Mi <- diag(numeric(m), m)

  for (i in 1:num.clus) {
    ri <- r.vec[i, ]
    Yi.var <- ri %*% t(ri)
    Vi.inv <- (1 / dispi[i]) * var.mat.inv
    Di <- ni[i] * diag(numeric(m) + 1, m)
    Mi <- Mi + t(Di) %*% Vi.inv %*% Yi.var %*% Vi.inv %*% Di
  }

  cov.mat <- ( (sum(ni) - 1) / (sum(ni) - m) ) * (num.clus / (num.clus - 1)) * (solve(Bi) %*% Mi %*% solve(Bi))
  cov.mat
}

#' Get GEE glogit Co-Variance Matrix
#'
#' Calculates GEE glogit variance co-variance matrix.
#'
#' @param betas vector of betas
#' @param rho overdispersion parameter
#' @param dat matrix of multinomial clusters
#'
#' @return matrix of covariance
get_var_glogit <- function(betas, rho, dat) {
  n <- dim(dat)[[2]]  # dimensions of multinom
  m <- n - 1  # order of multinom
  ni <- rowSums(dat) # cluster sizes
  num.clus <- dim(dat)[[1]]

  # helper vars
  betas.exp <- exp(betas)
  rho.sq <- rho ^ 2
  denom <- 1 + sum(betas.exp)
  dispi <- (ni * (1 + (ni - 1) * rho.sq))
  p.vec <- as.vector(betas.exp / denom)
  p.mat <- matrix(p.vec, num.clus, m, byrow = TRUE)

  # create matrices
  bi <- matrix(0, m, m)
  mi <- diag(numeric(m), m)
  var.mat <- diag( p.vec, m ) - p.vec %*% t( p.vec )
  var.mat.inv <- solve(var.mat)
  r.vec <- dat[, 1:m] - ni * p.mat
  d.bar <- create_beta_equations(betas, rho, dat) / num.clus

  for (i in 1:num.clus) {
    ri <- r.vec[i, ]
    vi.inv <- (1 / dispi[i]) * var.mat.inv
    di <- ni[i] * (diag( betas.exp * denom, m ) - betas.exp %*% t( betas.exp )) / (denom ^ 2)
    dj <- t(di) %*% vi.inv %*% ri
    bi <- bi + t(di) %*% vi.inv %*% di
    mi <- mi + (dj - d.bar) %*% t(dj - d.bar)
  }

  cov.mat <- ( (sum(ni) - 1) / (sum(ni) - m) ) * (num.clus / (num.clus - 1)) * ( solve(bi) %*% mi %*% solve(bi) )
  cov.mat
}


##Shape=vector point
##Rinde=field Shape
##output_plots_to_html
##showplots
##inliers=output vector

library(sp)
library(spdep)

crs_imagen<-st_crs(Shape)
filtro1 <- as_Spatial(Shape)

cord <- filtro1@coords
gri <- dnearneigh(cord,0,30)
lw <- nb2listw(gri, style = "W",zero.policy=TRUE)
par(mfrow=c(1,1))

ML <- localmoran (filtro1@data[,Rinde], lw, p.adjust.method="bonferroni",alternative ="less",zero.policy=TRUE)
MP <- moran.plot(filtro1@data[,Rinde],lw,quiet=T,labels=F,col=3,zero.policy=T,xlab="Rendimiento", ylab="Rendimiento Spatially Lagged")
Influ <- MP$is.inf ;
datos0 <- data.frame(filtro1@data,filtro1@coords,ML,Influ)

#eliminacion de datos con ?ndice de Moran Local negativo y estad?sticamente significativos (p<0.05).
datos1 <- subset(datos0,datos0$Ii > 0 | datos0$Pr.z...0.>0.05)
myshp.inlier<- subset(datos0,datos0$Ii < 0 | datos0$Pr.z...0.<0.05)

datos2 <- datos1[datos1$dfb.1_ == FALSE & datos1$dfb.x == FALSE
                   & datos1$dffit == FALSE & datos1$cov.r == FALSE & datos1$cook.d
                   == FALSE & datos1$hat == FALSE, ]

>print("--------------------------------------------------------")
>str(datos2)

datos3<-data.frame(datos2[Rinde],datos2["coords.x1"],datos2["coords.x2"])
coordinates(datos2)<-c("coords.x1","coords.x2")
output <-sf::st_as_sf(datos3, coords = c("coords.x1", "coords.x2"),crs= crs_imagen)

n<-nrow(filtro1@data[Rinde])-nrow(datos3[Rinde])
>print(paste("Se filtraron",n,"puntos"))

inliers = output


suppressPackageStartupMessages(library(float))
tol = 1e-6

x1 = 1:3
x2 = 6:7
x = c(pi, exp(1))
s1 = fl(x1)
s2 = fl(x2)

test = dbl(c(s1, s2))
truth = c(x1, x2)
stopifnot(all.equal(test, truth, tol=tol))

test = dbl(c(s1, x2))
stopifnot(all.equal(test, truth, tol=tol))

test = c(s1, x2, x)
truth = c(x1, x2, x)
stopifnot(all.equal(test, truth, tol=tol))


mult <- function(a,b) a*b


### Do some analysis on the traffic experiments

library(ggplot2)
setwd("/Users/VGupta/Documents/Research/Julia Stuff/Traffic/")
dat = read.csv(file="trafficCVal.csv")
names(dat)<- c("Lambda", "C", "deg", "Mean", "SD")
pos = position_dodge(.5)

#The absolute minimum occurs at row 36:
# 1e05, 3.7625, deg 5
ggplot(aes(x=Lambda, y=Mean, color=factor(C), group=factor(C)),
       data=subset(dat, deg == 6 & C > 1 & C < 4.1)) +
  geom_point(position=pos) + geom_line(position=pos) +
  geom_errorbar(aes(ymin=Mean - SD, ymax=Mean+SD), position=pos) +
  scale_x_log10()

ggplot(aes(x=C, y=Mean, color=factor(Lambda), group=factor(Lambda)),
       data=subset(dat, Lambda >=.1 & deg==5)) +
  geom_point(position=pos) + geom_line(position=pos) +
  geom_errorbar(aes(ymin=Mean - SD, ymax=Mean+SD), position=pos)

unique(dat$C)

### Plotting the various fits for different d
library(reshape)
dat.fits = read.csv("fittedFuncs.csv")
str(dat.fits)
dat.fits.melt = melt(dat.fits, id="Flow", variable_name="Degree")

ggplot(aes(x=Flow, color=Degree, linetype=Degree, y=value),
       data=dat.fits.melt) +
  geom_line() +
  theme_bw(base_size=18) +
  xlab("Scaled Flow") + ylab("") +
  theme(legend.title=element_blank(),
        legend.position = c(.2, .7))

###  Plotting the residuals from traffic
dat.resids = read.csv("resids.csv")
ggplot(aes(x=ResidsRel), data = dat.resids) +
  geom_histogram(aes(y=..density..), fill="grey") +
  theme_bw(base_size=18) +
  ylab("") +
  xlab("Relative Residuals")

dat.flows = read.csv("FlowDiffs.csv")
ggplot(aes(x=Rel), data=dat.flows) +
  geom_histogram(aes(y=..density..), fill="grey") +
  theme_bw(base_size=18) +
  ylab("") +
  xlab("Rel. Prediction Error")

dat.fits2 = read.csv("amgSetsTraffic.csv")
str(dat.fits2)
ggplot(aes(x=Flows, y=True), data =dat.fits2) +
geom_line(size=.5, linetype="dashed") +
  geom_point(aes(y=Fit), color="black", size=3, shape=15) +
  geom_line(aes(y=Fit), color="black", size=.5) +
  ylab("") +
  geom_ribbon(aes(ymin=LB, ymax=UB), fill="grey", alpha=.3) +
  coord_cartesian(ylim=c(0, 4)) +
  theme_bw(base_size=18)


library(doMC)
registerDoMC(cores=4)

setwd("~/Desktop/chapter 2")
mydata <- read.csv("WA_Fn-UseC_-HR-Employee-Attrition.csv")
mydata$EmployeeNumber=mydata$Over18=mydata$EmployeeCount=mydata$StandardHours = NULL

library(mlbench)
library(gbm)

mydata$Attrition = as.numeric(mydata$Attrition)
head(mydata)

mydata = transform(mydata, Attrition=Attrition-1)
head(mydata)

gbm.model = gbm(Attrition~., data=mydata, shrinkage=0.01, distribution = 'bernoulli', cv.folds=10, n.trees=3000, verbose=F)

best.iter = gbm.perf(gbm.model, method="cv")

best.iter

summary(gbm.model)

library(caret)

set.seed(123)
mydata1=mydata
mydata1$Attrition=as.factor(mydata1$Attrition)
fitControl = trainControl(method="repeatedcv", number=10,repeats=10)
caretmodel = train(Attrition~., data=mydata1, method="gbm",distribution="bernoulli", trControl=fitControl, verbose=F, tuneGrid=data.frame(.n.trees=best.iter, .shrinkage=0.01, .interaction.depth=1, .n.minobsinnode=1))
caretmodel


library(readr)
library(data.table)
# @param
# actual is vector, pred is data.frame
# mlogloss(actual,pred)
mlogloss <- function(actual,pred){
	actual <- as.integer(as.factor(actual))
	probs <- rep(0,length(actual))
	for(i in 1:length(actual)) { probs[i] <- pred[i,actual[i]]}
	probs <- as.numeric(probs)
	probs[which(probs>1-1e-15)] <- 1-1e-15
	probs[which(probs<1e-15)] <- 1e-15
	return(-(1/length(actual))*sum(log(probs)))
}

path <- "../Data/"
train <- fread(paste0(path,"train_2nd.csv"))
train <- as.data.frame(train)
train$id <- NULL

tsne <- fread(paste0(path,"train_2nd_tsne.csv"))
tsne <- as.data.frame(tsne)
train <- cbind(train,tsne)

y <- train$target
y <- gsub('Class_','',y)
y <- as.integer(y)-1 #xgboost take features in [0,numOfClass)
train$target <- NULL
train$target <- y

for(i in 1:(ncol(train)-1)) { train[,i] <- as.numeric(train[,i])}

# make test data
test <- fread(paste0(path,"test_2nd.csv"))
test <- as.data.frame(test)
test$id <- NULL

tsne <- fread(paste0(path,"test_2nd_tsne.csv"))
tsne <- as.data.frame(tsne)
test <- cbind(test,tsne)

for(i in 1:ncol(test)) { test[,i] <- as.numeric(test[,i])}

predAll <- rep(0,9)
nfold <- 1
set.seed(131)
rnd <- sample(100000,nfold)
rnd <- 131
for(i in 1:nfold){
library(xgboost)
param <- list("objective" = "multi:softprob",
              "eval_metric" = "mlogloss",
              "num_class" = 9,
			  "max_depth" = 4,
			  "eta" = 0.02, # 0.002
			  "min_child_weight" = 1, # 10
			  "subsample" =  0.9, # 0.9
			  "colsample_bytree" = 0.8 # 0.8
			  )
cv.nround <- 10000
gc(TRUE)
set.seed(rnd[i])
bst <- xgb.cv(param=param, data=data.matrix(train[,c(-ncol(train))]), label=train$target,
nrounds=cv.nround, nfold=10, early.stop.round=10)
print(tmp <- min(bst$test.mlogloss.mean))
(minNum <- which.min(bst$test.mlogloss.mean))

# tsne
# eta 0.025: 602, 0.410142

#minNum <- 518
set.seed(rnd[i])
bst <- xgboost(param=param, data=data.matrix(train[,c(-ncol(train))]),
label=train$target, nrounds=minNum)

pred <- predict(bst,data.matrix(test))
pred <- matrix(pred,9,length(pred)/9)
predAll <- predAll + t(pred)
}
predAll <- predAll / nfold
submission <- data.frame(id=1:nrow(test),predAll)
names(submission) <- c('id', paste0('Class_',1:9))
head(submission,10)
for(i in 1:ncol(submission)) { submission[,i] <- as.character(submission[,i])}
write_csv(submission,paste0(path,"xgb_2nd.csv"))

imp<-xgb.importance(names(train[,-ncol(train)]),model=bst)
print(imp)
xgb.plot.importance(imp)

#xgb.plot.tree(feature_names=names(train[,-ncol(train)]),model=bst, n_first_tree=2)

# retrain
rm(pred)
library(cvTools)
NAME <- paste0('Class_',1:9)
tmp <- matrix(rep(NA,9),nrow(train),9)
tmp <- as.data.frame(tmp)
colnames(tmp) <- NAME
submission <- cbind(id=1:nrow(train),tmp)
nfold <- 5
cv.folds <- cvFolds(nrow(train),nfold)
cvs <- cv.folds$which
id <- 1:nrow(train)

for(NUMCV in 1:nfold){
test.x <- train[which(cvs==NUMCV),-ncol(train)]
test.y <- train[which(cvs==NUMCV),ncol(train)]
train.x <- train[which(cvs!=NUMCV),-ncol(train)]
train.y <- train[which(cvs!=NUMCV),ncol(train)]

set.seed(131)
bst <- xgboost(param=param, data=data.matrix(train.x), label=train.y, nrounds=minNum)
pred <- predict(bst,data.matrix(test.x))
pred <- matrix(pred,9,length(pred)/9)
submission[which(cvs==NUMCV),2:10] <- t(pred)
}

for(i in 1:ncol(submission)) { submission[,i] <- as.character(submission[,i])}
write_csv(submission,paste0(path,"xgb_2nd_retrain.csv"))

mlogloss(train$target,submission[,2:10])


twrc.calc <- function(twri, from=NA, to=NA, zero.from=FALSE) {
    if (class(twri)[1] == 'numeric') {
        ## use all twri entries
        twrc <- cumprod(twri + 1) - 1
    } else if (class(twri)[1] == 'matrix') {
        ## use all twri entries
        ## twrc <- cumprod(twri + 1) - 1
        # twrc <- t(t(cumprod(twri + 1))) - 1
        twrc <- apply(twri, 2, function(x) t(t(cumprod(x + 1))) - 1 )
    } else {
        ## twri must be an xts object
        ## use first and/or last twri entries for from and to if not defined
        if (is.na(from)) from <- zoo::index(twri[1,])
        if (is.na(to))   to   <- zoo::index(twri[nrow(twri),])
        ## cumprod works differently on xts than regular matrix so following is a bit complex
        duration <- paste(from, '/', to, sep='')
        if (isTRUE(zero.from)) {
            ## set twrc for from date to zero
            twrc <- xts::as.xts( t(t(cumprod(twri[duration]+1)) / as.vector(twri[from]+1) - 1) )
        } else {
            ## use from date when calculating twrc
            twrc <- xts::as.xts( t(t(cumprod(twri[duration]+1)) - 1) )
        }
    }
    return(twrc)
}
## twrivec1 <- c(0.1, 0.2, 0.3, 0.4, 0.5)
## twrivec2 <- c(0.11, 0.12, 0.13, 0.14, 0.15)
## twrimat  <- cbind(a=twrivec1, b=twrivec2)
## rownames(twrimat) <- c('2020-01-31', '2020-02-28', '2020-03-31', '2020-04-30', '2020-05-31')
## twrixts  <- xts::as.xts(twrimat)
## twrcvec1 <- twrc.calc(twrivec1)
## twrcmat  <- twrc.calc(twrimat)


source("linearcbf.r")
predict_linear = predict
source("svdopt.r")
predict_svd = predict

hybrid_pond <- function(train, test, features) {
	cat("Training Linear Model...", "\n")
	lmodel = linearcbf(train, test, features)
	cat("Training SVD Model...", "\n")
	svd_model = svdopt(train, k = 2)

	model = list()
	model$lmodel = lmodel
	model$svd_model = svd_model

	return(model)
}

predict <- function(model, user, item, features) {
	return((predict_linear(model$lmodel, user, item, features) + predict_svd(model$svd_model, user, item)) / 2)
}


#########################################################
# Build Model 2: Regression between Rate and sub meters #
#########################################################

###############
# Observation #
###############

build_model_2 <- data.frame(clean_data$Phase,clean_data$Sub_metering_1,clean_data$Sub_metering_2,clean_data$Sub_metering_3)

png('./img/Data-Build-Model-regression-2-Sub-Meter-1-VS-Rate.png')
par(mfrow=c(3,1))
plot(build_model_2$clean_data.Sub_metering_1,build_model_2$clean_data.Phase,xlab="Sub Meter 1",ylab="Sub Meter 2")
# dev.off()

# png('./img/Data-Build-Model-regression-2-Sub-Meter-2-VS-Rate.png')
plot(build_model_2$clean_data.Sub_metering_2,build_model_2$clean_data.Phase,xlab="Sub Meter 1",ylab="Sub Meter 2")
# dev.off()

# png('./img/Data-Build-Model-regression-2-Sub-Meter-3-VS-Rate.png')
plot(build_model_2$clean_data.Sub_metering_3,build_model_2$clean_data.Phase,xlab="Sub Meter 1",ylab="Sub Meter 2")
dev.off()

# we found that when the value is larger than 5, it seems like a linear, so we drop the small values

##############
#  Sampling  #
##############

build_model_2_bt = subset(build_model_2,(build_model_2$clean_data.Sub_metering_1>5)&(build_model_2$clean_data.Sub_metering_2>5)&(build_model_2$clean_data.Sub_metering_3>5))

build_model_2_bt_sample <- build_model_2_bt[sample(nrow(build_model_2_bt),2000),]

build_model_2_test <- build_model_2_bt[sample(nrow(build_model_2_bt),2000),]

###############
# Build Model #
###############

fit <- lm(build_model_2_bt_sample$clean_data.Phase~build_model_2_bt_sample$clean_data.Sub_metering_1+build_model_2_bt_sample$clean_data.Sub_metering_2+build_model_2_bt_sample$clean_data.Sub_metering_3)
print(summary(fit))
png('./img/Data-Build-Model-regression-2-Report.png')
par(mfrow=c(2,2))
plot(fit)
dev.off()

png('./img/Data-Build-Model-regression-2-Fitted.png')
plot(build_model_2_bt_sample$clean_data.Phase,fitted(fit))
dev.off()

pred <- predict(fit,build_model_2_test)
png('./img/Data-Build-Model-regression-2-Test.png')
plot(pred,build_model_2_test$clean_data.Phase-pred)
dev.off()


# Broken Line Process
# 23-04-2015
# Killian Martin--Horgassan

brokenLine = function(u) {

	Int_part <- floor(u)
	Float_part <- u-floor(u)

	# Y_t = S_floor(t) + (t-floor(t))*Epsilon_(floor(t)+1)
	Epsilons <- Epsilon_is(Int_part + 1)
	#S <- randomWalk(Int_part, Epsilons)

	#output <- S[Int_part] + Float_part*Epsilons[Int_part + 1]
	output <- cumsum(Epsilons)

	return(output)
}


#-------------------------------------------------------------------------------
# Mean non-zero value
#-------------------------------------------------------------------------------

lnz <- function(x) {
	log2( x[(x > 0)] );
}

mainName <- function(n) {
	idx = regexpr(".SM.", n, fixed=T)[1]
	if( idx > 1 ) {
		return( substr(n, 1, idx-1) )
	}
	return(n)
}

#-------------------------------------------------------------------------------
# Main
#-------------------------------------------------------------------------------

# Load data
if( ! exists('gt') ) {
	cat("Loading data from gtex.txt\n");
	gt = read.table("gtex.txt", sep="\t", header=TRUE);
}

minCol = 3

# Experiment names
colExpNames = as.vector( sapply(colnames(gt), mainName) )
expNames = unique( sort( colExpNames[3:ncol(gt)] ) )

# Plot histogram
plot(0, 0, xlim = c(-15,15), ylim = c(0, 0.15) )

#---
# Perform
#	i) Log2( colum )
#	ii) Column wise mean correction
#---
cat("Step 1:\n");
L = matrix( 0 , nrow = nrow(gt), ncol = ncol(gt)-2 )
for( idx in minCol:ncol(gt) ) {
	cat('\t', colExpNames[idx], "\n");
	x = gt[,idx]
	l = log2( x )

	k = ( x > 0 )
	l[!k] = NA

	mu = mean( l, na.rm = TRUE )
	l = l - mu

	L[,idx-minCol+1] = l
}

#---
# Difference to average
#---
cat("Step 2:\n");
lmu = rowMeans(L, na.rm = TRUE)
plot( density( lmu[k] ) , xlim = c(-15,15) )
for( idx in 1:ncol(L) ) {
	l = L[, idx] - lmu

	k = ! is.na(l)
	mu = mean(l , na.rm = TRUE )
	l = (l - mu) / sd(l,  na.rm = TRUE)

	lines( density( l[k] ), col=idx )

	L[,idx] = l

	cat('\t', colExpNames[idx], "\n");
}

colnames(L) = colnames(gt)[minCol:ncol(gt)]
norm = data.frame( geneId = gt[,1], geneName = gt[,2], L)

write.table(norm, file="gtex_norm.txt", quote = FALSE, sep = "\t", row.names = FALSE)


make_simulation_params <- function(n,
                                    sequence_scheme,
                                   complexity,
                                  alpha_priors,
                                   beta_priors,
                                   alpha_epsilon,
                                   beta_epsilon,
                                   noise_parameter,
                                   world_EIG,
                                   max_observation,
                                   fixed_length_complexity,
                                   feature_space_n,
                                   simple_feature_n,
                                   complex_feature_n,
                                   dissimilar_ratio
){

  params_id_df <- crossing(
    alpha_prior = alpha_priors,
    beta_prior = beta_priors,
    alpha_epsilon = alpha_epsilon,
    beta_epsilon = beta_epsilon,
    noise_parameter = noise_parameters,
    world_EIG = world_EIG,
    max_observation = max_observation
  ) %>%
    mutate(params_id = row_number(),
    )

  stimulus_sequence_df <- tibble(sequence_scheme = sequence_scheme) %>%
    crossing(tibble(complexity = complexity)) %>%
    mutate(n = 1) %>%
    rowwise() %>%
    mutate(
      stimuli_sequence = nest(scheme_to_stimuli(sequence_scheme, fixed_length_complexity = fixed_length_complexity,
                                                complexity = complexity,
                                                feature_space_n = feature_space_n,
                                                simple_feature_n = simple_feature_n,
                                                complex_feature_n = complex_feature_n,
                                                dissimilar_ratio = dissimilar_ratio), data = everything())) %>%
    ungroup() %>%
    mutate(sim_id = row_number())

  stimulus_sequence_df %>%
    crossing(params_id_df)

}

scheme_to_stimuli <- function(sequence_scheme,
                              fixed_length_complexity = TRUE,
                              complexity,
                              #similarity?,
                              feature_space_n,
                              simple_feature_n, complex_feature_n,
                              dissimilar_ratio
){

  if (fixed_length_complexity){
    background_creature <- sample(c(rep(FALSE,
                                        feature_space_n - ifelse(complexity == "complex", complex_feature_n, simple_feature_n)),                                     rep(TRUE, ifelse(complexity == "complex", complex_feature_n, simple_feature_n))))

    # make deviant creature
    # first figure out which location has TRUE
    deviant_creature <- background_creature

    feature_pos <- which(background_creature == TRUE)
    non_feature_pos <- which(background_creature == FALSE)
    total_feature_n <- length(feature_pos)
    feature_flip <- ceiling(total_feature_n * dissimilar_ratio)
    feature_change_pos <- sample(feature_pos,
                                 feature_flip,
                                 replace = FALSE)
    deviant_creature[feature_change_pos] <- !deviant_creature[feature_change_pos]

    # change non-feature to feature
    non_feature_change_pos <- sample(non_feature_pos,
                                     ifelse(feature_flip > length(non_feature_pos), length(non_feature_pos), feature_flip),
                                     replace = FALSE)

    deviant_creature[non_feature_change_pos] <-!deviant_creature[non_feature_change_pos]

    dissimilar_stimuli = deviant_creature

  }else{

    background_creature <- sample(c(rep(TRUE, ifelse(complexity == "complex",
                                                     complex_feature_n,
                                                     simple_feature_n))))
    # how to represent dissimilarity with ratio? currently just flipping
    #FIXME:
    deviant_creature <- as.logical(1-background_creature)
    dissimilar_stimuli = deviant_creature

  }

  block_list <- strsplit(sequence_scheme, "")[[1]]

  background_sequence <- replicate(length(block_list), background_creature, simplify = FALSE)
  background_sequence[which(block_list == "D")] <- replicate(length(which(block_list == "D")),
                                                             dissimilar_stimuli, simplify = FALSE)

  tidy_creature_sequence <- bind_rows(lapply(background_sequence,
                                             function(x) x %>% as_tibble_row(.name_repair = make.names)))

  # renaming columns
  rename_column <- function(x){paste0("V", x)}
  tidy_column_names <- lapply(1:length(background_creature), rename_column)
  colnames(tidy_creature_sequence) <- tidy_column_names
  tidy_creature_sequence <- tidy_creature_sequence %>%
    mutate(trial_number = row_number())

  return(tidy_creature_sequence)

}


library(quantmod)

stock <- na.omit(get(getSymbols('2357.TW')))

x = SMA( Cl(stock), 5 )
y = SMA( Cl(stock), 20 )
row <- x > y
#View( cbind(x, y, row) )
pl <- setNames( rep( 0, length(x) ), time(stock) )

m <- 21
while ( m < nrow(stock) ) {
    if (row[m-1] == 1 && row[m] == 0) {
        short <- as.numeric( Op(stock)[m+1] )
        while ( row[m] == 0 && m < nrow(stock) ) {
            m = m + 1
        }
        pl[m] <- short - as.numeric( Op(stock)[m+1] )
    }
    m = m+1
}

plot( cumsum(pl), type='l', col='red', lwd=2 )


## Dependencies
## install.packages(c('readr', 'curl', 'ggplot2', 'dplyr', 'stringr', 'fable', 'tsibble', 'dplyr', 'feasts', 'remotes', 'urca', 'sodium', 'plumber', 'jsonlite'))
library(fable)
library(tsibble)
library(dplyr)

## Setting parameters
city <- 'Melbourne'
ets_trend_method <- 'A' # additive
ic <- 'aic' # use aic as information criteria to select model

## Getting data
tourism_city <- tourism %>%
  filter(Region == city)
tourism

## Exploration
# Purpose: Business, Holiday, Visiting friends and family, or Others
tourism_city %>%
  autoplot(Trips)

## Training ETS and ARIMA models
fitted_model <- tourism_city %>%
  model(
    ets = ETS(Trips ~ trend(ets_trend_method), ic = ic),
    arima = ARIMA(Trips, ic = ic)
  )
fitted_model

## Inferencing
fc <- fitted_model %>%
  forecast(h = "5 years")
fc

fc %>%
  hilo(level = c(80, 95))

fc %>%
  autoplot(tourism_city)

## Analysis
accuracy_report <- fitted_model %>%
  accuracy() %>%
  arrange(MASE)
print(accuracy_report)


# 4. faza: Analiza podatkov
#
# podatki <- obcine %>% transmute(obcina, povrsina, gostota,
#                                 gostota.naselij = naselja/povrsina) %>%
#   left_join(povprecja, by = "obcina")
# row.names(podatki) <- podatki$obcina
# podatki$obcina <- NULL
#
# # Število skupin
# n <- 5
# skupine <- hclust(dist(scale(podatki))) %>% cutree(n)

osnovni.podatki <- rbind(osnovni.podatki.poroke, osnovni.podatki.razveze)

ociscena <- subset(osnovni.podatki, spremenljivka == "Sklenitve zakonskih zvez - Skupaj")
fit <- lm(data = ociscena, vrednost ~ leto)
a <- data.frame(leto=seq(2016, 2030, 2))
predict(fit, a)
napoved <- a %>% mutate(vrednost=predict(fit, .))
graf5 <- ggplot(ociscena, aes(x=leto, y=vrednost)) +
  geom_smooth(method=lm, se=FALSE, fullrange = TRUE) +
  geom_point(data=napoved, aes(x=leto, y=vrednost), color="orange", size=3) +
  labs(title="Napoved števila porok", y="Število porok") + geom_point()

#+ scale_x_continuous(limits = c(2017, 2030))


### (c) rucorbet@ucsc.edu
### this script is distributed freely but with no warranty
###

### USAGE: Rscript --vanilla plot_extremal.r [extremal_file] [output pdf]

args <- commandArgs(TRUE)
srcFile <- args[1]
outFile <- args[2]

require(plyr)

pdf(outFile,height=12,width=8)
par(mfrow=c(3,1))

d <- as.data.frame(read.table(srcFile))

## generate counts of sites by parsimony
counts_all <- ddply(d, .(d$V2, d$V3), nrow)
names(counts_all) <- c("alt", "parsimony", "Freq")

## plot for all sites
plot(counts_all$alt,counts_all$parsimony,log="x",pch=19,cex=0,xlab="Alternate allele count",ylab="Parsimony score")
for ( i in 1:length(counts_all$alt)+1 ) {
         points(counts_all$alt,counts_all$parsimony,pch=19,cex=c(2*log10(counts_all$Freq+1)),col=rgb(0,0,0,0.005))
}

## grab extremal
extremal <- d[d$V7==1,]

## add the linear fit to the graph
fit <- lm(extremal$V3 ~ log10( extremal$V2 ) )
abline( a = fit$coefficients[1], b = fit$coefficients[2], lty= 3 )

## plot extremal points
points( extremal$V2, extremal$V3, col="red", pch=18)

## label the slope
text(labels=c("slope (all)=\n\n", fit$coefficients[2]/3.32116635809), 10,max(d$V3)-2)

## again but no C>U
x <- d[d$V4 == 0,]
counts <- ddply(x, .(x$V2, x$V3), nrow)
names(counts) <- c("alt", "parsimony", "Freq")

## plot
plot(counts_all$alt,counts_all$parsimony,log="x",pch=19,cex=0,xlab="Alternate allele count",ylab="Parsimony score")
for ( i in 1:length(counts$alt)+1 ) {
         points(counts$alt,counts$parsimony,pch=19,cex=c(2*log10(counts$Freq+1)),col=rgb(0,0,0,0.005))
}

## grab extremal
extremal <- x[x$V9==1,]

## add the linear fit to the graph
fit <- lm(extremal$V3 ~ log10( extremal$V2 ) )
abline( a = fit$coefficients[1], b = fit$coefficients[2], lty= 3 )

## plot extremal points
points( extremal$V2, extremal$V3, col="red", pch=18)

## label the slope
text(labels=c("slope (no C>U)=\n\n", fit$coefficients[2]/3.32116635809), 10,max(x$V3)-2)

## again but no C>U or G>U
x <- d[d$V4 == 0 & d$V5 == 0,]
counts <- ddply(x, .(x$V2, x$V3), nrow)
names(counts) <- c("alt", "parsimony", "Freq")

## plot
plot(counts_all$alt,counts_all$parsimony,log="x",pch=19,cex=0,xlab="Alternate allele count",ylab="Parsimony score")
for ( i in 1:length(counts$alt)+1 ) {
         points(counts$alt,counts$parsimony,pch=19,cex=c(2*log10(counts$Freq+1)),col=rgb(0,0,0,0.005))
}

## grab extremal
extremal <- x[x$V9==1,]

## add the linear fit to the graph
fit <- lm(extremal$V3 ~ log10( extremal$V2 ) )
abline( a = fit$coefficients[1], b = fit$coefficients[2], lty= 3 )

## plot extremal points
points( extremal$V2, extremal$V3, col="red", pch=18)

## label the slope
text(labels=c("slope (no C>U, no G>U)=\n\n", fit$coefficients[2]/3.32116635809), 10,max(x$V3)-2)
dev.off()


require("neuralnet")

x = read.csv("abalone.train")
x = x[,1:8]

print(x)
yd = read.csv("abalone.train")
yd = as.matrix(yd[,9])
#Normalization of value Between -1 and 1
#yd=(yd*0.068965517)-1
print(yd)

trainingdata <- cbind(x,yd)
colnames(trainingdata) <- c("x0","x1","x2","x3","x4","x5","x6","x7","Output")
trainingdata = as.matrix(trainingdata)
print("Treinando rede...")
net.abalone <- neuralnet(Output~x0+x1+x2+x3+x4+x5+x6+x7,trainingdata, linear.output=TRUE,hidden=30, threshold=0.1)
print("Rede treinada!")

#------Neural network tests--------------------------------------------

x = read.csv("abalone.train")
x = x[,1:8]
print("Classificando...")
net.results = compute(net.abalone, x)
print("Classificado!")
#print("Results")
#print(net.results)

test=read.csv("abalone.train")
test=test[,9:9]

i=1
error=0
for(net.result in net.results$net.result)
{

#	result=round((net.result+1)*14.05,0)
	print(paste0("Resultado: ",result, " Esperado: ", test[i] ))

	if(result!=test[i])
		error=error+1
	i=i+1
}
percent=error/i
percent=percent*100
print(paste0("Total de testes:", i))
print(paste0("Total de erros: ", error  ))
print(paste0("Percentual de erro: ", percent, "% "  ))


####################################################################################
# description: Example for loading Tidepool data and calculating cgm stats in R
# version: 0.0.1
# created: 2018-07-17
# author: Jason Meno
# license: BSD-2-Clause
####################################################################################

# Set location of data
dataPath = file.path("..","example-data")

# load csv data
data = read.csv(file.path(dataPath,
                       "example-from-j-jellyfish.csv"),
                       stringsAsFactors = FALSE)

# View the first 5 rows of data
head(data)

# Get a list of all data columns
colnames(data)

# Get the unique data types
unique(data$type)

# get just the cgm data
cgm = data[data$type=="cbg",]

# look at the first 5 rows of data
head(cgm)

# rename "value" field to "mmol_L"
colnames(cgm)[colnames(cgm)=="value"] = "mmol_L"

# convert mmol/L to mg/dL and create a new field
cgm$mg_dL = as.integer(cgm$mmol_L * 18.01559)

# view the cgm mg/dL data
head(cgm$mg_dL)

# define a function that captures the Ambulatory Glucose Profile statistics
# http://www.agpreport.org/agp/agpreports#CGM_AGP
get_stats = function(df){

    statsDF = data.frame(matrix(nrow=1,ncol=0))

    totalNumberCBGValues = length(df$mg_dL)
    statsDF$totalCgmValues = totalNumberCBGValues

    df$deviceTime = as.POSIXct(df$deviceTime,format="%Y-%m-%dT%H:%M:%S")
    firstDataPoint = min(df$deviceTime)
    lastDataPoint = max(df$deviceTime)

    if(grepl("FreeStyle", df$deviceId[1])==TRUE){
        dataFrequency = 15
    }else{
        dataFrequency = 5
    }

    totalPossibleCgmValues = round(as.integer(difftime(lastDataPoint,
                                    firstDataPoint,
                                    units="min"))/dataFrequency)

    statsDF$totalPossibleCgmReadings = totalPossibleCgmValues

    statsDF$percentOfPossibleCgmReadings =
                   totalNumberCBGValues / totalPossibleCgmValues

    statsDF$firstDataPoint = firstDataPoint
    statsDF$lastDataPoint = lastDataPoint
    statsDF$daysOfCgmData = as.integer(
            difftime(as.Date(lastDataPoint),
                     as.Date(firstDataPoint),
                     units="days"))

    mean_mgdL = mean(df$mg_dL)
    statsDF$mean_mgdL = mean_mgdL

    std_mgdL = sd(df$mg_dL)
    statsDF$std_mgdL = std_mgdL

    cov_mgdL = std_mgdL / mean_mgdL
    statsDF$cov_mgdL = cov_mgdL

    totalBelow54 = sum(df$mg_dL < 54)
    statsDF$percentBelow54 = totalBelow54 / totalNumberCBGValues

    totalBelow70 = sum(df$mg_dL < 70)
    statsDF$percentBelow70 = totalBelow70 / totalNumberCBGValues

    total70to180 = sum((df$mg_dL >= 70) & (df$mg_dL <= 180))
    statsDF$percentTimeInRange = total70to180 / totalNumberCBGValues

    totalAbove180 = sum(df$mg_dL > 180)
    statsDF$percentAbove180 = totalAbove180 / totalNumberCBGValues

    totalAbove250 = sum(df$mg_dL > 250)
    statsDF$percentAbove250 = totalAbove250 / totalNumberCBGValues

    statsDF$min_mgdL = min(df$mg_dL)
    statsDF$`10%` = quantile(df$mg_dL,0.10)
    statsDF$`25%` = quantile(df$mg_dL,0.25)
    statsDF$median = quantile(df$mg_dL,0.50)
    statsDF$`75%` = quantile(df$mg_dL,0.75)
    statsDF$`90%` = quantile(df$mg_dL,0.90)
    statsDF$max_mgdL = max(df$mg_dL)

    # get estimated HbA1c or Glucose Management Index (GMI)
    # GMI(%) = 3.31 + 0.02392 x [mean glucose in mg/dL]
    # https://www.jaeb.org/gmi/
    statsDF$GMI = 3.31 + (0.02392 * mean_mgdL)

    return(statsDF)

}

# apply function to get stats
cgmStats = get_stats(cgm)
t(cgmStats)


#
# R script for plotting cdist as function of the number of clusters
#

infile <- "debug_cdist.csv"
plotfilename <- "debug_cdist.pdf"

message(sprintf("cdist plot is written to '%s'", plotfilename))

cyan <- rgb(007,161,226,maxColorValue=255)

x <- rev(read.csv(infile, header=FALSE)[,1])
n <- length(x)
k <- min(c(80,n-1))
x.tail <- x[1:k]

# two sigma expected jump width
expjump <- function(x,k) {
    y <- rep(0,k) # preallocation
    for (i in 1:k) {
        y[i] <- x[i+1] + 2*sd(x[i:n], na.rm=TRUE)
    }
    return(y)
}

# set plot parameters
pdf(plotfilename, width=6, height=4)
par(lwd=1, ps=14, mar=c(3.5,3.5,0.5,0.5), cex.lab=1.0, family="Times")

# plot of cdist valaues
plot(1:k, x.tail, type='l', xlab=expression(italic('number of clusters, i.e. ') (m-i)), ylab=expression(italic('cdist')), mgp=c(2.5,1,0))
points(1:k, x.tail)

# plot comparison line of automatic threshold
z <- expjump(x,k)
lines(1:k, z, col="red")
if (any(z[1:k] < x[1:k])) {
    t.index <- max(which(z[1:k] < x[1:k]))
    t <- z[t.index]
    lines(c(-1,k+4), c(t,t), col=cyan)
    text(expression(italic('automatic threshold')), x=k-15, y=t, pos=3, col=cyan)
}
legend("topright", c(expression(italic("cdist")[i]), expression(italic("cdist")[i-1] + sigma^{(i)})), col=c("black","red"), lty=c(1,1))

# close pdf outfile
grabage <- dev.off()


print(paste0(
  Sys.time(), " --- Taxonomic effort - publications (boxplot + violin plot)"
))

# Individual plots

## Mean number of species per publication by decade

# Used in chapter 2 as supporting information

p <- ggplot(df_publications_N) +
    theme_minimal() +
    geom_histogram(aes(x=n_species), binwidth=1) +
    xlab('\n Number of species') + ylab('Number of publications (log scale)\n')
f <- paste0(dir_plot2, 'n-species-pub.png')
ggsave(f, p, units="cm", width=16, height=12, dpi=300)

N_spp_per_pub_decade <- df_publications_N[,
    list(
        mean_N_spp = mean(n_species),
        median_N_spp = as.double(median(n_species)),
        perc_75 = quantile(n_species, .75)
    ),
    by = "date.decade"
][order(date.decade)]

N_spp_per_des_decade[, c('date.decade', 'median_N_spp')]

N_spp_per_pub_decade

df_publications_N[date.decade == "1750s"]

calc_median <- function(x){
  return(c(y = -5, label = length(x)))
  # experiment with the multiplier to find the perfect position
}

x_axis <- unique(df_publications_N$date.decade)
x_axis[rep(c(FALSE, TRUE), length(x_axis)/2)] <- ""

plot_tax_pub_decade <-
    ggplot(data=df_publications_N, aes(x=date.decade, y=n_species)) +
        geom_line(
            data=N_spp_per_pub_decade,
            mapping=aes(x=date.decade, y=median_N_spp, group=1),
            size=1, color='grey70'
        ) +
        geom_boxplot(width=.5, outlier.size=NULL, fill="white", outlier.shape=NA) +
        geom_jitter(shape=16, position=position_jitter(0.2),
                    size=0.2, alpha=0.2, color='grey10') +
        scale_y_continuous(limit=c(-5, 40)) +
        scale_x_discrete(breaks = x_axis) +
        xlab("\nDecade") +
        ylab("Number of species \nper publication\n") +
        theme + theme_minimal(base_size=10)

# Old plot
# plot_tax_pub_decade <-
#     ggplot(data=df_publications_N, aes(x=date.decade, y=n_species)) +
#         geom_violin(width=3, fill="grey", alpha=.7, color="grey40", trim=T) +
#         # geom_boxplot(width=0.2, outlier.size=NULL, fill="white") +
#         geom_jitter(
#             shape=16, position=position_jitter(0.2),
#             size=0.2, alpha=0.2, color='grey10'
#         ) +
#         geom_point(
#             data=N_spp_per_pub_decade,
#             mapping=aes(x=date.decade, y=median_N_spp, group=1),
#             size=2, color='black'
#         ) +
#         geom_line(
#             data=N_spp_per_pub_decade,
#             mapping=aes(x=date.decade, y=median_N_spp, group=1),
#             size=1, color='black'
#         ) +
#         # geom_line(
#         #    data=N_spp_per_pub_decade,
#         #    mapping=aes(x=date.decade, y=mean_N_spp, group = 1),
#         #    size=1.3, color="red", alpha=0.9, linetype='dashed'
#         # ) +
#         scale_y_continuous(limit=c(-5, 40)) +
#         # stat_summary(
#         #    fun.data=calc_median, geom="text", fun=median,
#         #    position=position_dodge(width = 0.75), size=3
#         # ) +
#         scale_x_discrete(breaks = x_axis) +
#         xlab("\nDecade") +
#         ylab("Number of species \nper publication\n") +
#         theme

## Species per author across years

N_spp_per_des_decade <- df_describers_year[,
    list(
        mean_N_spp = mean(N),
        median_N_spp = as.double(median(N)),
        perc_75 = quantile(N, .75)
    ),
    by = "date.decade"
][order(date.decade)]

# https://stackoverflow.com/questions/12125364 median issue

df_describers_year[date.decade == "1750s"]

plot_tax_des_decade <-
    ggplot(data=df_describers_year, aes(x=date.decade, y=N)) +
        # geom_violin(width=3, fill="grey", alpha=.7, color="grey40") +
        # geom_point(
        #     data=N_spp_per_des_decade,
        #     mapping=aes(x=date.decade, y=median_N_spp, group=1),
        #     size=2, color='black', shape=1
        # ) +
        geom_line(
            data=N_spp_per_des_decade,
            mapping=aes(x=date.decade, y=median_N_spp, group=1),
            size=1, color='grey70'
        ) +
        # geom_line(
        #    data=N_spp_per_des_decade[date.decade != "1750s"],
        #    mapping=aes(x=date.decade, y=mean_N_spp, group=1),
        #    size=1, color='grey'
        # ) +
        geom_boxplot(width=.5, outlier.size=NULL, fill="white", outlier.shape=NA) +
        geom_jitter(shape=16, position=position_jitter(0.2),
            size=0.2, alpha=0.2, color='grey10') +
        scale_y_continuous(limit=c(-5, 40)) +
        scale_x_discrete(breaks = x_axis) +
        # stat_summary(
        #    fun.data=calc_median, geom="text", fun=median,
        #    position=position_dodge(width = 0.75), size=3
        # ) +
        xlab("\nDecade") +
        ylab("Number of species \nper PTE\n") +
        theme + theme_minimal(base_size=10)

# Save plots
ggsave(paste0(dir_plot, 'fig-2a.png'), plot_tax_pub_decade, units="cm", width=13.5, height=6, dpi=300)
ggsave(paste0(dir_plot, 'fig-2b.png'), plot_tax_des_decade, units="cm", width=13.5, height=6, dpi=300)

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

# Trend analysis
N_spp_per_pub_decade[date.decade != "1750s"]$median_N_spp
N_spp_per_des_decade[date.decade != "1750s"]$median_N_spp

res <- MannKendall(
    N_spp_per_pub_decade[date.decade != "1750s"]$median_N_spp
)

print("--------------------------")
print("Trend test: mean species per publication")
summary(res)

res <- MannKendall(N_spp_per_des_decade[date.decade != "1750s"]$median_N_spp)
print("--------------------------")
print("Trend test: mean species per describer")
summary(res)


C -> D (1)
E -> B (1)
E -> G (1)
C -> E (2)
A -> D (3)
D -> F (6)


#' @export
#' @title convert.dd.dddd
#' @description This function can convert various formats to decimal degrees or to degrees-minutes
#' @param \code{x} = coordinates
#' @param \code{format} = dec.deg Acceptable values include dec.deg, deg.min
#' @author Brad Hubley
#' @examples
#' convert.dd.dddd(4730.3)
#' [1] 47.505
#' convert.dd.dddd(47.505, 'deg.min')
#' [1] 4730.3
#' @family coordinate converters
#' @export
convert.dd.dddd<-function(x,format='dec.deg'){

	if(format=='dec.deg'){
		dat<-data.frame(ddmm.mm=x,dd.dddd=NA)

			#degrees-minutes-seconds -> degrees
			ddmmss<-dat$ddmm.mm[!is.na(dat$ddmm.mm)&abs(dat$ddmm.mm)>9000]
			ddmm.ss<-ddmmss/100
			ddmm<-trunc(ddmm.ss)
			ss<-(ddmm.ss-ddmm)*100
			dd.mm<-ddmm/100
			dd<-trunc(dd.mm)
			mm<-(dd.mm-dd)*100
			dat$dd.dddd[!is.na(dat$ddmm.mm)&abs(dat$ddmm.mm)>9000]<-dd+mm/60+ss/3600

			#degrees-minutes -> degrees
			dd.mmmm<-dat$ddmm.mm[!is.na(dat$ddmm.mm)&abs(dat$ddmm.mm)>90&abs(dat$ddmm.mm)<9000]/100
			dd<-trunc(dd.mmmm)
			mm.mm<-(dd.mmmm-dd)*100
			dat$dd.dddd[!is.na(dat$ddmm.mm)&abs(dat$ddmm.mm)>90&abs(dat$ddmm.mm)<9000]<-dd+mm.mm/60

			#degrees -> degrees
			dat$dd.dddd[!is.na(dat$ddmm.mm)&abs(dat$ddmm.mm)<90]<-dat$ddmm.mm[!is.na(dat$ddmm.mm)&abs(dat$ddmm.mm)<90]

		return(dat$dd.dddd)
	}

	if(format=='deg.min'){
		dat<-data.frame(ddmm.mm=NA,dd.dddd=x)

			#degrees-minutes-seconds -> degrees-minutes
			ddmmss<-dat$dd.dddd[!is.na(dat$dd.dddd)&abs(dat$dd.dddd)>9000]
			ddmm.ss<-ddmmss/100
			ddmm<-trunc(ddmm.ss)
			ss<-(ddmm.ss-ddmm)*100
			dat$ddmm.mm[!is.na(dat$dd.dddd)&abs(dat$dd.dddd)>9000]<-ddmm+ss/60

			#degrees-minutes -> degrees-minutes
			dat$ddmm.mm[!is.na(dat$dd.dddd)&abs(dat$dd.dddd)>90&abs(dat$dd.dddd)<9000]<-dat$dd.dddd[!is.na(dat$dd.dddd)&abs(dat$dd.dddd)>90&abs(dat$dd.dddd)<9000]

			#degrees -> degrees-minutes
			dd.dddd<-dat$dd.dddd[!is.na(dat$dd.dddd)&abs(dat$dd.dddd)<90]
			dd<-trunc(dd.dddd)
			mm.mm<-(dd.dddd-dd)*60
			dat$ddmm.mm[!is.na(dat$dd.dddd)&abs(dat$dd.dddd)<90]<-dd*100+mm.mm

		dat$ddmm.mm
	}

}


library(imager)

data_images <- array(, dim = c(1000, 201, 201))

for (i in 1:1000) {
  str_path <- paste0("Desktop/1000_imgs/SLIKA", i, ".png")
  im <- load.image(str_path)
  data_images[i, , ] <- im[1:201, 1:201]
}

data_labels <- array(, dim = c(1000, 2))
data_labels <- INPUT

data_x <- array(, dim = c(1000, 101))
for (i in 1:1000) {
  data_x[i, ] <- data_images[i, 101, 101:201]
}

set.seed(12)
training_indices <- sample(seq_len(251), size = round(251 * 0.8))
train_data <- data_x[training_indices, ]
test_data <- data_x[-training_indices, ]
train_labels <- data_labels[training_indices, ]
test_labels <- data_labels[-training_indices, ]

library(keras)

model <- keras_model_sequential()
model %>%
  layer_dense(units = 3000, activation = 'relu', input_shape = c(101)) %>%
  #layer_dropout(rate = 0.3) %>%
  layer_dense(units = 1500, activation = 'relu') %>%
  #layer_dropout(rate = 0.4) %>%
  layer_dense(units = 1500, activation = 'relu') %>%
  #layer_dropout(rate = 0.3) %>%
  layer_dense(units = 750, activation = 'relu') %>%
  #layer_dropout(rate = 0.2) %>%
  layer_dense(units = 2)

summary(model)

model %>% compile(
  loss = "mse",
  optimizer = optimizer_rmsprop(),
  metrics = list("mean_absolute_error")
)

history <- model %>% fit(
  train_data,
  train_labels,
  epochs = 100,
  validation_split = 0.2
)

model %>% evaluate(test_data, test_labels)

predicted <- model %>% predict(test_data)
predicted <- cbind(predicted, test_labels)


=begin
((<Algebra>))

= Algebra
((*(Module for Algebra)*))

This is a module containing:

* ((<Algebra::Polynomial|URL:polynomial.html>))
* ((<Algebra::MPolynomial|URL:m-polynomial.html>))
* ((<Algebra::ResidueClassRing|URL:residue-class-ring.html>))
* ((<Algebra::LocalizedRing|URL:localized-ring.html>))
* ((<Algebra::MatrixAlgebra|URL:matrix-algebra.html>))
* etc.

== Asocciated Files:
* Let (({require "algebra.rb"})) then

    include Algebra

  has done. And (({require})) the scripts defining above modules, automatically.

== SuperClass:

* ((|Object|))

== Included Modules:

none.

== ClassMethods:

--- Algebra.Polynomial(ring [, obj0 , obj1 [, ...]])
    Refer ((<Algebra.Polynomial|URL:polynomial.html#Algebra_S_Polynomial>))().

--- Algebra.MPolynomial(ring [, obj0 [, obj1 [, ...]]])
    Refer ((<Algebra.MPolynomial|URL:m-polynomial.html#Algebra_S_MPolynomial>))().

--- Algebra.ResidueClassRing(ring, mod)
    Refer ((<Algebra.ResidueClassRing|URL:residue-class-ring.html#Algebra_S_ResidueClassRing>))()

--- Algebra.AlgebraicExtensionField(field, obj){|x| ... }
    Refer ((<Algebra.AlgebraicExtensionField|URL:residue-class-ring.html#Algebra_S_AlgebraicExtensionField>))().

--- Algebra.MatrixAlgebra(ring, m, n)
    Refer ((<Algebra.MatrixAlgebra|URL:matrix-algebra.html#Algebra_S_MatrixAlgebra>))(ring, m, n).

--- Algebra.Vector(ring, n)
    Refer ((<Algebra.Vector|URL:matrix-algebra.html#Algebra_S_Vector>))(ring, n).

--- Algebra.Covector(ring, n)
    Refer ((<Algebra.Covector|URL:matrix-algebra.html#Algebra_S_Covector>))(ring, n).

--- Algebra.SquareMatrix(ring, size)
    Refer ((<Algebra.SquareMatrix|URL:matrix-algebra.html#Algebra_S_SquareMatrix>))(ring, n).

=end


library(nloptr)
library(rlist)
library(Rlab)
library(bssm)

fit = function(observed_I, f_inc, f_inf, prior_R, lags=7, lags2=3){
  "
  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  f_inc : numeric vector
    Incubation  time distribution. Should be the same length as 'observed_I'.
  f_inf : numeric vector
    Infectious  time distribution. Should be the same length as 'observed_I'.

  Returns
  -------
  model : list
    model betas , R and R_c.
  "
  omega = NULL
  F_inf = cumsum(f_inf)
  right_tail_inf = c(1, 1 - F_inf)
  for (tau in 1:length(observed_I)) {
    omega = c(omega, 0)
    for (tau_prime in 1:tau) {
      omega[tau] = omega[tau] + f_inc[tau_prime] * right_tail_inf[tau - tau_prime + 1]
    }
  }

  f = f_inc[1:lags2]
  f = f/sum(f)

  infection_time = sum(omega,na.rm=TRUE)
  priorMean= prior_R / infection_time

  expected_value = sum((omega/sum(omega))*seq(1,length(omega)))

lags3 = 9
#cases=base$newCases
  initialVector=rep(0,lags3)
  cases= observed_I

 #Dependiente
  casesMatrix_T=matrix(0,length(cases)-lags2+1,lags2)
  for(i in 1:dim(casesMatrix_T)[1]){
    casesMatrix_T[i,]=cases[i:(i+lags2-1)]
  }
  incubPotential_T=casesMatrix_T%*%f

  omega = omega[1:lags]

  omega = rev(omega*infection_time/sum(omega))

  #Independiente
  longCases=c(initialVector,cases)
  casesMatrix_T=matrix(0,length(longCases)-lags,lags)
  for(i in 1:dim(casesMatrix_T)[1]){
    casesMatrix_T[i,]=longCases[i:(i+lags-1)]
  }
  infectPotential_T=casesMatrix_T%*%omega
  infectPotential_T=infectPotential_T[1:length(incubPotential_T)]
  infectPotential_T[1]=1

   pars=c(0,0)
    obj1 <- function(pars) {
      tryCatch({
      pars2=pars
      pars2=exp(pars2)
      x=log(infectPotential_T)
      y=as.matrix(incubPotential_T)
      Z=t(cbind(as.matrix(x),1,0))
      n=length(incubPotential_T)
      dim(Z)=c(1,3,n)
      Z=as.array(Z)
      Ti=rep(c(1,0,0,0,1,0,0,1,1),n)
      dim(Ti)=c(3,3,n)

      R=rep(c(0,pars2[1],0,0,0,pars2[2]),n)
      dim(R)=c(3,2,n)

      a1=c(1,priorMean,priorMean)
      P1=diag(c(0,10^9,10^9))
      distribution="poisson"
      u=0
      model=ssm_mng(y, Z, Ti, R, a1, P1, distribution, state_names=c("Base", "Beta", "Beta_P"))

      objectiveFunction=-logLik(model, nsim = 1000, nsim_states = 0)
      if(objectiveFunction==-Inf){
        objectiveFunction=-objectiveFunction
      }
      }, error = function(e) {
        objectiveFunction=Inf
      } )
      return(objectiveFunction)
    }

    lb=c(-10,-10)
    ub=c(10,10)
    x0 = c(0,0)

    local_opts = list( "algorithm" = "NLOPT_LN_BOBYQA",
                       "xtol_rel" = 1.0e-7 )
    opts = list( "algorithm" = "NLOPT_LN_BOBYQA",
                 "xtol_rel" = 1.0e-7,
                 "maxeval" = 100000,
                 "local_opts" = local_opts )

    res = nloptr( x0=x0, eval_f=obj1, eval_grad_f=NULL,lb=lb, ub=ub, opts=opts)
    pars=res$solution

    pars2=pars
    pars2=exp(pars2)
    x=log(infectPotential_T)
    y=as.matrix(incubPotential_T)
    Z=t(cbind(as.matrix(x),1,0))
    n=length(incubPotential_T)
    dim(Z)=c(1,3,n)
    Z=as.array(Z)
    Ti=rep(c(1,0,0,0,1,0,0,1,1),n)
    dim(Ti)=c(3,3,n)

    R=rep(c(0,pars2[1],0,0,0,pars2[2]),n)
    dim(R)=c(3,2,n)

    a1=c(1,priorMean,priorMean)
    P1=diag(c(0,10^9,10^9))
    distribution="poisson"
    u=0
    model=ssm_mng(y, Z, Ti, R, a1, P1, distribution, state_names=c("Base", "Beta", "Beta_P"))
    betaT=sim_smoother(model, nsim = 1)[-1,2,1]
    for(h in 2:1000){
      betaT=cbind(betaT,sim_smoother(model, nsim = 1)[-1,2,1])
    }

    beta=exp(betaT)

    simuQL=function(simu){
      return(quantile(simu,c(0.05,0.95)))
    }

  data=cbind(t(apply(beta, 1, simuQL)),apply(beta, 1, mean))
  colnames(data)=c("lb","ub", "beta")

  # lb=qgamma(0.05, shape=shape1, rate=rate1)
  # ub=qgamma(0.95, shape=shape1, rate=rate1)
  # beta=((shape1-1)/rate1)
  #
  # data=cbind(betaParameteres,lb, beta,ub)
  data=as.data.frame(data)
  data$R=data$beta*sum(omega)
  data$Rlb=data$lb*sum(omega)
  data$Rub=data$ub*sum(omega)

  #R_Caso
  lb=data$lb
  ub=data$ub
  beta=data$beta
  longCaseslb=c(rep(lb[1], length=lags-1),lb)
  longCasesub=c(rep(ub[1], length=lags-1),ub)
  longCasesbeta=c(rep(beta[1], length=lags-1),beta)

  data$R_c=data$beta*sum(omega)
  data$R_clb=data$lb*sum(omega)
  data$R_cub=data$ub*sum(omega)

  for(i in 1:dim(betaT)[1]){
    for(j in 1:i){
      data$R_c[i]=data$R_c[i] + (longCasesbeta[i]*omega[j])
      data$R_clb[i]=data$R_clb[i] + (longCaseslb[i]*omega[j])
      data$R_cub[i]= data$R_cub[i] + (longCasesub[i]*omega[j])
    }
  }
  return(list(data=data))
}


# The BiT-age method, one of the first methods we'll try, was designed and
# published by David Meyer and Bjorn Schumacher
# (https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7963339/)
# (https://github.com/Meyer-DH/AgingClock)

the_glmnet_func <- function(df) {
  library(caret) # install.packages(c("caret", "glmnet"))
  library(glmnet)

  ages <- df$age
  df <- df[,-1]
  variances <- apply(df, 2, var)
  df <- df[, order(variances, decreasing = TRUE)[1:2000]]
  df$age <- ages

  # adjuvant subfunction
  get_best_result = function(caret_fit) { # from https://daviddalpiaz.github.io/r4sl/elastic-net.html
    best = which(rownames(caret_fit$results) == rownames(caret_fit$bestTune))
    best_result = caret_fit$results[best, ]
    rownames(best_result) = NULL
    best_result
  }

  set.seed(42)
  cv_3 = trainControl(method = "cv", number = 3)

  hit_elnet = train(
    age ~ ., data = df,
    method = "glmnet",
    trControl = cv_3
  )

  return(get_best_result(hit_elnet))
}

gtex_data <- readRDS("GTEX_21blood_samples.rds")
dim(gtex_data) # 21 54272
gtex_data <- gtex_data[,colSums(gtex_data)!=0] # remove genes that are zero-only
dim(gtex_data) # 21 39702

gtex_ages <- gtex_data[,"age"]
gtex_tpms <- gtex_data[,colnames(gtex_data) != "age"]
dim(gtex_tpms) # 21 39701

mod_tpms <- gtex_data
mod_tpms[mod_tpms==0] <- NA # This is justified by this: https://github.com/Meyer-DH/AgingClock/blob/b6980add65779be9da8af883409bed5f6f5e0e87/src/biological_age_prediction.py#L17

# Binarize based on whether TPM (similar to CPM) is above median or not.
sample_median_TPMs <- apply(mod_tpms, 1, FUN = function(x) {return(median(x, na.rm=TRUE))})
for (i in 1:nrow(mod_tpms)) {
  mod_tpms[i,] <- ifelse(mod_tpms[i,] > sample_median_TPMs[i], 1, 0)
}
mod_tpms[is.na(mod_tpms)] <- 0

# Doing the model with no binarisation ------
df <- as.data.frame(cbind(age=gtex_ages, gtex_tpms))
nobLM <- the_glmnet_func(df)
nobLM

# Doing the model with    binarisation ------
df <- as.data.frame(cbind(age=gtex_ages, mod_tpms))
binLM <- the_glmnet_func(df)
binLM

# Too few samples to be sure, but so far it looks like BiT-age is not a better predictor in blood samples from GTEX


all_global_data <- read.table("global-dump.txt",
                              header = TRUE,
                              sep="\t",
                              col.names=c("ap", "pr","au", "gt",
                                          "rms", "pklv", "rssi", "snr", "loc"),
                              fill=FALSE,
                              strip.white=TRUE)

global_data <- all_global_data[c("ap", "pr", "gt", "rms", "pklv", "rssi")]
phone_data_gt <- all_global_data[c("gt", "ap", "rms", "pklv", "rssi")]
phone_data_pr <- all_global_data[c("pr", "ap", "rms", "pklv", "rssi")]

# 1. Linear Model
model1.gt <- lm(gt~., phone_data_gt)
summary(model1.gt)

# cross validation
library(DAAG)
coba <- cv.lm(data=phone_data_gt, model1.gt, m=459)
cv.lm(data=phone_data_gt, model1.gt, m=10)

# standard mean suare error
predictions <- predict(model1.gt, phone_data_gt)
mean((phone_data_gt$gt - predictions)^2)

library(caret)
fitControl <- trainControl(
  method = "repeatedcv",
  number = 10,
  repeats = 10)
gbmGrid <-  expand.grid(cost=seq(0,10,1))

lasso.gt <- train(gt~., data=phone_data_gt, method="lasso",
                  trControl=fitControl, tuneGrid = gbmGrid)
ridge.gt <- train(gt~., data=phone_data_gt, method="ridge", metric="residual",
                  trControl=fitControl, tuneGrid = gbmGrid)
gcvEarth.gt <- train(gt~., data=phone_data_gt, method="gcvEarth")
svm.gt <- train(gt~., data=phone_data_gt, method="svmLinear2",metric="residual",
                trControl=fitControl, tuneGrid = gbmGrid)
linear.gt <- train(gt~., data=phone_data_gt, method="leapForward")
nnet.gt <- train(gt~., data=phone_data_gt, method="nnet")
knn.gt <- train(gt~., data=phone_data_gt, method="knn")


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(1:30, 10)

  p1 = x + 1
  p2 = 1 + x
  p3 = x + x

  m1 = x - 1
  m2 = 1 - x

  t1 = x * 2
  t2 = 2 * x

  d1 = x / 2
  d2 = 2 / x

  pow = x^(-1)
} else {
  x = NULL
}

dx = expand(x)

p1_t = collapse(dx + 1)
p2_t = collapse(1 + dx)
p3_t = collapse(dx + dx)
comm.print(all.equal(p1, p1_t))
comm.print(all.equal(p2, p2_t))
comm.print(all.equal(p3, p3_t))

m1_t = collapse(dx - 1)
m2_t = collapse(1 - dx)
comm.print(all.equal(m1, m1_t))
comm.print(all.equal(m2, m2_t))

t1_t = collapse(dx * 2)
t2_t = collapse(2 * dx)
comm.print(all.equal(t1, t1_t))
comm.print(all.equal(t2, t2_t))

d1_t = collapse(dx / 2)
d2_t = collapse(2 / dx)
comm.print(all.equal(d1, d1_t))
comm.print(all.equal(d2, d2_t))

pow_t = collapse(dx ^ (-1))
comm.print(all.equal(pow, pow_t))

finalize()


johnson_tol <- function(x, jfit='all', alpha=0.01, P=0.99, side=1, plots='no') {

    ## input:   x     = data set
    ##          alpha = 1 - confidence
    ##          P     = proportion = coverage (tolerance interval only)
    ##          side  = 1 = 1-sided tolerance limit
    ##                = 2 = 2-sided tolerance limit
    ##          jfit  = 'all' = uses SuppDists::JohnsonFit to determine parameters
    ##                = 'SU'  = uses ExtDist::eJohnsonSU to determine parameters
    ##                = list of user specified parameters
    ##                  e.g., jparms <- list(gamma   = -1.039,
    ##                                       delta   = 1.66,
    ##                                       xi      = 14.46,
    ##                                       lambda  = 6.95,
    ##                                       type    = 'SU',
    ##                       johnson_tol(mtcars$mpg, jfit=jparms)
    ##
    ## output:  jparms = Johnson fit parameters used in tolerance limit calculation
    ##          xtol_lower = lower bound tolerance limit
    ##          xtol_upper = upper bound tolerance limit

    proportion <- P

    ##--------------------------------------------------------
    ## initialize tolerance limits
    xntol_lower  = NA
    xntol_upper  = NA
    xtol_lower   = NA
    xtol_upper   = NA

    ##--------------------------------------------------------
    ## determine Johnson parameters

    if (jfit[1] == 'all') {
        ## let R figure out which Johnson distribution fits best
        jparms  <- SuppDists::JohnsonFit(x)
    } else if (jfit[1] == 'SU') {
        ## force the Johnson SU distribution
        jparms.out <- ExtDist::eJohnsonSU(x)
        jparms <- list(gamma   = jparms.out$gamma,
                       delta   = jparms.out$delta,
                       xi      = jparms.out$xi,
                       lambda  = jparms.out$lambda,
                       type    = 'SU')
    } else {
        ## use Johnson parameters specified in jfit
        ## needs to be in same list format as created by SuppDists::JohnsonFit
        jparms <- jfit
    }
    gamma  <- jparms$gamma
    delta  <- jparms$delta
    xi     <- jparms$xi
    lambda <- jparms$lambda
    type   <- jparms$type

    ##--------------------------------------------------------
    ## transform x to normal distribution, xn
    ## https://www.sigmamagic.com/blogs/how-do-i-transform-data-to-normal-distribution/

    if (type == 'SU') {
        xn <- gamma + delta * asinh( (x - xi)/ lambda )
    } else if (type == 'SB') {
        xn <- try( gamma + delta *   log( (x - xi)/(lambda + xi - x) ) )
    } else {
        ## type == 'SL'
        xn <- try( gamma + delta *   log( (x - xi)/ lambda ) )
    }
    df <- data.frame(x, xn)

    if (plots != 'no') {
        plotspace(1,2)
        hist(x)
        hist(xn)
    }

    ##--------------------------------------------------------
    ## error check then proceed
    na_rows <- df[is.na(df$xn),]
    if (nrow(na_rows) != 0) {

        ## xn values could not be calculated for all x values
        cat('\n')
        cat('#####################################\n')
        cat('  ERROR IN JOHNSON_TOL  \n')
        cat('  xn(x) = NA or NaN for some x values \n')
        cat('#####################################\n')
        print(jparms)
        print(na_rows)
        xntol_out <- tolerance::normtol.int(xn, alpha = alpha, P=proportion, side=side)
    }

    ##--------------------------------------------------------
    ## calculate normal tolerance limit, xntol

    xntol_out <- tolerance::normtol.int(xn, alpha = alpha, P=proportion, side=side)
    if (side == 1) {
        xntol_lower <- xntol_out$'1-sided.lower'
        xntol_upper <- xntol_out$'1-sided.upper'
    } else if (side == 2) {
        xntol_lower <- xntol_out$'2-sided.lower'
        xntol_upper <- xntol_out$'2-sided.upper'
    }

    ##-----------------------------------------------------------------------------
    ## transform xntol back to johnson tolerance limit, xtol

    if (type == 'SU') {
        ## xn <- gamma + delta * asinh( (x - xi)/ lambda )
        xtol_lower = xi + lambda * sinh( (xntol_lower - gamma)/delta )
        xtol_upper = xi + lambda * sinh( (xntol_upper - gamma)/delta )

    } else if (type == 'SB') {
        ## Not sure tolerance limits have meaning for a bounded fit,
        ## but can define lower and upper bounds.

        ## Given xn <- gamma + delta *   log( (x - xi)/(lambda + xi - x) )
        ## Johnson SB undefined for (x - xi)/(lambda + xi - x) <= 0

        ## Based on aboove and knowing lambda > 0 by definition:
        ## On low end, need x-xi > 0
        xtol_lower <- xi
        ## On high end, need lambda + xi - x > 0
        xtol_upper <- lambda + xi

    } else {
        ## type == 'SL'
        ## xn <- gamma + delta *   log( (x - xi)/ lambda )
        ## On low end, need x-xi > 0 since lambda is defined as > 0
        xtol_lower <- xi
        xtol_upper <- xi + lambda * exp( (xntol_upper - gamma)/delta )

    }

    return(list(sided=side,
                alpha=alpha,
                P=P,
                jfit=jfit,
                jparms=jparms,
                x=x,
                xn=xn,
                xtol_lower=xtol_lower,
                xtol_upper=xtol_upper))
}

## ## test

## johnson_tol(mtcars$mpg)

## out <- johnson_tol(mtcars$mpg)
## upper_tolerance_limit_john <- out$xtol_upper
## upper_tolerance_limit_john
## jparms <- out$jparms

## johnson_tol(mtcars$mpg, jfit=jparms)


# this is quick
# under an hour
# depends on TP-FP-yeast-setup.r
if(!exists('output.summary.edgeR')){
  load(paste(my.path,'data/output.summary.edgeR.Rda', sep=''))
}

run.this=FALSE
# takes less than an hour

if(run.this == TRUE){

group <- factor(c(rep("WT",43),rep("SN", 41)))

y <- DGEList(counts=d.good, group=group)

keep <- filterByExpr(y)

y <- y[keep,,keep.lib.sizes=FALSE]

# normalize library sizes
# here we are scaling the counts in each sample
# choosing a midpoint in each sample
y <- calcNormFactors(y)

# add in the experimental design
design <- model.matrix(~group)

# fit a Negative Binomial to the data
y <- estimateDisp(y,design)

# Log likelihood test (kinda a t-test)
fit <- glmFit(y,design)
lrt <- glmLRT(fit,coef=2)

tt <- topTags(lrt, n=nrow(d.good))

diff.p <- rownames(tt)[which(tt[[1]]$FDR < 0.1)]
diff.FC <- union(rownames(tt)[which(tt[[1]]$logFC > 1)],
  rownames(tt)[which(tt[[1]]$logFC < -1)])
diff.p.FC <- intersect(diff.p,diff.FC)

output.summary2 <- list()
output.summary.edgeR <- list()

# original tests done at 100 replicates
test.size <- 100
max.samples <- 20
registerDoMC(4) # this is the MC backend.

output.summary.edgeR <- foreach(j = 2:max.samples)%dopar%{
    print(j)
	n.samples = j

	summary.stats <- matrix(data=NA, ncol=6, nrow=test.size)

	colnames(summary.stats) <- c('p.TP', 'p.FP', 'FC.TP', 'FC.FP', 'pFC.TP', 'pFC.FP')

	for(i in 1:test.size){
		test.col  <- c(sample(1:43,n.samples), sample(44:84,n.samples))
		group <- factor( c(rep("WT", n.samples), rep("SN",n.samples)) )
		y <- DGEList(counts=d.good[,test.col], group=group)

		keep <- filterByExpr(y)

		y <- y[keep,,keep.lib.sizes=FALSE]

		y <- calcNormFactors(y)

		design <- model.matrix(~group)

		y <- estimateDisp(y,design)

		# Log likelihood test (kinda a t-test)
		fit <- glmFit(y,design)
		lrt <- glmLRT(fit,coef=2)
		tt <- topTags(lrt, n=nrow(d.good))

		test.diff.p <- rownames(tt)[which(tt[[1]]$FDR < 0.1)]
		test.diff.FC <- union(rownames(tt)[which(tt[[1]]$logFC > 1)],
  		  rownames(tt)[which(tt[[1]]$logFC < -1)])
		test.diff.p.FC <- intersect(test.diff.p,test.diff.FC)

		summary.stats[i,1] <- length(intersect(diff.p, test.diff.p))
		summary.stats[i,2] <- length(setdiff(test.diff.p, diff.p))
		summary.stats[i,3] <- length(intersect(diff.FC, test.diff.FC))
		summary.stats[i,4] <- length(setdiff(test.diff.FC, diff.FC))

		summary.stats[i,5] <- length(intersect(test.diff.p.FC, diff.p.FC))
		summary.stats[i,6] <- length(setdiff(test.diff.p.FC, diff.p.FC))
		}
	output.summary2[[j]] <- summary.stats
}
save(output.summary.ty, file=paste(my.path,'data/output.summary.edgeR.Rda', sep=''))

}


# inc_plot_maps_europe_choropleth_countries.r
data(wrld_simpl)
w <- wrld_simpl[wrld_simpl@data[, "NAME"] != "Antarctica",]
m <- spTransform(w, CRS=CRS("+proj=merc"))

plot(m,xlim=c(-2000000,5000000),ylim=c(4000000,10000000),col=rgb(120,120,120,maxColorValue=255),border=F)

x<-readShapeSpatial("myData/NUTS-2006/NUTS_RG_03M_2006.shp",proj4string=CRS("+proj=longlat"))

xls<-read.xls("myData/eb_nuts.xlsx", encoding="latin1")

y<-x[x$NUTS_ID %in% xls$nuts_id,]

m <- spTransform(y, CRS=CRS("+proj=merc"))

source("scripts/inc_datadesign_dbconnect.r")
sql<-paste("select ", mySelection," selection from v_za4972_countries",sep="")
myDataset<-dbGetQuery(con,sql)
attach(myDataset)

myNo<-m$NUTS_ID
myDataset$ref_NUTS_ID<-xls$nuts_id

position<-vector()
for (i in 1:30){
	position[i]<-match(m$NUTS_ID[i], myDataset$ref_NUTS_ID)
}

myColour_no<-cut(myDataset$selection[position],myClasses)
levels(myColour_no)<-myClass_des

plot(m,col=myColourPalette[myColour_no],border="white",add=T)
legend("right",levels(myColour_no),cex=0.95,border=F,bty="n",fill= myColourPalette,text.col="white")


########################################################
####      Perform Mantel tests for both species.    ####
########################################################
########################################################
#####  Genetic distances included Gst (Nei 1973)   #####
#####           and G''st (Hedrick 2005)           #####
########################################################
#####  Geographic distances were evaluated with    #####
#####       and without log transformation         #####
#####         (i.e., Rousset 1997, 2000)           #####
########################################################

##### Load required packages #####
library(vegan)
library(geosphere)
library(mmod)
library(VPLandscapeGenetics)
data(VPLandscapeGenetics)

##### Calculate genetic and geographic distances #####
## Genetic distances
hedrick.SS <- as.matrix(pairwise_Gst_Hedrick(genind.SS))
nei.SS <- as.matrix(pairwise_Gst_Nei(genind.SS))

hedrick.WF <- as.matrix(pairwise_Gst_Hedrick(genind.WF))
nei.WF <- as.matrix(pairwise_Gst_Nei(genind.WF))

## Linearized genetic distances
hedrick.SS.lin <- hedrick.SS / (1-hedrick.SS)
nei.SS.lin <- nei.SS / (1-nei.SS)

hedrick.WF.lin <- hedrick.WF / (1-hedrick.WF)
nei.WF.lin <- nei.WF / (1-nei.WF)

## Geographic distances
geoDist.SS <- as.numeric(distm(latLong.SS, fun=distGeo))
dim(geoDist.SS) <- c(90, 90)
dimnames(geoDist.SS) <- list(1:90, 1:90)

geoDist.WF <- as.numeric(distm(latLong.WF, fun=distGeo))
dim(geoDist.WF) <- c(87, 87)
dimnames(geoDist.WF) <- list(1:87, 1:87)

## Log transform geographic distance
geoDist.SS.log <- log(geoDist.SS)

geoDist.WF.log <- log(geoDist.WF)

##### Perform Mantel tests #####
mantel.hedrick.SS <- mantel(as.dist(hedrick.SS.lin), as.dist(geoDist.SS), permutations = 9999)
mantel.hedrick.log.SS <- mantel(as.dist(hedrick.SS.lin), as.dist(geoDist.SS.log), permutations = 9999)

mantel.nei.SS <- mantel(as.dist(nei.SS.lin), as.dist(geoDist.SS), permutations = 9999)
mantel.nei.log.SS <- mantel(as.dist(nei.SS.lin), as.dist(geoDist.SS.log), permutations = 9999)

mantel.hedrick.WF <- mantel(as.dist(hedrick.WF.lin), as.dist(geoDist.WF), permutations = 9999)
mantel.hedrick.log.WF <- mantel(as.dist(hedrick.WF.lin), as.dist(geoDist.WF.log), permutations = 9999)

mantel.nei.WF <- mantel(as.dist(nei.WF.lin), as.dist(geoDist.WF), permutations = 9999)
mantel.nei.log.WF <- mantel(as.dist(nei.WF.lin), as.dist(geoDist.WF.log), permutations = 9999)