gen_key <- function() {
    # generating random number in range from 0 to 999 (max 3 digit number)
    first_three_digits = sprintf("%d", floor(runif(1, 0, 999+1)))

    while(first_three_digits=="333" || first_three_digits=="444" || first_three_digits=="555" || first_three_digits=="666"
        || first_three_digits=="777" || first_three_digits=="888" || first_three_digits=="999") {
        # regenerating random number to the point when they are not repeating (excluding 111 and 222)
        first_three_digits = sprintf("%d", floor(runif(1, 0, 999+1)))
    }

    while(nchar(first_three_digits)<3) {
        # adding trailing zeros if necessary (to match length of 3)
        first_three_digits = paste(first_three_digits, "0", sep="")
    }

    # generating random number in range from 0 to 999999 (max 6 digit number)
    mul_of_seven = sprintf("%d", floor(runif(1, 0, 999999+1)))

    # creating variable which will be use to count sum of all digits generated in the previous step
    num_added_together = 0

    # creating list of digits from number contained in mul_of_seven variable
    mul_of_seven_split = strsplit(mul_of_seven, "")[[1]]

    # iterating over each digit in list mul_of_seven_split
    for(i in mul_of_seven_split) {
        # adding digit to variable num_added_together
        num_added_together = num_added_together + strtoi(i, 10)
    }

    while(nchar(mul_of_seven)<6) {
        # adding trailing zeros if necessary (to match length of 6)
        mul_of_seven = paste(mul_of_seven, "0", sep="")
    }

    # searching for remainder value to make mul_of_seven divisible by 7
    for(i in 0:6) {
        if((num_added_together+(i+1))%%7==0) {
            # adding this value to the end of mul_of_seven variable
            mul_of_seven = paste(mul_of_seven, sprintf("%d", i+1), sep="")
            break
        }
    }

    # combining all needed variables with dashes and other constants into variable named key
    key = paste(first_three_digits, mul_of_seven, sep="-")

    # displaying generated key to user
    print(key)
}

gen_oem <- function() {
    # generating random number in range from 1 to 366
    first_three_digits = sprintf("%d", floor(runif(1, 1, 366+1)))

    while(nchar(first_three_digits)<3) {
        # adding zeros at the beginning if necessary (to match length of 3)
        temp = first_three_digits
        first_three_digits = paste("0", temp, sep="")
    }

    # generating random number in range from 95 to 102
    second_two_digits = sprintf("%d", floor(runif(1, 95, 102+1)))

    if(nchar(second_two_digits)==3) {
        # if generated number is 3 digits long then remove first digit
        second_two_digits = substr(second_two_digits, 2, 3)
    }

    # generating random number in range from 0 to 99999 (max 5 digit number)
    mul_of_seven = sprintf("%d", floor(runif(1, 0, 99999+1)))

    # creating variable which will be use to count sum of all digits generated in the previous step
    num_added_together = 0

    # creating list of digits from number contained in mul_of_seven variable
    mul_of_seven_split = strsplit(mul_of_seven, "")[[1]]

    # iterating over each digit in list mul_of_seven_split
    for(i in mul_of_seven_split) {
        # adding digit to variable num_added_together
        num_added_together = num_added_together + strtoi(i, 10)
    }

    while(nchar(mul_of_seven)<5) {
        # adding trailing zeros if necessary (to match length of 5)
        mul_of_seven = paste(mul_of_seven, "0", sep="")
    }

    # searching for remainder value to make mul_of_seven divisible by 7
    for(i in 0:6) {
        if((num_added_together+(i+1))%%7==0) {
            # adding this value to the end of mul_of_seven variable
            mul_of_seven = paste(mul_of_seven, sprintf("%d", i+1), sep="")
            break
        }
    }

    # generating random number in range from 0 to 99999 (max 5 digit number)
    last_five_digits = sprintf("%d", floor(runif(1, 0, 99999+1)))

    while(nchar(last_five_digits)<5) {
        # adding trailing zeros if necessary (to match length of 5)
        last_five_digits = paste(last_five_digits, "0", sep="")
    }

    # combining all needed variables with dashes and other constants into variable named key
    key = paste(first_three_digits, second_two_digits, sep="")
    key = paste(key, mul_of_seven, sep="-OEM-0")
    key = paste(key, last_five_digits, sep="-")

    # displaying generated key to user
    print(key)
}

main <- function() {

    print("5 CD Keys:")

    # generating 5 keys (and displaying them)
    for(i in 1:5) {
        gen_key()
    }

    print("")
    print("5 CD Keys (OEM):")

    # generating 5 OEM keys (and displaying them)
    for(i in 1:5) {
        gen_oem()
    }
}

# executing main function
main()


##CTE534_Índices=group
##Imagen=raster
##VERDE=number 2
##NIR=number 4
##NDWI=output raster
##showplots

NDWI <- (Imagen[[VERDE]]-Imagen[[NIR]])/(Imagen[[VERDE]] + Imagen[[NIR]])
plot(NDWI,
     main="NDWI",
     xlab="X",
     ylab="Y")
box()
grid(col="black",
     lwd=1)


####
#
#Library of utility functions we will need to put together the functions needed
#to answer the quiz
#
#####

# function returns a file list as string given a directory and ID of files to fetch
get_files <- function(directory,id = 1:332) {
	#fetch all files in the a directory
	file.names <- list.files(directory, full.names = TRUE)

	#from the file names get a list of numbers
  	file.numbers <- as.numeric(sub('\\.csv$','', basename(file.names)))

  	#from the number vector match the numbers we need from id arguement
  	#and use it to select only those file names
  	selected.files <- na.omit(file.names[match(id, file.numbers)])
}

# function returns a merged data-frame given a R file list as string
merged_data_frame <- function(files) {
	# First apply read.csv, then rbind
	# This will combine all files into one dataframe
	df = do.call(rbind, lapply(files, function(x) read.csv(x, stringsAsFactors = FALSE)))
}

# function returns a list of data-frames given a R file list as string
get_dataframe_list_from_files <- function(files) {
	#this will return the combined csv files as a list of dataframes
	df_list = lapply(files, function(x) read.csv(x, stringsAsFactors = FALSE))
}

#this function calculated mean for all values in the given column
#for a datframe, ignoring the NAs
calculate_mean <- function(dataframe, column){
	m <- mean(dataframe[,column], na.rm = TRUE)
}

#Function counts the number of complete cases for a dataframe
count_complete_cases <- function(dataframe){
	#logical vector of TRUE and FALSES to show which cases are complete
	l <- complete.cases(dataframe)
	#count complete (TRUE) cases (values)
	count <- length(l[l==TRUE])
}

#this function finds the number of complete observations (none of the columns is NA) in the dataframe and returns the
#result as a new dataframe of the form:
# 	 id nobs
# 1  2 1041
# 2  4  474
list_complete_cases <- function(dataframe_list){
	df <- data.frame(id = integer(0), nobs = integer(0))

	#how to add a new row?
	#df = rbind(df,data.frame(id = 8, nobs = 567))

	#get complete cases for each dataframes and add them as a row in new df
	for(i in seq_along(dataframe_list)){
		df = rbind(df,data.frame(id = i, nobs = count_complete_cases(dataframe_list[[i]])  ))
	}

	df
}

# http://www.inside-r.org/r-doc/stats/cor
# takes a complete threshold , and calculates covarience for
# all dataframes that pass this threshold
# returns the correlation as a vector
get_corelations <- function(dataframes,threshold=0) {
	cor_vector <- numeric(0)

	for(i in seq_along(dataframes)){
		df <- dataframes[[i]]
		if (count_complete_cases(df) > threshold){
			cor_vector <- c(   cor_vector, cor( df[,'sulfate'], df[,'nitrate'], use = "complete.obs" )   )
		}
	}

	cor_vector
}

####
#
#Finally lets use above functions and write functions needed in quiz to answer the question
#
#####

DATA_LOCATION <- "~/code/r/r-experiments/specdata"

#Part 1
pollutantmean <- function(pollutant,id=1:332) {
	file_list 	<- get_files(DATA_LOCATION,id)
	data_frame 	<- merged_data_frame(file_list)
	m <- calculate_mean(data_frame,pollutant)
}

#Part 1 test cases
#print(pollutantmean("sulfate", 1:10))
#print(pollutantmean("nitrate"))
#print(pollutantmean("sulfate", 34))
#print(pollutantmean("sulfate", 1:10))

#Part 2
complete <- function(id) {
	file_list 	<- get_files(DATA_LOCATION,id)
	data_frame_list <- get_dataframe_list_from_files(file_list)
	complete_cases <- list_complete_cases(data_frame_list)
}

#Part 2 test cases
#print(complete(1))
#print(complete(c(2, 4, 8, 10, 12)))
#print(complete(30:25))
#print(complete(3))
# cc <- complete(54)
# print(cc$nobs)

#Part 3
corr <- function(threshold=0) {
	file_list 	<- get_files(DATA_LOCATION)
	data_frame_list <- get_dataframe_list_from_files(file_list)
	cr_vector <- get_corelations(data_frame_list,threshold)
}

#Part 3 test cases

 #cr <- corr(150)
 #print(cr)
 #print(head(cr))
#print(summary(cr))

# cr <- corr(400)
# print(head(cr))
# print(summary(cr))

# cr <- corr(5000)
# print(summary(cr))
# print(length(cr))

# cr <- corr()
# print(summary(cr))
# print(length(cr))

# cr <- corr(129)
# cr <- sort(cr)
# n <- length(cr)
# set.seed(197)
# out <- c(n, round(cr[sample(n, 5)], 4))
# print(out)

cr <- corr(2000)
n <- length(cr)
cr <- corr(1000)
cr <- sort(cr)
print(c(n, round(cr, 4)))


# install.packages("plyr") # for aggregation
library(plyr)

# read in trip data for Sep 2019. A bit slow but only needs to be done once
temp = tempfile()
download.file("https://s3.amazonaws.com/hubway-data/201909-bluebikes-tripdata.zip", temp)
trip_zip = unz(temp, "201909-bluebikes-tripdata.csv")
trip_data = read.csv(trip_zip, header=TRUE)
unlink(temp)
summary(trip_data)

# extract just date from start times
trip_data$date = as.Date(trip_data$starttime)

# remove outlier trips. start with 3 std dev, adjust if appropriate
outlier_threshold = mean(trip_data$tripduration) + 3*sd(trip_data$tripduration)
trip_data = subset(trip_data, trip_data[, "tripduration"] < outlier_threshold)

# create empty data frame to fill after transformations.
# numrow is fixed based on number of stations*dates, need to adjust if using a different month
agg_trips = data.frame(matrix(0, ncol=4, nrow=9529))
colnames(agg_trips) = c('id', 'date', 'total.start', 'total.end')

# count number of trips in and out of a station by day
trips.start = count(trip_data, c('date', 'start.station.id'))
trips.end = count(trip_data, c('date', 'end.station.id'))

# rename columns
colnames(trips.start)[colnames(trips.start) == "start.station.id"] = "id"
colnames(trips.end)[colnames(trips.end) == "end.station.id"] = "id"

# merge in and out counts and replace NA values with 0 (since no trips)
jointdataset = merge(trips.start, trips.end, by = c('date','id'), all=TRUE)
jointdataset[is.na(jointdataset)] = 0

# fill aggregate dataset
agg_trips$id = jointdataset$id
agg_trips$date = jointdataset$date
agg_trips$total.start = jointdataset$freq.x
agg_trips$total.end = jointdataset$freq.y

# calculate flow for each station (end - start since we want to know the change)
agg_trips$flow = agg_trips$total.end - agg_trips$total.start

# add in day of the week for averages
agg_trips$weekday = weekdays(agg_trips$date)


require(rms)
set.seed(1)
n <- 100
y <- sample(1 : 10, n, TRUE)
x1 <- runif(n)
x2 <- runif(n)
f <- lrm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
set.seed(1)
fb <- bootcov(f, B=400, eps=.001)
k <- c('y>=6', 'x1', 'x2')
set.seed(1)
gb <- bootcov(g, B=400, eps=.001)
list(rownames(f$var), rownames(g$var), rownames(fb$var), rownames(gb$var))
attributes(gb$var)
fb$var[k, k]
gb$var[k, k]

vcov(fb)[k, k]
vcov(gb)
vcov(gb, intercepts='mid')

anova(fb)
anova(gb)
# Still need to understand how bootcov works differently for orm

r <- resid(f, 'score') - resid(g, 'score')
apply(r, 2, function(x) max(abs(x)))
fr <- robcov(f)
gr <- robcov(g)

g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001, family='loglog')
gr <- robcov(g)
gb <- bootcov(g, B=200)

# Compare against Yuqi Tian's function
source('robcov_Yuqi.r')
vh <- func_robcov(g, cluster=1:100)
vg <- vcov(gr, intercepts='all')

cv <- function(v1, v2) {
  se1 <- sqrt(diag(v1))
  se2 <- sqrt(diag(v2))
  prn(round(se1 / se2, 3))
  prn(max(abs(v1 - v2)))
}
cv(vg, vh)

cs <- function(fit) {
  sc1 <- resid(fit, 'score')
  sc2 <- func_score(fit)
  max(abs(sc1 - sc2))
}
g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
cs(g)

g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001, family='probit')
cs(g)

g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001, family='loglog')
cs(g)

g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=0.001, family='cauchit')
cs(g)


beta_calculator <- function(L, T, mu0, sigma0){
    # Calculates the sub-optimal beta for the poisson process.
    #
    # Args:
    #    L (scalar): The Lipschitz/Holder coefficient decribed in Assumption 3.1 of the reference paper
    #    T (scalar): The maturity of the asset
    #    mu0 (array-like): The starting value of mu for each dimension (not sure about this)
    #    sigma0 (array-like): The starting value of sigma for each dimension (not sure about this)
    # Returns:
    #     (scalar): The sub-optimal beta

    # Get the dimension of the process
    d <- length(mu0)

    mu_inf <- sqrt(sum(mu0^2))

    trace <- sum(diag(solve(sigma0 %*% t(sigma0))))

    L_prime <- L^2 * ( 2*(1+mu_inf*sqrt(T))^2 * trace + 2*(3*d+d*(d-1)) )

    return(sqrt(L_prime + 0.25*T^2) + 0.5*T)
}


# 4. faza: Analiza podatkov

# predikcija povprečnega razpoložljivega dohodka (moški)
spol_moski <- spol %>%
  filter(Spol == "Moški")

model <- lm(Dohodek ~ Leto , data = spol_moski)

prihodnost <- data.frame(Leto = seq(2020,2024), Spol = "Moški")

napoved <- prihodnost %>%
  mutate(Dohodek= predict(model, .)) %>%
  select(Spol, Leto, Dohodek)

napoved_spol_moski <- bind_rows( (spol_moski),napoved)

graf_napoved_spol_moski <- ggplot(napoved_spol_moski, aes(x=Leto, y=Dohodek)) +
  geom_point() +
  geom_point(data=napoved, color="red") +
  geom_smooth(method = "lm", formula = y ~ x, col="red") +
  scale_x_continuous(breaks = seq(2008, 2024, 2)) +
  ggtitle("Napoved dohodka - moški")

print(graf_napoved_spol_moski)


# Random Forest Regression for machine learning.
#
# Random forest algorithm is a supervised classification algorithm. As the name
# suggest, this algorithm creates the forest with a number of decision trees.
#
# In general, the more trees in the forest the more robust the forest looks like.
# In the same way in the random forest classifier, the higher the number of trees
# in the forest gives the high accuracy results.
# Importing the data set

dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Fit Random Forest Regression to the dataset
# install.packages("randomForest")
# library(randomForest)
set.seed(1234) # For debuging
regressor = randomForest(x = dataset[1], y = dataset$Salary,
                         ntree = 100)

# Predict a new result with Random Forest Regression model
y_pred = predict(regressor, newdata = data.frame(Level = 6.5))

# HIGH RESOLUTION: Visualize graphic result of the Random Forest Regression model
# install.packages('ggplot2')
# library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.01)
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour='red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level=x_grid))),
            colour='blue') +
  ggtitle('Truth or Bluff (Random Forest Regression)') +
  xlab('Level') + ylab('Salary')


Rcpp::sourceCpp('src/CppLoglikelihood.cpp')
Rcpp::sourceCpp('src/make_pilot.cpp')
library("ramify")

get_bandwidth <- function(alpha, beta, pilot) {
  return(alpha / pilot ^ beta)
}

roop_likelihoood_by_alpha <- function (beta, vec_alpha, pilot, dat) {
  dat <- sort(dat)
  discre_size = length(vec_alpha)
  n = length(dat)
  likelihood_by_alpha <- numeric(discre_size)
  for (i in 1:length(vec_alpha)) {
    bandwidth <-  get_bandwidth(vec_alpha[i], beta, pilot)
    likelihood_by_alpha[i] <-  CppLoglikelihood(dat, bandwidth, as.integer(n))
  }
  return (likelihood_by_alpha)
}

argmax_logalpha_in_likelihood <- function (range_log_alpha, pilot, dat, discre_size, beta) {

  vec_logalpha = seq(range_log_alpha[1], range_log_alpha[2], length = discre_size + 1)[1:discre_size]
  vec_alpha = 10^vec_logalpha
  likelihood_by_alpha <- roop_likelihoood_by_alpha (beta, vec_alpha, pilot, dat)

  argmax = ramify::argmax(t(as.matrix(likelihood_by_alpha)))
  begin = NA; end = NA; l_alpha = length(likelihood_by_alpha)
  if (argmax == 1) {
    begin = 1; end=1; warning("range of alpha is not enough")
  } else if (argmax == l_alpha) {
    begin = l_alpha; end = l_alpha; warning("range of alpha is not enough")
  } else {
    begin = argmax - 1
    end = argmax + 1
  }

  return (
    list (
      argmax = argmax,
      max_alpha = vec_logalpha[argmax],
      range_log_alpha = c(vec_logalpha[begin], vec_logalpha[end]),
      likelihood = likelihood_by_alpha[argmax]
      )
  )
}

get_adeba_bandwidth <- function (
  dat,
  range_log_alpha,
  vec_beta,
  discre_size1,
  discre_size2,
  alpha0,
  beta0
  ) {

  pilot0 <- numeric(length(dat)) + alpha0
  res1 <- argmax_logalpha_in_likelihood (range_log_alpha, pilot0, dat, discre_size1, beta0)

  res2 <- argmax_logalpha_in_likelihood (res1$range_log_alpha, pilot0, dat, discre_size2, beta0)
  argmax_alpha_result <- res2$argmax

  n <- length(dat)
  likelihood_by_beta <- numeric(length(vec_beta)) - Inf
  pilot1_prev <- numeric(n)
  alpha1 <- 10^res2$max_alpha

  for (i in 1:length(vec_beta)) {

    bandwidth <- get_bandwidth (alpha1, vec_beta[i], pilot0)
    pilot1 <- make_pilot(dat, bandwidth, as.integer(n))

    res1 <- argmax_logalpha_in_likelihood (range_log_alpha, pilot1, dat, discre_size1, vec_beta[i])
    res2 <- argmax_logalpha_in_likelihood (res1$range_log_alpha, pilot1, dat, discre_size2, vec_beta[i])

    likelihood <- res2$likelihood
    likelihood_by_beta[i] <- likelihood
    alpha1 <- 10^res2$max_alpha

    argmax_beta <- ramify::argmax(t(as.matrix(likelihood_by_beta)))
    max_likelihood <- likelihood_by_beta[argmax_beta]
    beta1 <- vec_beta[ramify::argmax(t(as.matrix(likelihood_by_beta)))]

    if (max_likelihood != likelihood) {
          pilot1 <- pilot1_prev
          alpha1 <- alpha1_prev
          break
    }

    pilot1_prev <- pilot1
    alpha1_prev <- alpha1
  }

  bandwidth_result <- get_bandwidth(alpha1, beta1, pilot1)
  return (bandwidth_result)
}

kernel_density <- function (dat, bandwith, kernelFn, x = NULL, out = .1) {
  n <- length(dat)
  delta <- max(dat) - min(dat)
  if (is.null(x)) {
    x <- seq(min(dat) - delta * out, max(dat) + delta * out, length = 400)
  }
  y <- numeric(length(x))
  for (i in 1:length(dat)) {
    if (bandwith[i] == Inf) next
    y <- y + 1 / n / bandwith[i] * kernelFn ((dat[i] - x) / bandwith[i])
  }
  return(list(x = x, y = y))
}

triweight <- function (u) {
  res <- numeric (length(u))
  LogiAbsU <- abs(u) <= 1
  res[LogiAbsU] <- 35 / 32 * (1 - u[LogiAbsU]^2)^3
  return (res)
}

adeba_denstiy <- function (
  dat,
  range_log_alpha = c(-6.0, 1.0),
  vec_beta = c(0.0, 0.5, 1.0, 1.5, 2.0),
  discre_size1 = 14,
  discre_size2 = 7,
  alpha0 = 1.0,
  beta0 = 0.01,
  x = NULL,
  out = .2
) {

  dat <- sort(dat)
  mind <- min(dat)
  maxd <- max(dat)
  dat = (dat - mind) / (maxd - mind)

  bandwith <- get_adeba_bandwidth(
    dat,
    range_log_alpha,
    vec_beta,
    discre_size1,
    discre_size2,
    alpha0,
    beta0
  )

  normalize_dens <- kernel_density (dat, bandwith, triweight, x = x, out = out)
  nx <- normalize_dens$x
  ny <- normalize_dens$y

  x <- nx * (maxd - mind) + mind
  delta <- x[3] - x[2]
  sumP <- sum(ny)
  y <- ny / (sumP * delta)

  return (list(x=x,y=y))
}

#plot(adeba_denstiy(dat))


# QQ t.test
# ЧАСТЬ 1: делаем data.frame
	# шаг-1. вчитываем таблицу. делаем из нее датафрейм.
MDepths <- read.csv("Depths.csv", header=TRUE, sep = ",")
	# шаг-2. чистим датафрейм от NA значений
MDF <- na.omit(MDepths)
row.has.na <- apply(MDF, 1, function(x){any(is.na(x))}) # проверяем, удалил ли все NA
sum(row.has.na) # суммируем все NA, должно получиться: [1] 0
head(MDF) # смотрим очищенный датафрейм. теперь с ним работаем.
# ЧАСТЬ 2: чертим график регрессионного анализа по отдельному профилю из датафрейма
	# шаг-3.
qqnorm(MDF$profile12)
qqline(MDF$profile12)


library(tidyverse) # metapackage of all tidyverse packages
library(keras)

list.files(path = "../input/fashionmnist")

train.data <- read_csv("../input/fashionmnist/fashion-mnist_train.csv",
                       col_types = cols(.default = "i"))
test.data <- read_csv("../input/fashionmnist/fashion-mnist_test.csv",
                      col_types = cols(.default = "i"))

names(train.data)

dim(train.data)
dim(test.data)

# Data is 28 pixels big in width and height
img_rows <- img_cols <- 28

#' Data is transformed to matrix (because they are easier indexable) and  pixels
#' are separated from labels.
x_train <- as.matrix(train.data[, 2:dim(train.data)[2]])
y_train <- as.matrix(train.data[, 1])
# Unflattening the data.
dim(x_train) <- c(nrow(x_train), img_rows, img_cols, 1)

# The same for test set.
x_test <- as.matrix(test.data[, 2:dim(train.data)[2]])
y_test <- as.matrix(test.data[, 1])
dim(x_test) <- c(nrow(x_test), img_rows, img_cols, 1)

clothes.labels <- c("T-shirt/top", "Trouser", "Pullover", "Dress", "Coat",
                    "Sandal", "Shirt", "Sneaker", "Bag", "Ankle boot")

# Function to rotate matrices
rotate <- function(x) t(apply(x, 2, rev))

# Function to plot image from a matrix x
plot_image <- function(x, title = "", title.color = "black") {
  dim(x) <- c(img_rows, img_cols)
  image(rotate(rotate(x)), axes = FALSE,
        col = grey(seq(0, 1, length = 256)),
        main = list(title, col = title.color))
}

# We plot 16 cherry-picked images from the training set
par(mfrow=c(4, 4), mar=c(0, 0.2, 1, 0.2))
for (i in 1:16) {
  nr <- i * 10
  plot_image(x_train[nr,,,1],
             clothes.labels[as.numeric(train.data[nr, 1] + 1)])
}

# Normalize values from [0, 255] to [0, 1] interval
x_train <- x_train / 255
x_test <- x_test / 255

# Convert class vectors to binary class matrices
num_classes <- 10
y_train <- to_categorical(y_train, num_classes)
y_test <- to_categorical(y_test, num_classes)

# model definition
model <- keras_model_sequential()

model %>%
  layer_flatten(input_shape = c(28, 28)) %>%
  layer_dense(units = 128, activation = 'relu') %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_dense(units = 10, activation = 'softmax')

model %>% compile(
  loss = loss_categorical_crossentropy, # if label is given as an integer, use loss_sparse_categorical_crossentropy
  optimizer = optimizer_adam(),
  metrics = c('accuracy')
)

model

history = model %>% fit(
  x_train, y_train,
  batch_size = 256,
  epochs = 20,
  validation_data = list(x_test, y_test)
)

plot(history)

history

input_shape <- c(img_rows, img_cols, 1)

model <- keras_model_sequential()
model %>%
  layer_conv_2d(filters = 32, kernel_size = c(3,3), activation = 'relu',
                input_shape = input_shape) %>%
  layer_dropout(rate = 0.5) %>%
  layer_conv_2d(filters = 32, kernel_size = c(3,3), activation = 'relu') %>%
  layer_flatten() %>%
  layer_dense(units = 128, activation = 'relu') %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = num_classes, activation = 'softmax')

# compile model
model %>% compile(
  loss = loss_categorical_crossentropy,
  optimizer = optimizer_adam(),
  metrics = c('accuracy')
)

model

# train and evaluate
history <- model %>% fit(
  x_train, y_train,
  batch_size = 256,
  epochs = 20,
  verbose = 1,
  validation_data = list(x_test, y_test)
)

plot(history)

history


#' Discretise numeric data into categorical
#'
#' `cut_interval()` makes `n` groups with equal range, `cut_number()`
#' makes `n` groups with (approximately) equal numbers of observations;
#' `cut_width()` makes groups of width `width`.
#'
#' @author Randall Prium contributed most of the implementation of
#'    `cut_width()`.
#' @param x numeric vector
#' @param n number of intervals to create, OR
#' @param length length of each interval
#' @inheritDotParams base::cut.default -x -include.lowest
#' @export
#' @examples
#' table(cut_interval(1:100, 10))
#' table(cut_interval(1:100, 11))
#'
#' table(cut_number(runif(1000), 10))
#'
#' table(cut_width(runif(1000), 0.1))
#' table(cut_width(runif(1000), 0.1, boundary = 0))
#' table(cut_width(runif(1000), 0.1, center = 0))
#' table(cut_width(runif(1000), 0.1, labels = FALSE))
cut_interval <- function(x, n = NULL, length = NULL, ...) {
  cut(x, breaks(x, "width", n, length), include.lowest = TRUE, ...)
}

#' @export
#' @rdname cut_interval
cut_number <- function(x, n = NULL, ...) {
  brk <- breaks(x, "n", n)
  if (anyDuplicated(brk))
    abort(glue("Insufficient data values to produce {n} bins."))
  cut(x, brk , include.lowest = TRUE, ...)
}

#' @export
#' @rdname cut_interval
#' @param width The bin width.
#' @param center,boundary Specify either the position of edge or the center of
#'   a bin. Since all bins are aligned, specifying the position of a single bin
#'   (which doesn't need to be in the range of the data) affects the location of
#'   all bins. If not specified, uses the "tile layers algorithm", and sets
#'   the boundary to half of the binwidth.
#'
#'   To center on integers, `width = 1` and `center = 0`.
#'   `boundary = 0.5`.
#' @param closed One of `"right"` or `"left"` indicating whether right
#'   or left edges of bins are included in the bin.
cut_width <- function(x, width, center = NULL, boundary = NULL, closed = c("right", "left"), ...) {
  x <- as.numeric(x)
  width <- as.numeric(width)

  closed <- match.arg(closed)

  x_range <- range(x, na.rm = TRUE, finite = TRUE)
  if (length(x_range) == 0) {
    return(x)
  }

  # Determine boundary
  if (!is.null(boundary) && !is.null(center)) {
    abort("Only one of 'boundary' and 'center' may be specified.")
  }
  if (is.null(boundary)) {
    if (is.null(center)) {
      # If neither edge nor center given, compute both using tile layer's
      # algorithm. This puts min and max of data in outer half of their bins.
      boundary <- width / 2
    } else {
      # If center given but not boundary, compute boundary.
      boundary <- center - width / 2
    }
  }
  boundary <- as.numeric(boundary)

  # Determine bins
  min_x <- find_origin(x_range, width, boundary)
  # Small correction factor so that we don't get an extra bin when, for
  # example, origin = 0, max(x) = 20, width = 10.
  max_x <- max(x, na.rm = TRUE) + (1 - 1e-08) * width

  breaks <- seq(min_x, max_x, width)
  cut(x, breaks, include.lowest = TRUE, right = (closed == "right"), ...)
}

# Find the left side of left-most bin
find_origin <- function(x_range, width, boundary) {
  shift <- floor((x_range[1] - boundary) / width)
  boundary + shift * width
}

breaks <- function(x, equal, nbins = NULL, binwidth = NULL) {
  equal <- match.arg(equal, c("numbers", "width"))
  if ((!is.null(nbins) && !is.null(binwidth)) || (is.null(nbins) && is.null(binwidth))) {
    abort("Specify exactly one of n and width")
  }

  rng <- range(x, na.rm = TRUE, finite = TRUE)
  if (equal == "width") {
    if (!is.null(binwidth)) {
      fullseq(rng, binwidth)
    } else {
      seq(rng[1], rng[2], length.out = nbins + 1)
    }
  } else {
    if (!is.null(binwidth)) {
      probs <- seq(0, 1, by = binwidth)
    } else {
      probs <- seq(0, 1, length.out = nbins + 1)
    }
    stats::quantile(x, probs, na.rm = TRUE)
  }

}


# open the necessary libraries
library(tidyverse)
library(brms)
library(ggplot2)

# read in the csv results and select the needed columns
d = read_csv2("XPLab_FinalProject/tree/master/data/main/GiveMeGestalt_filtered_results.csv") %>%
  filter(trial_name %in% c("rating_scale_object", "rating_scale_like")) %>%
  select(submission_id, trial_name, response, picture_nr, artist)

# cast data into appropriate type
d_wide = spread(d, key = trial_name, value = response) %>%
  mutate(likeability = factor(rating_scale_like, ordered = T),
         objects = factor(paste0("C", rating_scale_object), ordered = T),
         artist = factor(artist),
         picture_nr = factor(picture_nr),
         submission_id = factor(submission_id),
         objects_forward = objects)

# inspect data
ggplot(d_wide, aes(x = objects, y= likeability)) + geom_jitter() + geom_smooth(method = "lm")

# further visual display
a <- ggplot(data=d)+
  geom_bar(mapping= aes(x = trial_name, fill = response), position = "dodge")
a

b <- ggplot(data=d)+
  geom_bar(mapping= aes(x = trial_name, fill = response))+
  facet_wrap(~artist)
b

# *****Section 1: the first three models treat the object-ratings as ordinal using the new brms monotonic models*****

# hierarchical model with only fixed effects
model_1 = brm(data = d_wide,
                formula = likeability ~ mo(objects),
                family=cumulative("logit")
)
model_1
plot(marginal_effects(model_1), categorical = T)

# hierarchical model with by-item (pictures) and by-subject random intercepts
model_2 = brm(data = d_wide,
                formula = likeability ~ mo(objects) + (1 | picture_nr) + (1 | submission_id),
                family=cumulative("logit")
)
model_2
plot(marginal_effects(model_2), categorical = T)

# hierarchical model with by-subject random intercepts and fixed effect of artist
model_3 = brm(data = d_wide,
                formula = likeability ~ mo(objects) + artist + (1 | submission_id),
                family=cumulative("logit")
)
model_3
plot(marginal_effects(model_3), categorical = T)

# *****Section 2: the following three models treat the object-ratings as interval-scale/ metric*****

# hierarchical model with only fixed effects
model_4 = brm(data = d_wide,
              formula = likeability ~ as.double(objects),
              family=cumulative("logit")
)
model_4
plot(marginal_effects(model_4))

# hierarchical model with by-item (pictures) and by-subject random intercepts
model_5 = brm(data = d_wide,
              formula = likeability ~ as.double(objects) + (1 | picture_nr) + (1 | submission_id),
              family=cumulative("logit")
)
model_5
plot(marginal_effects(model_5))

# hierarchical model with by-subject random intercepts and fixed effect of artist
model_6 = brm(data = d_wide,
              formula = likeability ~ as.double(objects) + artist + (1 | submission_id),
              family=cumulative("logit")
)
model_6
plot(marginal_effects(model_6))

# model comparison with loo
loo(model_1, model_2, model_3, model_4, model_5, model_6)
loo


# working with time and dates in R

# Core functionality is based upon POSIX standards
?POSIXt

Class ‘"POSIXct"’  -- time since 1970 -- in seconds

Class ‘"POSIXlt"’  -- time stamp in human readable format

Example:

    z.ct <- Sys.time()             # the current date, as class "POSIXct"
    print(z.ct)
    unclass( z.ct )  # seconds since 1970-1-1 00:00:00

    z.lt = as.POSIXlt( z.ct, "AST" ) # the current time in Atlantic time zone
    z.lt = as.POSIXlt( z.ct, "GMT" ) # the current time in GMT
    print(z.lt)
    unclass( z.lt )  # human readable characters
    unclass( as.POSIXct( z.lt) ) # return to numeric format (seconds)

    # pretty print in human readable format
    format(z.lt)
    format(z.ct)

    months(z.ct)
    julian(z.lt)

# operating with POSIX .. a bit convoluted:
    date = as.POSIXct("01-01-2010", format = "%d-%m-%Y", tz = "UTC")
    as.POSIXlt(date)$month + 1
    as.numeric(format(date, "%m"))
    date = as.POSIXct(format(date,"%Y-2-%d"), tz = "UTC")
    as.POSIXct(format(as.POSIXct(date), tz = "UTC"), tz = "GMT")

# lubridate interoprates with POSIX as well as a number of other different formats and is fast
# install.packages( "lubridate")  # if you do not have it
  library(lubridate)

    date = dmy("01-01-2010")
    month(date)
    month(date) = 2
    with_tz(date, "GMT")

#Parsing .. reading in dates
    mdy("12-01-2010")
    ydm("2010-01-01")

    dmy(c("31.12.2010", "01.01.2011", "12-01-2010", "12:06.2070"  ))  # kind of smart

    z = now()
    year(z)
    minute(z)

    year(z) = 2121
    day(z) = day(z) + 3

    z = z + hours(3)

    z = ymd_hms("2012-01-01 12:00:00", tz="UTC")  # UTC is default
    a = ymd_hms("2013-05-05 12:00:00", tz="America/Halifax")

    b = z- a
    unclass(b)

    ? lubridate::decimal_date  # Converts a date to a decimal of its year.
    lubridate::decimal_date( z )

    So Julian day is simply:

    (decimal_date( z ) - year(z)) * 365.242189

    dayofyear = function(a) (decimal_date(a) - year(a)) * 365.242189

    dayofyear( z )

    or

    lubridate::yday(z)

    ? lubridate::parse_date_time  # low level control


#' Simple binning of numeric variable
#'
#' This functions bins numeric variable into bins with unique values.
#'
#' @param df data frame with at least one numeric column
#' @param vars numeric column(x) to be binned
#' @param by parameter for quantile based binning. Default value 0.1 will create 10 bins if possible, using quantile function
#' @param eout Exclude outliers. If TRUE (default) then outliers as defined in boxplot are excluded before binning
#' and included afterwards as separated bins.
#' @param verbose Prints additional details when TRUE. Useful mainly for debugging.
#' @export
#' @examples
#' iv.binning.simple(german_data,"credit_amount")
#' iv.binning.simple(german_data,"credit_amount",by=0.05)
#' iv.binning.simple(german_data,"credit_amount",eout=FALSE)
#' iv.binning.simple(german_data,"age",by=0.2)
#' german_data$cut_cra1 <- iv.binning.simple(german_data,"credit_amount",eout=TRUE)
#' german_data$cut_cra2 <- iv.binning.simple(german_data,"credit_amount",eout=FALSE)
#' iv.plot.woe(iv=iv.mult(german_data,"gb",vars=c("cut_cra1","cut_cra2")))

iv.binning.simple <- function (df,vars,by=0.1,eout=TRUE,verbose=FALSE) {

for (col in vars) {
  breaks <- numeric(0)

  if(eout) {
    x <- boxplot(df[,col][!df[[col]] %in% boxplot.stats(df[[col]])$out],plot=FALSE)
    non_outliers <- df[,col][df[[col]] <= x$stats[5] & df[[col]] >= x$stats[1]]
    if (!(min(df[[col]])==min(non_outliers))) {
      breaks <- c(breaks, min(df[[col]]))
    }
  }

  breaks <- c(breaks, quantile(if(eout) non_outliers else df[[col]], probs=seq(0,1, by=by)))

  if(eout) {
    if (!(max(df[[col]])==max(non_outliers))) {
      breaks <- c(breaks, max(df[[col]]))
    }
  }

  return (cut(df[[col]],breaks=breaks,include.lowest=TRUE))
}

}


euler <- function(f, y0, a, b, h)
{
  t <- a
  y <- y0

  while (t < b)
  {
    cat(sprintf("%6.3f %6.3f\n", t, y))
    t <- t + h
    y <- y + h*f(t, y)
  }
}

newtoncooling <- function(time, temp)
  return(-0.07*(temp-20))

euler(newtoncooling, 100, 0, 100, 10)


#Rscript

#####################################################################################################################
#####################################################################################################################
################################# Compute a Generalized Linear Model from your data #################################
#####################################################################################################################
#####################################################################################################################

###################### Packages
suppressMessages(library(multcomp))
suppressMessages(library(DHARMa))
suppressMessages(library(glmmTMB)) ###Version: 0.2.3
suppressMessages(library(gap))

###################### Load arguments and declaring variables

args <- commandArgs(trailingOnly = TRUE)

if (length(args) < 10) {
    stop("At least 4 arguments must be supplied : \n- two input dataset files (.tabular) : metrics table and unitobs table \n- Interest variable field from metrics table \n- Response variable from unitobs table.", call. = FALSE) # if no args -> error and exit1

} else {
    import_data <- args[1] ###### file name : metrics table
    import_unitobs <- args[2] ###### file name : unitobs informations
    colmetric <- as.numeric(args[3]) ###### Selected interest metric for GLM
    list_fact <- strsplit(args [4], ",")[[1]] ###### Selected response factors for GLM
    list_rand <- strsplit(args [5], ",")[[1]] ###### Selected randomized response factors for GLM
    col_fact_ana <- args[6] ####### (optional) Selected splitting factors for GLMs
    distrib <- args[7] ###### (optional) Selected distribution for GLM
    glm_out <- args[8] ###### (Optional) GLM object as Rdata output ?
    aggreg <- args[9] ###### Aggregation level of the data table
    source(args[10]) ###### Import functions

}

#### d_ata must be a dataframe with at least 3 variables : unitobs representing location and year ("observation.unit"), species code ("species.code") and abundance ("number")

#Import des données / Import data
obs <- read.table(import_data, sep = "\t", dec = ".", header = TRUE, encoding = "UTF-8") #
obs[obs == -999] <- NA
metric <- colnames(obs)[colmetric]
tab_unitobs <- read.table(import_unitobs, sep = "\t", dec = ".", header = TRUE, encoding = "UTF-8")
tab_unitobs[tab_unitobs == -999] <- NA

if (col_fact_ana != "None") {
    fact_ana <- colnames(tab_unitobs)[as.numeric(col_fact_ana)]
    if (class(tab_unitobs[fact_ana]) == "numeric" || fact_ana == "observation.unit") {
        stop("Wrong chosen separation factor : Analysis can't be separated by observation unit or numeric factor")
    }
}else{
    fact_ana <- col_fact_ana
}

vars_data1 <- NULL
err_msg_data1 <- "The input metrics dataset doesn't have the right format. It needs to have at least the following 2 variables :\n- observation.unit (or year and site)\n- numeric or integer metric\n"
check_file(obs, err_msg_data1, vars_data1, 2)

vars_data2 <- c("observation.unit", list_fact, list_rand)
err_msg_data2 <- "The input unitobs dataset doesn't have the right format. It needs to have at least the following 2 variables :\n- observation.unit (or year and site)\n- factors used in GLM (habitat, year and/or site)\n"
check_file(tab_unitobs, err_msg_data2, vars_data2[vars_data2 != "None"], 2)

if (all(c(list_fact, list_rand) == "None")) {
    stop("GLM needs to have at least one response variable.")
}

if (list_fact[1] == "None" || all(is.element(list_fact, list_rand))) {
     stop("GLM can't have only random effects.")
}

####################################################################################################
######### Computing Generalized Linear Model ## Function : glm_community ############
####################################################################################################

glm_community <- function(metrique, list_fact, list_rand, fact_ana, distrib, tab_metrics, tab_metrique, tab_unitobs, unitobs = "observation.unit", nb_name = "number") {
    ## Purpose: Monitoring steps for GLM on community data
    ## ----------------------------------------------------------------------
    ## Arguments: metrique : selected metric
    ##            list_fact : Factors for GLM
    ##            list_rand : Random factors for GLM
    ##            fact_ana : Separation factor for GLMs
    ##            distrib : selected distribution for model
    ##            tab_metrics : data table metrics
    ##            tab_metrique : data table's name
    ##            tab_unitobs : data table unitobs
    ## ----------------------------------------------------------------------
    ## Author: Yves Reecht, Date: 18 août 2010, 15:59 modified by Coline ROYAUX 04 june 2020

    tmpd_ata <- tab_metrics

    out_fact <- .GlobalEnv$organise_fact(list_rand = list_rand, list_fact = list_fact)
    resp_fact <- out_fact[[1]]
    list_f <- out_fact[[2]]
    list_fact <- out_fact[[3]]

    ##Creating model's expression :
    expr_lm <- eval(parse(text = paste(metrique, "~", resp_fact)))

    ##Creating analysis table :

    list_fact_tab <- c(list_fact, fact_ana)
    list_fact_tab <- list_fact_tab[list_fact_tab != "None"]

    if (all(is.na(match(tmpd_ata[, unitobs], tab_unitobs[, unitobs])))) {
        stop("Observation units doesn't match in the two input tables")
    }

    if (! is.element("species.code", colnames(tmpd_ata))) {
        col <- c(unitobs, metrique)
        tmpd_ata <- cbind(tmpd_ata[, col], tab_unitobs[match(tmpd_ata[, unitobs], tab_unitobs[, unitobs]), list_fact_tab])
        colnames(tmpd_ata) <- c(col, list_fact_tab)

        for (i in list_fact_tab) {
            switch(i,
                  tmpd_ata[, i] <- as.factor(tmpd_ata[, i]))
         }
    }else{
        stop("Warning : wrong data frame, data frame should be aggregated by observation unit (year and site)")
    }

    ## Suppress unsed 'levels' :
    tmpd_ata <- .GlobalEnv$drop_levels_f(tmpd_ata)

    ## Automatic choice of distribution if none is selected by user :

    chose_distrib <- .GlobalEnv$distrib_choice(distrib = distrib, metrique = metrique, data = tmpd_ata)

    if (fact_ana != "None" && nlevels(tmpd_ata[, fact_ana]) > 1) {
        ana_cut <- levels(tmpd_ata[, fact_ana])
    }else{
        ana_cut <- NULL
    }

    ##Create results table :
    lev <- unlist(lapply(list_f, FUN = function(x) {
                                                        levels(tmpd_ata[, x])
                                                   }))
    row <- c("global", ana_cut)

    if (is.element("year", list_f) && ! is.element("year", list_rand)) {
        tab_sum <- .GlobalEnv$create_res_table(list_rand = list_rand, list_fact = list_fact, row = row, lev = unlist(c("year", lev)), distrib = chose_distrib)
    }else{
        tab_sum <- .GlobalEnv$create_res_table(list_rand = list_rand, list_fact = list_fact, row = row, lev = lev, distrib = chose_distrib)
    }
    ### creating rate table
    tab_rate <- data.frame(analysis = row, complete_plan = NA, balanced_plan = NA, NA_proportion_OK = NA, no_residual_dispersion = NA, uniform_residuals = NA, outliers_proportion_OK = NA, no_zero_inflation = NA, observation_factor_ratio_OK = NA, enough_levels_random_effect = NA, rate = NA)

    ##plural analysis
    for (cut in ana_cut) {
        cutd_ata <- tmpd_ata[grep(cut, tmpd_ata[, fact_ana]), ]
        cutd_ata <- .GlobalEnv$drop_levels_f(cutd_ata)

        res <- ""
        resy <- ""

        if (list_rand[1] != "None") {
            res <- tryCatch(glmmTMB::glmmTMB(expr_lm, family = chose_distrib, data = cutd_ata), error = function(e) {
                                                                                })
            if (is.element("year", list_f) && ! is.element("year", list_rand)) { #Model with year as continuous
                cutd_ata$year <- as.numeric(cutd_ata$year)
                resy <- tryCatch(glmmTMB::glmmTMB(expr_lm, family = chose_distrib, data = cutd_ata), error = function(e) {
                                                                                })
                cutd_ata$year <- as.factor(cutd_ata$year)
            }else{
                resy <- ""
            }

        }else{
            res <- tryCatch(glm(expr_lm, data = cutd_ata, family = chose_distrib), error = function(e) {
                                                                                })
            if (is.element("year", list_f)) { #Model with year as continuous
                cutd_ata$year <- as.numeric(cutd_ata$year)
                resy <- tryCatch(glm(expr_lm, family = chose_distrib, data = cutd_ata), error = function(e) {
                                                                                })
                cutd_ata$year <- as.factor(cutd_ata$year)
            }else{
                resy <- ""
            }

        }

          ## Write results :
         if (! is.null(res)) {
            file_save_glm_cut <- paste("GLM_", cut, ".Rdata", sep = "")
            save(res, file = file_save_glm_cut)

            tab_sum <- sorties_lm_f(obj_lm = res, obj_lmy = resy, tab_sum = tab_sum, metrique = metrique,
                                  fact_ana = fact_ana, cut = cut, col_ana = "analysis", lev = lev, #modSel = iFactGraphSel, list_fact_sel = list_fact_sel,
                                  list_fact = list_fact, list_rand = list_rand,
                                  d_ata = cutd_ata)

            tab_rate[tab_rate[, "analysis"] == cut, c(2:11)] <- .GlobalEnv$note_glm_f(data = cutd_ata, obj_lm = res, metric = metrique, list_fact = list_fact, details = TRUE)

        }else{
            cat("\nCannot compute GLM for level", cut, "Check if one or more factor(s) have only one level, or try with another distribution for the model in advanced settings \n\n")
        }

    }

    ## Global analysis :

    res_g <- ""
    res_gy <- ""

    if (list_rand[1] != "None") {
        res_g <- glmmTMB::glmmTMB(expr_lm, family = chose_distrib, data = tmpd_ata)
        if (is.element("year", list_fact) && ! is.element("year", list_rand)) { #Model with year as continuous
            yr <- tmpd_ata$year
            tmpd_ata$year <- as.numeric(tmpd_ata$year)
            res_gy <- glmmTMB::glmmTMB(expr_lm, family = chose_distrib, data = tmpd_ata)
            tmpd_ata$year <- as.factor(tmpd_ata$year)
            tmpd_ata$year <- yr
        }else{
            res_gy <- ""
        }

    }else{
        res_g <- glm(expr_lm, data = tmpd_ata, family = chose_distrib)
        if (is.element("year", list_fact)) { #Model with year as continuous
            yr <- tmpd_ata$year
            tmpd_ata$year <- as.numeric(tmpd_ata$year)
            res_gy <- glm(expr_lm, family = chose_distrib, data = tmpd_ata)
            tmpd_ata$year <- yr
        }else{
            res_gy <- ""
        }
    }

    ## write results :

    save(res_g, file = "global_GLM.Rdata")

    tab_sum <- sorties_lm_f(obj_lm = res_g, obj_lmy = res_gy, tab_sum = tab_sum, metrique = metrique,
                          fact_ana = fact_ana, cut = "global", col_ana = "analysis", lev = lev, #modSel = iFactGraphSel, list_fact_sel = list_fact_sel,
                          list_fact = list_fact, list_rand = list_rand,
                          d_ata = tmpd_ata)

    tab_rate[tab_rate[, "analysis"] == "global", c(2:11)] <- .GlobalEnv$note_glm_f(data = tmpd_ata, obj_lm = res_g, metric = metrique, list_fact = list_fact, details = TRUE)
    .GlobalEnv$note_glms_f(tab_rate = tab_rate, expr_lm = expr_lm, obj_lm = res_g, file_out = TRUE)

    ## simple statistics and infos :
    filename <- "GLMSummaryFull.txt"
    info_stats_f(filename = filename, d_ata = tmpd_ata, agreg_level = aggreg, type = "stat",
                metrique = metrique, fact_graph = fact_ana, #fact_graph_sel = modSel,
                list_fact = list_fact)#, list_fact_sel = list_fact_sel)

    tab_sum$separation <- fact_ana

    return(tab_sum)

}

################# Analysis

tab <- glm_community(metrique = metric, list_fact = list_fact, list_rand = list_rand, fact_ana = fact_ana, distrib = distrib, tab_metrics = obs, tab_metrique = aggreg, tab_unitobs = tab_unitobs, nb_name = "number")

write.table(tab, "GLMSummary.tabular", row.names = FALSE, quote = FALSE, sep = "\t", dec = ".", fileEncoding = "UTF-8")


#---------------------------------------------------#
# LA variation - 2010/11 model_adjusted funnel plot #
#---------------------------------------------------#

# packages ----
library(dplyr)
library(tidyr)
library(readr)
library(lme4)
library(broom)
library(gridExtra)
library(grid)
library(gtable)
library(ggpubr)
library(ggplot2)
library(ggrepel)

#----------------------#
# begin function ----
#----------------------#
abs_rate_funnel <- function(data, var, pop, pern = 1000, wlbls = FALSE){

  eval(data)

  # derive standard error ----
  dt <- data %>%
    rename(var_unquo = var,
           pop_unquo = pop) %>%
    mutate(rate = var_unquo/pop_unquo ,
           rate_pern = rate*pern,
           rate_se = sqrt(rate*(1-rate)/pop_unquo),
           pop_round = round(pop_unquo, -1))

  # derive common (fixed) effect ----
  rate_fem <- weighted.mean(dt$rate, 1/dt$rate_se^2, na.rm = TRUE)

  if(is.nan(rate_fem)){
    rate_fem <- mean(dt$rate, na.rm = TRUE)
    warning("weighted means could not be calculated. Arithmetic mean used instead.")
  }

  ## lower and upper limits for 95% and 99.9% CI, based on FEM estimator ----
  p_fem <- rate_fem*(1-rate_fem)

	number.seq <- seq(10, max(dt$pop_unquo), 10)

	number.ll95 <- (rate_fem - 1.96 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.ul95 <- (rate_fem + 1.96 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.ll999 <- (rate_fem - 3.29 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.ul999 <- (rate_fem + 3.29 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.se <- ((sqrt((p_fem * (1 - p_fem)) / number.seq)) * pern)
	dfCI <- data.frame(number.ll95, number.ul95, number.ll999, number.ul999, number.seq, number.se, rate_fem)

  # create labels for 'outliers' ----
  labels <- left_join(dt, dfCI, by = c("pop_round" = "number.seq")) %>%
    mutate(label_name = ifelse(rate_fem*pern > number.ul999 + 2*number.se | rate_fem*pern < number.ll999 - 2*number.se, la_name, NA),
           label_rate = ifelse(!is.na(label_name), round(rate_fem*pern,1), NA),
           label_comb = ifelse(!is.na(label_name) & !is.na(label_rate), paste(label_name, label_rate, sep = ": "), NA)) %>%
    select(la_code, starts_with("label_"))

  count <- left_join(dt, dfCI, by = c("pop_round" = "number.seq")) %>%
    mutate(high_low = ifelse(rate*pern > number.ul999 | rate*pern < number.ll999, 1, 0)) %>%
    summarise(extreme = sum(high_low ==1, na.rm = TRUE))

	final_dt <- left_join(dt, labels, by = c("la_code"))

if(wlbls == TRUE) {
	# draw funnel plot ----
	p <- ggplot(data = final_dt, aes(x = pop_unquo, y = rate_pern)) +
	  geom_point(alpha = 0.85, size = 2, shape = 21) +
	  geom_line(aes(x = number.seq, y = number.ll95, linetype = "dashed"), data = dfCI) +
	  geom_line(aes(x = number.seq, y = number.ul95), data = dfCI, linetype = "dashed") +
	  geom_line(aes(x = number.seq, y = number.ll999, linetype = "longdash"),  data = dfCI) +
	  geom_line(aes(x = number.seq, y = number.ul999), linetype = "longdash", data = dfCI) +
	  geom_hline(aes(yintercept = rate_fem*pern), data = dfCI) +
	  geom_text_repel(aes(label = label_name),size = 3.2, nudge_x = 11000, nudge_y = -0.05) +
	  scale_linetype_manual("",values = c("dashed", "longdash"), labels = c("95% control limit", "99.9% control limit")) +
	  theme(axis.line = element_line(colour = "black"),
	        panel.grid.major = element_blank(),
	        panel.grid.minor = element_blank(),
	        panel.border = element_blank(),
	        panel.background = element_blank(),
	        axis.text = element_text(colour = "black")) #+
	return(list(p, count, labels))
} else{
  # draw funnel plot ----
  p <- ggplot(data = final_dt, aes(x = pop_unquo, y = rate_pern)) +
    geom_point(alpha = 0.85, size = 2, shape = 21) +
    geom_line(aes(x = number.seq, y = number.ll95, linetype = "dashed"), data = dfCI) +
    geom_line(aes(x = number.seq, y = number.ul95), data = dfCI, linetype = "dashed") +
    geom_line(aes(x = number.seq, y = number.ll999, linetype = "longdash"),  data = dfCI) +
	  geom_line(aes(x = number.seq, y = number.ul999), linetype = "longdash", data = dfCI) +
	  geom_hline(aes(yintercept = rate_fem*pern), data = dfCI) +
	  scale_linetype_manual("",values = c("dashed", "longdash"), labels = c("95% control limit", "99.9% control limit")) +
    theme(axis.line = element_line(colour = "black"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_blank(),
          panel.background = element_blank(),
          axis.text = element_text(colour = "black")) #+
  return(list(p, count))
}

}

#----------------------#
# get analysis data ----
#----------------------#
source("N:/Documents/Data & Programming/R Scripts/la variation/la_variation_analysis_data.r", echo = FALSE)

#----------------------#
# get final model ----
#----------------------#

# linear mixed-effect model:
lmer_final <- lmer(data = filter(model_dat, any_bad_linkrate == 0 & any_bad_bwrate ==0),
                         formula = as.formula(paste("n_child_10000 ~ year_std",
                                                    "any_ara_pct",
                                                    "teenbirth_2010",
                                                    "imd_10pc_2010",
                                                    "lowbw_2010",
                                                    "ca_feud_2010",
                                                    "total_2010",
                                                    "lone_parent_pct",
                                                    "violent_crime",
                                                    #"prop10_idaci_pct",
                                                    "(year_std|la_code)",
                                                    sep = "+")), REML = TRUE)
lmer_final_predict <- predict(lmer_final, re.form = NA)

#-----------------------#
# funnel plots lmer ----
#-----------------------#
final_dat <- bind_cols(filter(model_dat, any_bad_linkrate == 0 & any_bad_bwrate ==0) ,
                       "predict" = lmer_final_predict) %>%
  filter(year == 2010) %>%
  mutate(adjusted_rate = (n_child_10000/predict)*mean(n_child_10000), # crude rate or mean of the rates? SMR
         adj_count = round((adjusted_rate*pop_U1)/10000),
         mean_rate = mean(n_child_10000)) %>%
  rowwise() %>%
  mutate(y_min = min(n_child_10000, adjusted_rate),
         y_max = max(n_child_10000, adjusted_rate),
         extreme = ifelse(abs(n_child_10000 - mean_rate) - abs(adjusted_rate - mean_rate) < 0, 1, 0)) %>%
  dplyr::select(la_code, la_name, region_name, n_child_10000, predict,
                adjusted_rate, mean_rate, n_child, adj_count, y_min, y_max, pop_U1, extreme)

# Funnel plot based only on observed rates:
plot_act <- abs_rate_funnel(data = final_dat, var = "n_child",
                            pop = "pop_U1", pern = 10000)[[1]] +
  scale_y_continuous("Number of infants (per 10000)",
                     limits = c(-5,250)) +
  scale_x_continuous("Local population size (Infants)") +
  labs(title = "Actual")

# Funnel plot with both observed and expected (as per lmer final) rates :
final <- plot_act  +
  geom_linerange(data = final_dat, aes(x = pop_U1, ymin = y_min, ymax = y_max), size = 1, alpha = 0.2, inherit.aes = FALSE, colour = "grey") +
  geom_point(data= final_dat, aes(x = pop_U1, y = n_child_10000, colour = "actual rate", fill = "actual rate", shape = "actual rate"), size = 2) +
  geom_point(data= final_dat, aes(x = pop_U1, y = adjusted_rate, colour = "adjusted rate", shape = "adjusted rate", fill = "adjusted rate"), size = 2) +
  scale_colour_manual("", values = c("grey70", "#1B9E77")) +
  scale_shape_manual("", values = c(19,15)) +
  scale_fill_manual("", values = c("grey70", "#1B9E77")) +
  scale_y_continuous("Number of infants CLA (per 10,000)",
                     limits = c(-5,250)) +
  scale_x_continuous("Local population size (Infants)") +
  theme(axis.text = element_text(size = 14),
        legend.position = "bottom",
        axis.title = element_text(size = 14),
        strip.text = element_text(size = 14),
        legend.title=element_text(size=14),
        legend.text=element_text(size=14),
        title = element_text(size = 16)) +
  labs(subtitle = "model prediction of rates uses fixed-effects only - final model")

ggsave(final, "N:/Documents/Data & Programming/outputs/la variation/modelling/adjusted_lmer_funnel_plot_feonly.png")

#--------------------------------------------------------------------------------#
# add lines between observed and expected and use shapes to depict region of LA ----
#--------------------------------------------------------------------------------#
  final_shapes <- plot_act  +
    geom_linerange(data = final_dat_wlbls, aes(x = pop_U1, ymin = y_min, ymax = y_max), size = 1, alpha = 0.2, inherit.aes = FALSE, colour = "grey") +
    geom_point(data= final_dat_wlbls, aes(x = pop_U1, y = n_child_10000, colour = "actual rate", fill = "actual rate", shape = "actual rate"), size = 2) +
    geom_point(data= final_dat_wlbls, aes(colour = region_name, shape = region_name, fill = region_name,
                                    x = pop_U1, y = adjusted_rate), size = 3.2) +
    #geom_label_repel(data= final_dat_wlbls, aes(x = pop_U1, y = n_child_10000,label = lbl),size = 3.2, nudge_x = 3000, nudge_y = -0.05) +
    scale_colour_manual("Region", values = c("grey80", "#1F78B4",  "#D95F02", "#1B9E77", "#7570B3",  "#66A61E", "#E7298A", "#E6AB02", "#FB9A99", "#666666")) +
    scale_shape_manual("Region", values=c(19,2,0,8,15,21,17,4,23,7)) +
    scale_fill_manual("Region", values = c("grey80", "#1F78B4",  "#D95F02", "#1B9E77", "#7570B3",  "#66A61E", "#E7298A", "#E6AB02", "#FB9A99", "#666666")) +
    scale_y_continuous("Number of infants CLA (per 10,000)",
                       limits = c(-5,250)) +
    scale_x_continuous("Local population size (Infants)") +
    theme(#legend.position = "bottom",
          axis.text = element_text(size = 14),
          axis.title = element_text(size = 14),
          strip.text = element_text(size = 14),
          legend.title=element_text(size=14),
          legend.text=element_text(size=14),
          title = element_text(size = 16)) +
    labs(title = "Local authority variation in Infants CLA - actual vs case-mix adjusted (2010/11 only)",
         subtitle = "linear mixed-effect model prediction of rates uses fixed-effects only"
      #title ="",
      #subtitle = "model prediction of rates uses fixed-effects only - final model"
      )

ggsave(final_shapes,"N:/Documents/Data & Programming/outputs/la variation/modelling/adjusted_lmer_funnel_plot_feonly_shapes.png",
       units = "mm", width = 350,height = 250)


# Internal fucntion of add_pcoord performing pricipal coordinate analysis
# D A list with objects H, P, and HP, returned by prepare_paco_data
#  correction The correction to apply (none, lingoes, or cailliez)
#  rn rownames (optional)
# Internal function coordpcoa is a modified version of ape::pcoa, utilising vegan::eigenvals and zapsmall
coordpcoa <- function (D, correction = "none", rn = NULL)
{
    centre <- function(D, n) {
        One <- matrix(1, n, n)
        mat <- diag(n) - One/n
        mat.cen <- mat %*% D %*% mat
    }
    bstick.def <- function(n, tot.var = 1, ...) {
        res <- rev(cumsum(tot.var/n:1)/n)
        names(res) <- paste("Stick", seq(len = n), sep = "")
        return(res)
    }
    D <- as.matrix(D)
    n <- nrow(D)
    epsilon <- sqrt(.Machine$double.eps)
    if (length(rn) != 0) {
        names <- rn
    }else {
        names <- rownames(D)
    }
    CORRECTIONS <- c("none", "lingoes", "cailliez")
    correct <- pmatch(correction, CORRECTIONS)
    if (is.na(correct))
        stop("Invalid correction method")
    delta1 <- centre((-0.5 * D^2), n)
    trace <- sum(diag(delta1))
    D.eig <- eigen(delta1)
    D.eig$values <- as.numeric(zapsmall(vegan::eigenvals(D.eig)))
    min.eig <- min(D.eig$values)
    zero.eig <- which(abs(D.eig$values) < epsilon)
    D.eig$values[zero.eig] <- 0
    if (min.eig > -epsilon) {
        correct <- 1
        eig <- D.eig$values
        k <- length(which(eig > epsilon))
        rel.eig <- eig[1:k]/trace
        cum.eig <- cumsum(rel.eig)
        vectors <- sweep(D.eig$vectors[, 1:k], 2, sqrt(eig[1:k]),
            FUN = "*")
        bs <- bstick.def(k)
        cum.bs <- cumsum(bs)
        res <- data.frame(eig[1:k], rel.eig, bs, cum.eig, cum.bs)
        colnames(res) <- c("Eigenvalues", "Relative_eig", "Broken_stick",
            "Cumul_eig", "Cumul_br_stick")
        rownames(res) <- 1:nrow(res)
        rownames(vectors) <- names
        colnames(vectors) <- colnames(vectors, do.NULL = FALSE,
            prefix = "Axis.")
        note <- paste("There were no negative eigenvalues. No correction was applied")
        out <- (list(correction = c(correction, correct), note = note,
            values = res, vectors = vectors, trace = trace))
    }
    else {
        k <- n
        eig <- D.eig$values
        rel.eig <- eig/trace
        rel.eig.cor <- (eig - min.eig)/(trace - (n - 1) * min.eig)
        rel.eig.cor = c(rel.eig.cor[1:(zero.eig[1] - 1)], rel.eig.cor[(zero.eig[1] +
            1):n], 0)
        cum.eig.cor <- cumsum(rel.eig.cor)
        k2 <- length(which(eig > epsilon))
        k3 <- length(which(rel.eig.cor > epsilon))
        vectors <- sweep(D.eig$vectors[, 1:k2], 2, sqrt(eig[1:k2]),
            FUN = "*")
        if ((correct == 2) | (correct == 3)) {
            if (correct == 2) {
                c1 <- -min.eig
                note <- paste("Lingoes correction applied to negative eigenvalues: D' = -0.5*D^2 -",
                  c1, ", except diagonal elements")
                D <- -0.5 * (D^2 + 2 * c1)
            }
            else if (correct == 3) {
                delta2 <- centre((-0.5 * D), n)
                upper <- cbind(matrix(0, n, n), 2 * delta1)
                lower <- cbind(-diag(n), -4 * delta2)
                sp.matrix <- rbind(upper, lower)
                c2 <- max(Re(eigen(sp.matrix, symmetric = FALSE,
                  only.values = TRUE)$values))
                note <- paste("Cailliez correction applied to negative eigenvalues: D' = -0.5*(D +",
                  c2, ")^2, except diagonal elements")
                D <- -0.5 * (D + c2)^2
            }
            diag(D) <- 0
            mat.cor <- centre(D, n)
            toto.cor <- eigen(mat.cor)
            toto.cor$values <- as.numeric(zapsmall(vegan::eigenvals(toto.cor)))
            trace.cor <- sum(diag(mat.cor))
            min.eig.cor <- min(toto.cor$values)
            zero.eig.cor <- which((toto.cor$values < epsilon) &
                (toto.cor$values > -epsilon))
            toto.cor$values[zero.eig.cor] <- 0
            if (min.eig.cor > -epsilon) {
                eig.cor <- toto.cor$values
                rel.eig.cor <- eig.cor[1:k]/trace.cor
                cum.eig.cor <- cumsum(rel.eig.cor)
                k2 <- length(which(eig.cor > epsilon))
                vectors.cor <- sweep(toto.cor$vectors[, 1:k2],
                  2, sqrt(eig.cor[1:k2]), FUN = "*")
                rownames(vectors.cor) <- names
                colnames(vectors.cor) <- colnames(vectors.cor,
                  do.NULL = FALSE, prefix = "Axis.")
                bs <- bstick.def(k2)
                bs <- c(bs, rep(0, (k - k2)))
                cum.bs <- cumsum(bs)
            }
            else {
                if (correct == 2)
                  cat("Problem! Negative eigenvalues are still present after Lingoes",
                    "\n")
                if (correct == 3)
                  cat("Problem! Negative eigenvalues are still present after Cailliez",
                    "\n")
                rel.eig.cor <- cum.eig.cor <- bs <- cum.bs <- rep(NA,
                  n)
                vectors.cor <- matrix(NA, n, 2)
                rownames(vectors.cor) <- names
                colnames(vectors.cor) <- colnames(vectors.cor,
                  do.NULL = FALSE, prefix = "Axis.")
            }
            res <- data.frame(eig[1:k], eig.cor[1:k], rel.eig.cor,
                bs, cum.eig.cor, cum.bs)
            colnames(res) <- c("Eigenvalues", "Corr_eig", "Rel_corr_eig",
                "Broken_stick", "Cum_corr_eig", "Cum_br_stick")
            rownames(res) <- 1:nrow(res)
            rownames(vectors) <- names
            colnames(vectors) <- colnames(vectors, do.NULL = FALSE,
                prefix = "Axis.")
            out <- (list(correction = c(correction, correct),
                note = note, values = res, vectors = vectors,
                trace = trace, vectors.cor = vectors.cor, trace.cor = trace.cor))
        }
        else {
            note <- "No correction was applied to the negative eigenvalues"
            bs <- bstick.def(k3)
            bs <- c(bs, rep(0, (k - k3)))
            cum.bs <- cumsum(bs)
            res <- data.frame(eig[1:k], rel.eig, rel.eig.cor,
                bs, cum.eig.cor, cum.bs)
            colnames(res) <- c("Eigenvalues", "Relative_eig",
                "Rel_corr_eig", "Broken_stick", "Cum_corr_eig",
                "Cumul_br_stick")
            rownames(res) <- 1:nrow(res)
            rownames(vectors) <- names
            colnames(vectors) <- colnames(vectors, do.NULL = FALSE,
                prefix = "Axis.")
            out <- (list(correction = c(correction, correct),
                note = note, values = res, vectors = vectors,
                trace = trace))
        }
    }
    class(out) <- "pcoa"
    out
}


# Random Forest Regression

# Libraries
library(ggplot2)
library(rpart)
library(randomForest)
set.seed(1234)

# Importing dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

regressor = randomForest(x = dataset[1],
                         y = dataset$Salary,
                         ntree = 500)

y_pred = predict(regressor, data.frame(Level = 6.5))

X_grid = seq(min(dataset$Level), max(dataset$Level), 0.01)
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour = 'red') +
  geom_line(aes(x = X_grid, y = predict(regressor, newdata = data.frame(Level = X_grid))),
            colour = 'blue') +
  ggtitle('Truth or Bluff (Random Forest Regression)') +
  xlab('Level') +
  ylab('Salary')


sum = function(n)
{

 if (n ==0 )
  {

   return(n)

   }else{

     return(n+sum(n-1))
 }
}

x=sum(10)
print(x)


# Sampling functions
#
library(MASS)
library(mvtnorm)
source('ars_alpha.r')
source('ars_beta.r')

DEBUG <- FALSE
sample_z <- function(u, A, alpha, z, mu_ar, S_ar, mu_a0, R_a0, beta_a0, W_a0){
    #
    # Chinese Restaurant Process with auxiliary tables (Neal's algorithm 8)
    #
    m <- 3 # number of auxiliary tables to approximate the infinite number of empty tables
    if(alpha==0) {m=0} # in case of no DP

    n <- tabulate(z)
    K <- length(unique(z))
    D <- dim(A)[1]
    R_a0_inv <- solve(R_a0)
    W_a0_inv <- solve(W_a0)

    # Compute likelihood for every table
    logprobs <- rep(NA, K+m)
    for(k in 1:K){
      logp <- log(n[k]-as.numeric(z[u]==k))
      logp <- logp + mvtnorm::dmvnorm(A[,u], mean=mu_ar[,k,drop=FALSE], sigma=solve(S_ar[,,k]), log=TRUE)
      logprobs[k] <- logp
    }
    if(m>0){

      # Create m auxiliary tables from the base distribution
      aux.tables.mean <- t(mvrnorm(m, mu_a0, R_a0_inv))
      aux.tables.covariance <-  rWishart(m, max(beta_a0,D), W_a0/beta_a0)

      # If last point in cluster, re-use its parameters for the auxiliary table so that
      # it has some probability of staying
      if (n[z[u]]==1){
        aux.tables.mean[,1] <- mu_ar[,z[u], drop=FALSE]
        aux.tables.covariance[,,1] <- S_ar[,,z[u]]
      }

      # Compute likelihood for auxilary table
      for(k in 1:m){
        logp <- log(alpha/m)
        logp <- logp + mvtnorm::dmvnorm(A[,u], mean=aux.tables.mean[,k], sigma=as.matrix(aux.tables.covariance[,,k]), log=TRUE)
        logprobs[K+k] <- logp
      }
    }

    # normalize probabilities to avoid numerical underflow
    probs <- logprobs-max(logprobs)
    probs <- exp(probs)
    probs <- probs/sum(probs)

    # Choose table
    chosen <- base::sample(1:(K+m), 1, prob=probs)

    # Re-label tables
    ##########################################
    # if auxiliary table is chosen, assign label K+i-th to this new table
    if(chosen>K){
      mu_ar[,K+1] <- aux.tables.mean[, chosen - K]
      S_ar[,,K+1] <- solve(aux.tables.covariance[,, chosen - K])
      z[u] <- K+1
    }
    else{
      z[u] <- chosen
    }

    # if old cluster is empty, shift right tables to the left
    # do it only if DP is used (m>0)
    n <- tabulate(z)
    if(any(n==0) && (m>0)){
      empty <- which(n==0)
      right <- (empty+1):(K+1)
      mu_ar[,(empty:K)] <- mu_ar[,(empty+1):(K+1)]
      S_ar[,,(empty:K)] <- S_ar[,,(empty+1):(K+1)]
      z[z>empty] <- z[z>empty] - 1
    }

    if((max(z) != length(unique(z))) && (m>0)){
      stop("Some cluster is not being used")
    }

    return(list(z=z,
                mu_ar=mu_ar,
                S_ar=S_ar))
}

sample_z_dual <- function(u, A, B, alpha, z,
                          mu_ar, S_ar, mu_a0, R_a0,  beta_a0, W_a0,
                          mu_br, S_br, mu_b0, R_b0, beta_b0, W_b0){
  #
  # Chinese Restaurant Process with auxiliary tables (Neal's algorithm 8)
  #
  m <- 3 # number of auxiliary tables to approximate the infinite number of empty tables
  if(alpha==0) {m=0} # in case of no DP

  n <- tabulate(z)
  K <- length(unique(z))
  D.a <- dim(A)[1]
  D.b <- dim(B)[1]
  R_a0_inv <- solve(R_a0)
  W_a0_inv <- solve(W_a0)
  R_b0_inv <- solve(R_b0)
  W_b0_inv <- solve(W_b0)

  # Compute likelihood for every table
  logprobs <- rep(NA, K+m)
  for(k in 1:K){
    logp <- log(n[k]-as.numeric(z[u]==k))
    logp <- logp + mvtnorm::dmvnorm(A[,u], mean=mu_ar[,k,drop=FALSE], sigma=solve(S_ar[,,k]), log=TRUE)
    logp <- logp + mvtnorm::dmvnorm(B[,u], mean=mu_br[,k,drop=FALSE], sigma=solve(S_br[,,k]), log=TRUE)
    logprobs[k] <- logp
  }

  if(m>0){

    # Create m auxiliary tables from the base distribution
    aux.tables.mean.a <- t(mvrnorm(m, mu_a0, R_a0_inv))
    aux.tables.covariance.a <-  rWishart(m, max(beta_a0,D.a), W_a0/beta_a0)
    aux.tables.mean.b <- t(mvrnorm(m, mu_b0, R_b0_inv))
    aux.tables.covariance.b <-  rWishart(m, max(beta_b0,D.b), W_b0/beta_b0)

    # If last point in cluster, re-use its parameters for the auxiliary table so that
    # it has some probability of staying
    if (n[z[u]]==1){
      aux.tables.mean.a[,1] <- mu_ar[,z[u], drop=FALSE]
      aux.tables.covariance.a[,,1] <- S_ar[,,z[u]]
      aux.tables.mean.b[,1] <- mu_br[,z[u], drop=FALSE]
      aux.tables.covariance.b[,,1] <- S_br[,,z[u]]
    }

    # Compute likelihood fro auxiliary tables
    for(k in 1:m){
      logp <- log(alpha/m)
      logp <- logp + mvtnorm::dmvnorm(A[,u], mean=aux.tables.mean.a[,k], sigma=as.matrix(aux.tables.covariance.a[,,k]), log=TRUE)
      logp <- logp + mvtnorm::dmvnorm(B[,u], mean=aux.tables.mean.b[,k], sigma=as.matrix(aux.tables.covariance.b[,,k]), log=TRUE)
      logprobs[K+k] <- logp
    }
  }

  # normalize probabilities to avoid numerical underflow
  probs <- logprobs-max(logprobs)
  probs <- exp(probs)
  probs <- probs/sum(probs)

  # Choose table
  chosen <- base::sample(1:(K+m), 1, prob=probs)

  # Re-label tables
  ##########################################
  # if auxiliary table is chosen, assign label K+i-th to this new table
  if(chosen>K){
    mu_ar[,K+1] <- aux.tables.mean.a[, chosen - K]
    S_ar[,,K+1] <- solve(aux.tables.covariance.a[,, chosen - K])
    mu_br[,K+1] <- aux.tables.mean.b[, chosen - K]
    S_br[,,K+1] <- solve(aux.tables.covariance.b[,, chosen - K])
    z[u] <- K+1
  }
  else{
    z[u] <- chosen
  }

  # if old cluster is empty, shift right tables to the left
  # do it only if DP is used (m>0)
  n <- tabulate(z)
  if(any(n==0) && (m>0)){
    empty <- which(n==0)
    right <- (empty+1):(K+1)
    mu_ar[,(empty:K)] <- mu_ar[,(empty+1):(K+1)]
    S_ar[,,(empty:K)] <- S_ar[,,(empty+1):(K+1)]
    mu_br[,(empty:K)] <- mu_br[,(empty+1):(K+1)]
    S_br[,,(empty:K)] <- S_br[,,(empty+1):(K+1)]
    z[z>empty] <- z[z>empty] - 1
  }

  if((max(z) != length(unique(z))) && (m>0)){
    stop("Some cluster is not being used")
  }

  return(list(z=z,
              mu_ar=mu_ar,
              S_ar=S_ar,
              mu_br=mu_br,
              S_br=S_br))
}

sample_b <- function(P, y, z, intercept, mu_ar, S_ar, s_y=10){
  nthreads <- dim(P)[2]
  P <- as.matrix(P)
  Lambda_post <- diag(S_ar[,,z]) + P%*%diag(rep(s_y, nthreads))%*%t(P)

  # Note: be aware of computationally singular matrices (use ginv if necessary)
  Sigma_post <- solve(Lambda_post)
  mu_post <- Sigma_post%*%(as.matrix(S_ar[z]*mu_ar[z]) + s_y*(P%*%as.matrix(y-intercept)))
  return(t(mvrnorm(mu=mu_post, Sigma=Sigma_post)))
}

sample_intercept <- function(P, y, z, B, mu_ar, S_ar, s_y){
  b <- t(B)
  offsets <- (y-t(P)%*%b)
  nthreads <- dim(P)[2]
  P <- as.matrix(P)
  lambda_post <- S_ar + nthreads*s_y
  sigma_post <- solve(lambda_post)
  mu_post <- sigma_post*(mu_ar*S_ar + sum(offsets)*s_y)
  return(rnorm(1, mean=mu_post, sd=sqrt(sigma_post)))
}

sample_noise_inv <- function(P, y, B, variance_y){
  # Sample the noise (its precision) inherent in threads length (y_t = p^t b + N(0, 1/s_y))
  # params gamma(1, var_y
  b <- t(B)
  nthreads <- dim(P)[2]
  gamma_dof_post <- nthreads + 1
  gamma_s_post <- solve(variance_y + sum((y - t(P)%*%b)^2))
  return(rgamma(1, gamma_dof_post/2, scale=2*gamma_s_post))
}

########################################################
# Component parameters
########################################################

sample_mu_ar <- function(A_r, S_ar, mu_a0, R_a0){
    #
    # Samples a mean for cluster r
    # from its conditional probability
    #
    n <- dim(A_r)[2]

    # If nobody in the cluster sample from prior
    if (n == 0){
      return(mvrnorm(1, mu_a0, solve(R_a0)))
    }

    ar_mean <- rowMeans(A_r)
    Lambda_post <- R_a0 + n*S_ar
    Sigma_post <- solve(Lambda_post)
    mu_post <- Sigma_post %*% ((R_a0 %*% mu_a0) + n*(S_ar%*%ar_mean))
    return(mvrnorm(1, mu_post, Sigma_post))
}

sample_S_ar <- function(A_r, mu_ar_k, beta_a0, W_a0){
    #
    # Sample attributes covariance matrix of cluster r
    # from its conditional probability
    #
    n <- dim(A_r)[2]
    D <- dim(A_r)[1]

    # If nobody in the cluster sample from prior
    if (n == 0){
            # unfortunately wishart implementation does not accept dof > F-1
            # but dof >= F
            # This will only affect when the cluster is empty.
            df <- max(beta_a0, D)
            return(rWishart(1, df, solve(W_a0)/beta_a0))
    }
    # If only one point, scatter is just this product
    if(n==1){
      scatter_matrix <- (A_r-mu_ar_k)%*%t(A_r-mu_ar_k)
    }
    if(n > 1){
      scatter_matrix <- cov(t(A_r-c(mu_ar_k)))*(dim(A_r)[2]-1)
    }

    wishart_dof_post <- beta_a0 + n
    wishart_S_post <- solve(beta_a0*W_a0 + scatter_matrix)
    return(rWishart(1, wishart_dof_post, wishart_S_post)[,,1])
}

########################################################
# Hyperparameters
########################################################

# Cluster means
#################
sample_mu_a0 <- function(Lambda_a, mu_a, mu_ar, R_a0){
    #
    # Samples mean of gaussian hyperprior placed over clusters centroids
    #
    K <- dim(mu_ar)[2]
    mean_ar = rowMeans(mu_ar)
    Lambda_post = Lambda_a + K*R_a0
    Sigma_post = solve(Lambda_post)
    mu_post = Sigma_post %*% (Lambda_a %*% mu_a) + K*(R_a0 %*% mean_ar)
    return(mvrnorm(1, mu_post, Sigma_post))
}

sample_R_a0 <-function(Sigma_a, mu_ar, mu_a0){
    #
    # Samples precision of gaussian hyperprior placed over clusters centroids
    #
    K <- dim(mu_ar)[2]
    D <- dim(mu_ar)[1]
    # Can't use the trick cov(t(mu_ar-mu_a0))*(K-1) when there is only one cluster
    scatter_matrix <- 0
    for(i in 1:K){
      scatter_matrix <- scatter_matrix + (mu_ar[,i]-mu_a0)%*%t(mu_ar[,i]-mu_a0)
    }
    wishart_dof_post = D + K
    wishart_S_post = solve(D*Sigma_a + scatter_matrix)
    return(as.matrix(rWishart(1, wishart_dof_post, wishart_S_post)[,,1]))
}

# Cluster covariances
#####################
sample_W_a0 <- function(Lambda_a, S_ar, beta_a0){
    #
    # Sample base covariance of attributes (hyperparameter)
    #
    K <- dim(S_ar)[3]
    D <- dim(S_ar)[1]
    # TODO: why apply does not work properly?
    #scatter_matrix <- apply(S_ar, 3, sum)
    scatter_matrix <- 0
    for (i in 1:dim(S_ar)[3]){
      scatter_matrix <- scatter_matrix + S_ar[,,i]
    }
    wishart_dof_post = D + K*beta_a0
    wishart_S_post = solve(D * Lambda_a + beta_a0*scatter_matrix)
    return(as.matrix(rWishart(1, wishart_dof_post, wishart_S_post)[,,1]))
}

sample_beta_a0 <- function(S, W, init=4){
  # Sample the degrees of freedom of the Wishart
  # given a scale matrix W and some observed precision matrices S
  ars.sample_beta_a0(S, W, init=init)

#   beta_a0 <- NULL
#   attempt <- 1
#   while( is.null(beta_a0) && attempt <= 3 ) {
#     attempt <- attempt + 1
#     try(
#       beta_a0 <- ars.sample_beta_a0(S, W, init=init)
#     )
#   }
#   return(beta_a0)
}


#' es
#'
#' Given a air temperature  in degC gives Vapor Pressure in hPa. Hardy, R.; ITS-90 Formulations for Vapor Pressure, Frostpoint
#' Temperature, Dewpoint Temperature and Enhancement Factors in the Range -100 to 100 degC;
#'
#'
#' @param t numeric Air temperature in Celsius degrees.
#' @return Saturation Vapor Pressure in hPa.
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  air saturation
#' @references Proceedings of Third International Symposium on Humidity and Moisture. National Physical Laboratory (NPL), London, 1998, pp. 214-221 \url{http://www.thunderscientific.com/tech_info/reflibrary/its90formulas.pdf}
#' @export
#'
#'
#'
#'

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


rm(list=ls())
library(lme4)

# Define models

#0# fixed effect trait, random effect (genotype)
data_i <- data.frame(phenodata_sub=phenodata[,i],genotype = genotype[,1])
fmer <- lmer(phenodata~1|genotype, data = data_i, na.action = na.omit)

#1# fixed effect: year, random effect (genotype)
fmer <- lmer(phenodata[,i]~year + (1|genotype), data = phenodata)
fmer <- lmer(v~1|w, data = data_i, na.action = na.omit)

#2# fixed effect: block, random effect (genotype)
fmer <- lmer(phenodata[,i]~block + (1|genotype), data = phenodata)

#3# fixed effects: year and block (additive), random effect (genotype) and covariate response identical for all
fmeria  <- lmer(phenodata[,i]~year + block + (1|genotype), data = phenodata)

#4# fixed effects: (year and block (additive),  random effect (genotype),  interaction (genotype:year) and covariate response identical for all
fmerib  <- lmer(phenodata[,i]~year + block + (1|genotype) + (1|genotype:year), data = phenodata)

#5# fixed effects: (year and block (additive), , hierarchical random effect (genotype),(response to genotype covariate based on year):
fmert  <- lmer(phenodata[,i]~year + block + (-1+year|genotype), data = phenodata)

# Model comparison (most complex vs less complex)
#genotype effect on year+block:
model(2) versus model(0)

#year effect on year+block:
model(1) versus model(0)

#block effect on genotype:
model(2) versus model(1)

#genotype:year interaction on genotype:
model(3) versus model(2)

#year + block hierachical effect on genotype:
model(5) versus model(2)


require(rms)
set.seed(1)
n <- 100
y <- sample(1 : 10, n, TRUE)
x1 <- runif(n)
x2 <- runif(n)
f <- lrm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
set.seed(1)
fb <- bootcov(f, B=400, eps=.001)
k <- c('y>=6', 'x1', 'x2')
set.seed(1)
gb <- bootcov(g, B=400, eps=.001)
list(rownames(f$var), rownames(g$var), rownames(fb$var), rownames(gb$var))
attributes(gb$var)
fb$var[k, k]
gb$var[k, k]

vcov(fb)[k, k]
vcov(gb)
vcov(gb, intercepts='mid')

anova(fb)
anova(gb)
# Still need to understand how bootcov works differently for orm


#' Time derivative of DO concentration
#'
#' @param t Time step for the ode integration
#' @param y Current state (dissolved oxygen concentration) at both sites
#' @param parms a vector of parameters; see details
#' @param data a list of data for the ode; see details
#' @param return_list logical, should a list (suitable for deSolve) be returned?
#' @details `params` must be a vector. The indices of the vector must map to model parameters
#'       as follows; (where parameters with length two are fit per site):
#' * [1:2] -- `P1` $(W min g^{-1} O_2)$ -- inverse of the slope of a photosynthesis–irradiance
#' 			curve at low light intensity
#' * [3:4] -- `P2` $(m^2 min g^{-1} O_2)$ -- inverse maximum photosynthesis rate; can be zero
#' 			to assume GPP is linear with light intensity instead of saturating
#' * [5:6] -- `k600` -- coefficient of gas exchange for a gas with a Schmidt number of 600
#' * [7:8] -- `ER24_20` -- daily ecosystem respiration rate, standardized at 20 degrees C
#'
#' `data` is a list of length 2 (one per site); each item is a list of (constant) data items,
#' 				including the following:
#' * `PAR`  a function that takes time as a parameter and returns light intensity $(W/m^2)$
#' * `temp` a function that takes time as a parameter and returns water temperature (degrees C)
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#'
#' @references Fuß, T. et al. (2017). Land use controls stream ecosystem metabolism by shifting
#' 		 dissolved organic matter and nutrient regimes. *Freshw Biol* **62**:582–599. \\
#'		 Van de Bogert MC et al. 2007. Assessing pelagic and benthic metabolism using free
#' 		 water measurements. *Limnol. Oceanogr.: Methods* **5**:145–155. \\
#' 		 Uehlinger, U., et al. 2000. Variability of photosynthesis‐irradiance curves and
#' 		 ecosystem respiration in a small river. *Freshw Biol* **44**:493–507.
#'
#' @return Time derivative of dissolved oxygen
#' @export
twoStation_dDOdt <- function(t, y, parms, data, return_list=FALSE)
{
	nms <- c('P1', 'P2', 'k600', 'ER24_20')
	parlist <- list(parms[c(1,3,5,7)], parms[c(2,4,6,8)])
	names(parlist[[1]]) <- names(parlist[[2]]) <- nms

	val <- mapply(function(pa, da) oneStation_dDOdt(t, y, pa, da, return_list = FALSE),
		pa = parlist, da = data, SIMPLIFY = !return_list)
	return(val)
}

#' Predict a time series of dissolved oxygen concentration
#' @param ws A [WatershedTools::Watershed()] object, describing ONLY the two sites
#' @param initial initial dissolved oxygen concentration in each station
#' @param lateral Vector  of length two giving the DO concentration of lateral input
#' 		(useful) if discharge varies significantly between the sites, defaults to 0
#' @param times The times at which to solve the system
#' @param params a named vector of parameters; see details
#' @param data a list of data for the ode; see details
#' @param dt Time step for integration; only used if `method == 'euler'`
#' @param method The integration method to use; default is euler

#' @details Light and temperature time series will be approximated using linear interpolation
#' 		at the desired time steps
#'
#' `params` must be a vector. The indices of the vector must map to model parameters
#'       as follows; (where parameters with length two are fit per site):
#' * [1:2] -- `P1` $(W min g^{-1} O_2)$ -- inverse of the slope of a photosynthesis–irradiance
#' 			curve at low light intensity
#' * [3:4] -- `P2` $(m^2 min g^{-1} O_2)$ -- inverse maximum photosynthesis rate; can be zero
#' 			to assume GPP is linear with light intensity instead of saturating
#' * [5:6] -- `k600` -- coefficient of gas exchange for a gas with a Schmidt number of 600
#' * [7:8] -- `ER24_20` -- daily ecosystem respiration rate, standardized at 20 degrees C
#'
#' `data` is a list of length 2 (one per site); each item is a list of (constant) data items,
#' 				including the following:
#' * `PAR`  2-column data frame; first column is light, second is time of observation
#' * `temp` 2-column data frame; first column is temperature, second is time of observation
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#' @return Time series of dissolved oxygen concentrations
#' @export
twoStation_DOPredict <- function(ws, initial, times, params, data, dt = 1,
			method=c('euler', 'lsoda')) {
	method <- match.arg(method)
	if(method == "lsoda" && !(requireNamespace("deSolve")))
		stop("Package deSolve is required for method lsoda; please install it and try again")
	if(times[1] != 0)
		stop('first time step must be 0')
	if(method == 'euler' && sum(times %% dt) != 0)
		stop('dt must divide evenly into all values in times')

	dDOData <- lapply(data, function(x) {
		list(PAR = approxfun(x = x$PAR[,2], y = x$PAR[,1], rule = 2),
			temp = approxfun(x = x$temp[,2], y = x$temp[,1], rule = 2),
			P = x$P,
			z = x$z)
	})

	ddodtParams <- list(parms = params, data = dDOData)
	state <- WatershedTools::transport(ws, initial, lateral, times, method = method, dt = dt,
			rxn = twoStation_dDOdt, rxnParams = ddodtParams)

	return(state)
}

#' Log posterior probability for the DO curve given empirical data
#' @param params A named vector of model parameters; see details
#' @param data A list of model data, see details
#' @param prior A list of prior hyperparameters; see details
#' @param ... Additional parameters to be passed to [DO_predict()]
#' @details `params` must be a vector. The indices of the vector must map to model parameters
#'       as follows; (where parameters with length two are fit per site):
#' * [1:2] -- `logP1` $(W min g^{-1} O_2)$ -- inverse of the slope of a photosynthesis–irradiance
#' 			curve at low light intensity
#' * [3:4] -- `logP2` $(m^2 min g^{-1} O_2)$ -- inverse maximum photosynthesis rate; can be zero
#' 			to assume GPP is linear with light intensity instead of saturating
#' * [5:6] -- `logk600` -- coefficient of gas exchange for a gas with a Schmidt number of 600
#' * [7:8] -- `logER24_20` -- daily ecosystem respiration rate, standardized at 20 degrees C
#' * [9] -- `logsd` -- log(Error standard deviation)
#'
#' `data` is a list of length 2 (one per site); each item is a list of (constant) data items,
#' 				including the following:
#' * `DO` 2-column data frame; first column is dissolved oxygen, second is time of observation
#' * `PAR`  2-column data frame; first column is light, second is time of observation
#' * `temp` 2-column data frame; first column is temperature, second is time of observation
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#'
#' `prior` is a list of hyperparameters for the priors on parameters listed under `params`.
#' All priors are normal. Thus, each list item should be named (following the names from
#' `params`), and each item should be a vector of length two giving the mean and standard
#' deviation of the prior for that parameter. Note that each parameter is optional
#' (as is the entire list); missing items will get a minimally informative normal(0,10)
#'  distribution.
#' @return The unnormalized log probability of the model given the data
#' @export
twoStation_DOlogprob <- function(params, data, prior = list(), ...) {
	logprob <- sum(mapply(oneStation_DOlogprob, params = params, data = data, prior = prior))
	return(logprob)
}


# Read in data, discard useless bits
dfr <- read.table("mlijobs.txt")
dfr <- dfr[,c(2,4)]
# Find most concurrent licences, and when
n.checked.out <- cumsum(ifelse(dfr$V2=="OUT", 1, -1))
times <- strptime(dfr$V4, "%Y/%m/%d_%H:%M:%S")
most.checked.out <- max(n.checked.out)
when.most.checked.out <- times[which(n.checked.out==most.checked.out)]
# As a bonus, plot license use
plot(times, n.checked.out, type="s")


#!/usr/bin/Rscript

# R (http://www.r-project.org/) script for generating
# a "distance matrix" of the RTT between all nodes
# in a test network.
#
# Uses the receipt described here:
# http://stackoverflow.com/questions/3081066/what-techniques-exists-in-r-to-visualize-a-distance-matrix

args <- commandArgs(TRUE)
if (length(args) != 2)
{
	cat("Usage: network-rtt.r <dataset.csv> <output-file>\n")
	q(status = 1)
}
now <- Sys.time()
fdst <- read.csv(args[1])
dim <- ncol(fdst)
dst <- data.matrix(fdst[2:dim])
dim <- ncol(dst)
pdf(args[2], title = sprintf("Network Round Trip Time - %s", format(now, "%Y-%m-%d %H:%M:%S")))
image(1:dim, 1:dim, dst, axes = FALSE, main = sprintf("Network Round Trip Time - %s", format(now, "%Y-%m-%d %H:%M:%S")),
		sub = "Average network round trip time in ms. between nodes", xlab = "", ylab = "")
axis(1, 1:dim, fdst[1:dim,1], cex.axis = 0.5, las = 2)
axis(2, 1:dim, fdst[1:dim,1], cex.axis = 0.5, las = 1)

for (i in 1:dim)
{
	for (j in 1:dim)
	{
		txt <- sprintf("%0.3f", dst[i,j])
		text(i, j, txt, cex=0.5)
	}
}

q(status = 0)