########################################
### Created by Valentino Gaffuri Bedetta
########################################
### on Jan 2019 @ Hult
### This is Fillmore
########################################
########################################

#### CLASSES OF R ####

############
# CLASS N1 #
############

"Hello World"

my_obj1<- "Hello World"
my_number1<-exp(1234)

############
# CLASS N2 #
############

num
summary<-summary(c(1,2,3,4,5,6,7,8,9,10))
print(summary)
sum<-sum(c(1,2,3,4,5,6,7,8,9,10))
product(c()) #is not working, find the correct function
quantile(c(1,2,3,4,5,6,7,8,9,10))
sd(c(1,2,3,4,5,6,7,8,9,10))
mean(c(1,2,3,4,5,6,7,8,9,10))

##### OBJECTS =====>
# 1) SCALER, here we have some examples:
x<-2
y<-3
z<-exp(123)
my_obj<-"Hello World"

# 2) VECTORS
R_names<-c("Thomas","Eliz", "John")
R_seq<- seq(from=1,to=10,by=1)
print(R_seq)
R_erp<-rep(R_seq,each=3)
print(R_erp)
R_erp[6:10]

x<- c(1,2)
y<- c(3,4)
plot(x,y)

## 2 dimensions OBJECTS
# Matrix
my_matrix<-matrix(R_seq, nrow=2,ncol = 5, byrow=T) #here you can rd ncol and will work, R do the math
print(my_matrix)
my_matrix[,3:4] # this is to subset a matrix, before the coma you put the rows, and after the coma you put the columns

# DataFrames
colnames(german_credit_card_without_X)
german_credit_card_without_X$age
sum(german_credit_card_without_X$age)
sd(german_credit_card_without_X$age)
mean(german_credit_card_without_X$age)
summary(german_credit_card_without_X$age)
quantile(german_credit_card_without_X$age)

german_credit_card_without_X$age[3:9]
# when we take out one variable from the dataframe we get a VECTOR!
# A DataFrame and a Matrix is a bunch of vectors
# Remember that DF and Matrixes are 2 dimensional

# Here we create a subset from the SF, is different of just looking at a parto of the DF
# We need to create a vector name, but here we did not do it
german_credit_card_without_X[,c("duration","age")]
german_credit_card_without_X[which(german_credit_card_without_X$age<35),c("duration","age")]
german_credit_card_without_X[which(german_credit_card_without_X$age>35 & german_credit_card_without_X$age<50),c("duration","age")]
# here at hte end we applied some filters in the age column, but again did't create a vector, we need to do that to create another DF

new_subset<-subset(german_credit_card_without_X, age>35)
print(new_subset)

## Types of variables in R

is.numeric(german_credit_card_without_X$age) # the output here is a logical object (logical answer)
is.character(german_credit_card_without_X$age)

# Converting chategorical to numerical data
as.numeric(german_credit_card_without_X$good_bad)
gc<- as.data.frame(german_credit_card_without_X)
# here we will create a new variable "binary" and we will put good as 1
gc$binary<-gc$good_bad
gc[which(gc$binary=="good"), c("binary")] <- 1
print(gc$binary)

# here is a easier way to do it
gc$binary <-gsub("bad",0,gc$binary) #here we change with a simplet method the bas for 0s
print(gc$binary)

gc_clean<-na.omit(gc)
print(gc_clean)

############
# CLASS N3 #
############

library(readxl)
german_credit <- read_excel("Documents/Master USA - HULT/CLASSES/Module B/R/Data to work/german credit card.xls")
View(german_credit)

# To replace we can do it in 2 ways:
# One is less useless for business, because here yo can not put multiple condition
my_new_var <- gsub("X","",german_credit$purpose)
print(my_new_var)

# Here you can put "OR", "AND" to add more condition in the replacement
my_new_var1 <- replace(german_credit$purpose, which(german_credit$purpose=="X"),"")
print(my_new_var1)
# Here we use the "&" operators (remember that both X and Y need to be inside of the cell)
my_new_var2 <- replace(german_credit$purpose, which(german_credit$purpose=="X" & german_credit$purpose=="1"),"ex1")
print(my_new_var1)
# Here we use the "OR" and this is better, because will look for all the values but not in the same cell
my_new_var3 <- replace(german_credit$purpose, which(german_credit$purpose=="X" | german_credit$purpose=="1"),"ex1")
print(my_new_var1)
# Here you can replace when more than oe condition in diferent variables are meet
my_new_var4 <- replace(german_credit$age, which(german_credit$purpose=="X" & german_credit$duration>2),"100")
print(my_new_var1)

# Here we clean the data and we changed the good and bad for biniary,
# because is a character we need to use gsub, and then we transformed to numeric
german_credit$good_bad <- gsub("bad", "0", german_credit$good_bad)
german_credit$good_bad <- gsub("good", "1", german_credit$good_bad)
german_credit$good_bad <- as.numeric(german_credit$good_bad)

# SQL intro

library(rpart)
install.packages("sqldf")
# I have already install the package, so I don't need yo install it again
library(sqldf)

sql_german <- sqldf("
                    SELECT good_bad
                    FROM german_credit
                    WHERE history <4
                    ")

############
# CLASS N4 #
############

## SQL & Loops

# SQL
sql_german <- sqldf("
                    SELECT *
                    FROM german_credit
                    WHERE history <4
                    ")

#Here we are grouping
a <- c(1,1,0,0,1,1)
b <- c(25,30,25,30,40,40)
my_sql_df1 <- data.frame(V1=a,V2=b)
# here we can create a data frame, but to use the loops use the one below

# here we created en empty df with the matrix function
# we use this to use then loops, so we can fill in with date programaticaly
# is a good option to use the matrix to create a DF because you can create the dimension ->
# -> with the matrix function.
my_sql_df <- as.data.frame(matrix(nrow=6, ncol = 2))
my_sql_df$V1 <- a
my_sql_df$V2 <- b
# here we put the data inside of the matrix, you need to select the vectors where you ->
# -> want to put the data inside.

my_sql_df$V3 <- NULL
# here we delete the Vector that we dont use.

colnames(my_sql_df) <- c("good_bad", "age")
# here you are changing the namas of the variables inside the DF

colnames(my_sql_df)[1] <- c('binary_good')
# another way to change the mame of the variable (column), you can select the # of the variable.
colnames(my_sql_df[,1]) <- c('binary_good') # THIS IS WRONG! IS NOT THE WAY!

my_simple_sql <- sqldf("
                      SELECT age, SUM(binary_good)
                       FROM my_sql_df
                      GROUP BY age
                       ")
# here we use SQL to filter and SUM the data inside the DF

sql_german <- sqldf("
                    SELECT good_bad, COUNT(good_bad)
                    FROM german_credit
                    GROUP BY good_bad
                    ")
# here we COUNT the amount of each variable type.

sql_german_cond <- sqldf("
                         SELECT *, CASE WHEN good_bad=0 then 'bad'
                        WHEN good_bad=1 then 'good'
                        ELSE 'wrong' END AS new_var
                        FROM german_credit
                         ")
# here we create a new var in the DF with GOOD and BAD when there are 1 and 0.

## Programing = LOOPS
# FOR LOOP =
#   1) create histograms
#   2) Create subsets
#   3) Replace values
#   4)

for (variable in vector) {

}
# structure of the FOR LOOP

my_vec <- c()
# here we create and empty vector to fill with the LOOP
for (i in 1:3) {
  my_vec[i] <-i
}# closing the i LOOP
# here we get the vector with the data inside

for (i in 1:nrow(german_credit)) {
  my_vec[i] <-german_credit$age[i] > 20
}
# here we do it on the column of the age i the DF of german_credit
# and also here we get FALSE or TRUE in all the columns

german_credit <- as.data.frame(german_credit)
my_var <- c()
for (i in 1:ncol(german_credit)) {
  try(my_var <- as.numeric(german_credit[,i]))
  try(hist(my_var))

}
# here we needed to create a DF, so that's why do the first german_credit <- as.data.frame(german_credit)
# Here be careful because there are some hist that are not being drawn because ->
# -> of the missing values inside of the variables.
# You need to do some cleaning before.

for (i in 1:ncol(german_credit)) {
  try(my_var <- german_credit[-which(is.na(german_credit[,i])),i])
  try(hist(my_var))
}
# this is not working but the professor told us that he will upload the result.

# HERE WE ARE GOING TO SEE CONDITIONAL STATEMENTS = IF STATEMENTS = results TRUE or FALSE
if(german_google$age[10]>20){print("Yay")}
if(german_google$age[10]<20){print("Yay")}
# here you have an easy example of how to use it (2 diff results)

# now you have with more conditions
if(german_google$age[10]>20){print("Yay")} else {"ble"}
if(german_google$age[10]<20){print("Yay")} else {"ble"}

# EXERCICE with the FOR LOOPS
for (i in 1:nrow(german_credit)) {
  if(german_credit$good_bad[i]==1){german_credit$good_bad[i] <- "good"}
  else{german_credit$good_bad[i]<-"bad"}
} # closing the i loop
# this is a really good way to replace the data

############
# CLASS N5 #
############

# Intrapolation - imputation
library(readr)
dataset_Facebook <- read_csv("Documents/Master USA - HULT/CLASSES/Module B/R/Data to work/dataset_Facebook.csv")
View(dataset_Facebook)

facebook<- dataset_Facebook

summary(facebook)

# the following code is a code that Tom uploaded in the annoucements in Kanvas
other_df <- facebook
for(i in 1:nrow(other_df)){
  if( is.na( other_df$like[i] ) ) { other_df$like[i] <- mean(other_df$like[-which(is.na(other_df$like))]) }
}

# here we do the mean of the original dateset, the code was taken from the previous script
# but we do the mean out of the whole script
facebook_mean <- mean(facebook$like[-which(is.na(facebook$like))])
facebook_mean

for(i in 1:nrow(facebook)){
  if( is.na( facebook$like[i] ) ) { facebook$like[i] <- mean(facebook$like[-which(is.na(facebook$like))]) }
}

# Here we can see that this 2 methods are the same, there's no difference.
# Because in the first one the ecuation will out the same mean as in the second one.
other_df$like - facebook$like
# that;s why we get 0 here, because is the same mean.

# we did some code in the file function_dataframe_conert... and we run a lopp there that is
# important

### Objetive achieve ###
## ALL THIS IS USE TO OPTIMIZE PORTFOLIO OF INVESMENT ##

# Here we instal this package to minimize (optimaze to get the min)
# here is to remain as close as possible to the line in the linear regression.
install.packages("minpack.lm")
library(minpack.lm)
y<-c(1,2,3,4)
x<-c(.5,.4,.7,.9)
x2<-c(.1,.2,.3,.4)

my_func <- function(b1, b2){
  y_est <- b1*x + b2*x2
  return(as.numeric(y_est))
}

# here we compare my real Y and the estimation = y_est
my_model <-nlsLM(y ~ my_func(b1,b2))
summary(my_model)

# Using this with an exercise that Tom gave
install.packages("minpack.lm")
library(minpack.lm)
y<-c(1000,480,1800,1000,990)
x<-c(1200,600,1050,860,720)
x2<-c(1050,310,2100,990,880)

my_func <- function(b1, b2){
  y_est <- b1*x + b2*x2
  return(as.numeric(y_est))
}

# here we compare my real Y and the estimation = y_est
my_model <-nlsLM(y ~ my_func(b1,b2))
summary(my_model)
#The weight is 31% for MIX 1 and 71% for mix2 = this is the result

# Here we adding one more mix to previuos one exercise
install.packages("minpack.lm")
library(minpack.lm)
y<-c(1000,480,1800,1000,990) #ojective to reach, as closest as possible
x<-c(1200,600,1050,860,720)
x2<-c(1050,310,2100,990,880)
x3<-c(710,420,1700,1600,1120)

my_func <- function(b1, b2,b3){
  y_est <- b1*x + b2*x2+b3*x3
  return(as.numeric(y_est))
}

# here we compare my real "Y" and the estimation = y_est
my_model <-nlsLM(y ~ my_func(b1,b2,b3))
summary(my_model)
# HERE WE GET AS A RESULT 25% OF MIX 1, 59% FOR MIX 2 AND 17% FOR MIX 3 #

# DICE GAME:
# WE CAN REPRODUCE THROUING TH DICE WITH A FUNCTION SAMPLE

my_uniform<-sample(1:6,1500, replace = T )
hist(my_uniform)
mean(my_uniform)

# Now let's do it with thw coins
my_binomial<-sample(1:2, 94, replace = T)
my_binomial
hist(my_binomial)
mean(my_binomial)

# now let's simulate the poison distribution
# the poition measure the amount of successes
?rpois
# the lamba is the mean here
hist(rpois(1000,2))
hist(rpois(1000,15))
# the bigger the mean the more normal distributed is the data

############################################
######## Exponential Distribution ##########
############################################

# how much time pass between succeses (from one sucess to other sucess)
# we can use this to see the depretiation of a machine or cars in companies if they are going down
# mean= 1/lamba ; variance= 1/lambda^2

#Examples:
# lambda is = to mean, so if we have an lambda of 10 we have a mean of 10 min also
# Let's build this with an histogram:
hist(rexp(1000, rate=10))#, breaks = seq(from=0, to=1000, by=100)) # here we do not use the breaks, so it automaticaly
# The distributions looks steep starting in 0 and going up to 0.8 in the X

# Let's now put the example given in the PDF file Exponential distribution Cheat Sheet:
hist(rexp(1000, rate=.4), breaks = seq(from=0, to=30, by=1))

# Exercise in the PDF of exponential distribution Cheat Sheet:
# Let’s assume that we are talking about the time between each bus (line #1 in SF) at a given stop
# (corner of California and Sansome). The X axis shows how many minutes elapsed since the previous bus.
# In the chart above, 350 buses arrived sooner than 1 minute after the previous bus (blue circle).
# There were also a few busses, maybe 10, that were 15 minutes apart (red circle).
# You know that the distribution is exponential with a λ = 0.4
# The Muni CEO asked you to calculate the probability of the bus arriving:

# a) In more than 10 minutes after the previous bus.
# P(X>10)= exp(-λ*10)
exp(-.4*10)
# RESULT = 0.01831564 -> 1.8 % probability in more than 10 minutes (arrival)

# b) In less than 5 minutes after the previous bus.
# P(X<5) = 1 - exp(-λ*5)
1-exp(-.4*5)
# RESULT = 0.8646647 -> 86.47 % probability in less than 5 minutes (arrival)

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

############
# CLASS N6 #
############

my_means <- c()
for (i in 1:500){
  my_means [i] <-mean(sample(1:2,1000, replace = T))
}
hist(my_means, breaks = seq(from=1, to=2, by=.02))
# here the mean is going to 0.5 with more and more repetitions.
# this is the mean of the means of the samples.

## Some practicing in Exponential Distribution ##
hist(rexp(1000, rate = .2), breaks=seq(from=0, to=50,by=1))

## Exercise = > your company have 30 machines, .4 lambda, surivival exp distrib,
# calculate, P more than 5 years, and, less than 1 year, and the same with a 1000 machines

# A)
exp(-.4*5)
# B)
1-exp(-.4*1)
# C) is the same probability

## Predicting Analytics
# logistical regression:
# we need to use binary if the variable is binomial

my_model<-glm(good_bad~age, data=german_credit, family = "binomial")
#exp(the result of the glm in the first column of the variable, the %)
summary(my_model)
# the result here was 0.0171
# the result is that the increase in the age will get you 1.0172 % of being good.
exp(0.1674)
# My result was different, don't know why
# But you can use this and put the exp to know how much increase or decrease

## Exercise with our dataset in the Census Income
my_model2<-glm(sex_binary~ hours_per_week, data = ci, family = "binomial")
summary(my_model2)
exp(0.043717)

####### IMPORTANT ########
# 1.044 = > every hour you increase the working hour, that increases the odds in 4.4% to being a male

# Function to make it easier
logit2prob <- function(x,coeff,intrcpt){
  logit <- intrcpt + x*coeff
  odds <- odds / (1+odds) # a one - unit change of x
  return(c(odds,prob))
}
logit2prob(x=20,coeff=0.017107,intrcpt = 0.242)
# this is not working but wil work if I correct the dataset German Credit with the 0 and 1 in good_bad

my_model3<-glm(good_bad~age+savings, data=german_credit, family = "binomial")
summary(my_model3)
exp(.015307)
exp(.275489)
#Estimate Std. Error z value Pr(>|z|)
# (Intercept) -0.232612   0.247498  -0.940   0.3473
# age          0.015307   0.006458   2.370   0.0178 *
# savings      0.275489   0.051071   5.394 6.88e-08 ***

my_model4<-glm(sex_binary~ hours_per_week+age, data = ci, family = "binomial")
summary(my_model4)
exp(0.0429692)
exp(0.0117900)

# 1) how 1 increase in the variable impact the odds of success (of being good)
# 2) If I am 20 y what is the Probability of becoming good

### Data Visualization ###
# Use the page 147 for the exam to select the correct chart

library(ggplot2)
ggplot(data = german_credit, aes(age))+
  geom_histogram(binwidth = 5)

ggplot(data = german_credit, aes(age))+
  geom_dotplot()

ggplot(data = german_credit, aes(age, amount))+
         geom_point()

# let's go to the book to see how to apply the plot_ly
library(plotly)
p <- plot_ly(data=iris, x=~Sepal.Length, y=~Petal.Length, color= 'Species')
p

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

############
# CLASS N8 #
############

## Trees -> Prediction Model

# Here we use german credit with the good_bad (binary).
# Here we applied odd ratio (predictiing)
my_logit3<- glm(good_bad ~ age,data=german_credit, family="binomial")
summary(my_logit3)

# Here we take the following value to use the analysis:
# Coefficients:
#            Estimate Std. Error z value Pr(>|z|)
#(Intercept) 0.215281   0.232343   0.927  0.35415
#age    ###0.017886### 0.006413   2.789  0.00529 **
exp(0.017886)

# Here we add more variables in the analysis
my_logit3<- glm(good_bad ~ age+duration+coapp,data=german_credit, family="binomial")
summary(my_logit3)
exp(0.017842)
1-exp(-0.036954) # here you will have a decrease= the odd of succes go down 3.627
# Be carefull with the p-value, is huge (0.45148) so we need to eliminate
exp(0.116674)
#               Estimate Std. Error z value Pr(>|z|)
#  (Intercept)  0.890704   0.326577   2.727  0.00638 **
#  age          0.017842   0.006620   2.695  0.00704 **
#  duration    -0.036954   0.005728  -6.452 1.11e-10 ***
#  coapp        0.116674   0.154954   0.753  0.45148

# Here we eliminate hte coapp because was a bad variable.
my_logit3<- glm(good_bad ~ age+duration,data=german_credit, family="binomial")
summary(my_logit3)
#             Estimate Std. Error z value Pr(>|z|)
#(Intercept)  1.030311   0.269726   3.820 0.000134 ***
#  age          0.017703   0.006617   2.676 0.007460 **
#  duration    -0.037038   0.005725  -6.470  9.8e-11 ***

### Here we will start using TREES with TITANIC
# Here we will intall a few packages
# And run them after installing them
install.packages("rpart.plot")
install.packages("titanic")
install.packages("ROCR")
library(rpart)
library(titanic)
library(rpart.plot)
library(ROCR)

# first let's create a df with titanic
my_df_titanic <- as.data.frame(titanic_train)

# Now let's explore the data
summary(my_df_titanic)

# Now let's create a Logistic Regresion
my_titanic_champ <- glm(Survived ~ Pclass+Sex+Age+SibSp, data= my_df_titanic, family = "binomial")
summary(my_titanic_champ)
# here we see all the variables significant, less than 0

# here we take the values LN and transforme those to exp.
# We put the 1-exp() because the value is negative.
1-exp(-1.317398)
# Result = 73.21% if you change your class to one les class the probability of survive goes down 73.21%
1-exp(-2.623483)
# Result = 92.74% if you change your class to one les class the probability of survive goes down 92.74%
1-exp(-0.044385)
# Result = 4.34% if you change your class to one les class the probability of survive goes down 4.34%
1-exp(-0.376119)
# Result = 31.34% if you change your class to one les class the probability of survive goes down 31.34%

# Here we create the TREE
titanic_tree <- rpart(Survived ~ Pclass+Sex+Age+SibSp, data= my_df_titanic, method = "class")
rpart.plot(titanic_tree, type = 1, extra = 1)
# here we get the tree with the probabilities of the posibilities

# EXAM QUESTION ###################################
# If I want to get the model smaller.
# If the tree is too big is over fitting my data, I need to reduce the model fit
# If the tree is too small, too general, and I need to improve the model fit
# INCREASE THE CP AND YOU GET A smaller TREE, AND VICEVERSA:
# DECREASE THE CP VALUE - THE TREE gets bigger
titanic_tree <- rpart(Survived ~ Pclass+Sex+Age+SibSp, data= my_df_titanic, method = "class", cp=0.003)
rpart.plot(titanic_tree, type = 1, extra = 1)

# INCREASE THE CP VALUE - THE TREE gets SMALLER
titanic_tree <- rpart(Survived ~ Pclass+Sex+Age+SibSp, data= my_df_titanic, method = "class", cp=0.09)
rpart.plot(titanic_tree, type = 1, extra = 1)

# If we want to optimize the size we use the following function
# plotcp()
titanic_tree <- rpart(Survived ~ Pclass+Sex+Age+SibSp, data= my_df_titanic, method = "class", cp=0.01)
rpart.plot(titanic_tree, type = 1, extra = 1)
plotcp(titanic_tree)
# the better size of the cp value is the smallest in the graph.
# Here is 0.013

# we change the cp value
titanic_tree <- rpart(Survived ~ Pclass+Sex+Age+SibSp, data= my_df_titanic, method = "class", cp=0.013)
rpart.plot(titanic_tree, type = 1, extra = 1)
plotcp(titanic_tree)
# Now the better size is 0.015
# always try a few CP values to see what is the best for your purpose
# WE CAN COMPARE THE MODEL WITH A CHART (LIFT-GAINS CHART)
# WITH THESE CHART WE CAN SEE WHICH MODEL IS BETTER TO PRESENT AND TO SHOW
# AND SUGGEST WHICH IS THE BEST CHART.
# Pruning is getting the chart smaller -> and we need to generalize the model and
# --> not to improve the fit.

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

############
# CLASS N9 #
############

#install.packages("rpart")
#install.packages("rpart.plot")
#install.packages("titanic")
#install.packages("ROCR")
##############################
#Creating a logistic regression for titanic
##############################
library(rpart)
mydf_train <- as.data.frame(titanic_train)
summary(mydf_train)#let's see what's in the data
View(mydf_train)
#creating a champion model with the titanic_train dataset:
my_logistic <- glm(Survived ~ Pclass + Sex + Age+ SibSp, data = titanic_train, family="binomial")
summary(my_logistic)
#predicting probability of 1
predict_logit <- predict(my_logistic, mydf_train, type="response")#
print(predict_logit)
# here you get the probabilities of every passenger and the probability of living
# The probability of success

##############################
#Creating a tree for titanic
##############################
library(titanic)
mytree <- rpart(Survived ~ Pclass + Sex + Age+ SibSp, data = titanic_train, method = "class")#, control=rpart.control(minsplit=50, cp=0.013))
rpart.plot::rpart.plot(mytree, type = 1, extra=1, box.palette =c("pink", "green"), branch.lty=3, shadow.col = "gray")

plotcp(mytree)#getting the best cp value, do we need to go back and prune?
#use the cp value that has the lower error

############################################
#####The section below is optional##########
############################################
#The section below will explain the basics of
#model comparison and will code
#the lifts and gains chart
#### Create the lift and gains chart
#Scoring the model
library(ROCR)
mydf <- as.data.frame(titanic_train)
val_1 <- predict(mytree, mydf, type="prob")#We want to predict probability of 1 for each observations
print(val_1)
#Storing Model Performance Scores

pred_val <- prediction(val_1[,2], mydf$Survived) # tree regression
pred_val_logit <- prediction(predict_logit, mydf$Survived) # logistical regression
#we need performance
perf <- performance(pred_val,"tpr","fpr") # tree regression
perf_logit <- performance(pred_val_logit,"tpr","fpr") #logistical regression
#Plotting Lift Curve
plot(perf,col="black",lty=3, lwd=3)
plot(perf_logit,col="blue",lty=3, lwd=3, add=TRUE)
#plot(performance(pred_val, measure="lift", x.measure="rpp"), colorize=TRUE)

# Now let's use the prediction func to use in the german credit
# Here I copy again the model construction
my_logit3<- glm(good_bad ~ age+duration,data=german_credit, family="binomial")
summary(my_logit3)

# Here I construct the TREE model and make the graph
german_credit_tree <- rpart(good_bad ~ age+duration,data=german_credit, method = "class", cp=0.014)
rpart.plot(german_credit_tree, type = 1, extra = 1)
# here we can see that the main important split is with the duration and then age.

# let's do a plotcp to see if the size is OK
plotcp(german_credit_tree)
# now here we have the plots
rpart.plot::rpart.plot(mytree, type = 1, extra=1, box.palette =c("pink", "green"), branch.lty=3, shadow.col = "gray")
plotcp(mytree)

# here we try to put more variables into the tree, and let's see what happens
german_credit_tree_moreV <- rpart(good_bad ~ age+duration+savings+checking+coapp,data=german_credit, method = "class",cp=0.0065)
rpart.plot(german_credit_tree_moreV, type = 1, extra = 1)
plotcp(german_credit_tree_moreV)
# Here you can see that the model rid COAPP taht was not statisticaly signicant
# So here we can put all the variables and the model will rid the ones that
# are not important.
# IN THE TREE INCLUDE MORE THAN YOU NEED BECAUSE THE MODEL WILL RID

# BUT REMEMBER TO COMPARE MODELS WITH THE SAME VARIABLES, ALWAYS!!!
# If you want to compare put the same variables in all the models

#creating a tree regression
german_credit_tree_moreV <- rpart(good_bad ~ age+duration+savings+checking+coapp,data=german_credit, method = "class",cp=0.0065)
rpart.plot(german_credit_tree_moreV, type = 1, extra = 1)
plotcp(german_credit_tree_moreV)

View(ci)
census_income_tree <- rpart(sex_binary ~ gnlwgt+hours_per_week+education_num+age,data=ci, method = "class",cp=0.0087)
rpart.plot(census_income_tree, type = 1, extra = 1)
plotcp(census_income_tree)

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

############
# CLASS N9 #
############

# Here we will see Shiny
# First we need to install the package

install.packages('rsconnect')
library('rsconnect')
# Here I went to create a new Shiny Web App in the buton in the left upper corner


words <- readLines("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt")
word_group <- sapply(
    strsplit(words, split=""), # this will split all words to single letters...
    function(x) paste(sort(x), collapse="") # ...which we sort and paste again
)

counts <- tapply(words, word_group, length) # group words by class to get number of anagrams
anagrams <- tapply(words, word_group, paste, collapse=", ") # group to get string with all anagrams

# Results
table(counts)
counts
    1     2     3     4     5
22263  1111   155    31     6

anagrams[counts == max(counts)]
                               abel                               acert
     "abel, able, bale, bela, elba" "caret, carte, cater, crate, trace"
                              aegln                               aeglr
"angel, angle, galen, glean, lange" "alger, glare, lager, large, regal"
                               aeln                                eilv
     "elan, lane, lean, lena, neal"      "evil, levi, live, veil, vile"


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')
library(rJava)

setwd("/Users/mengmengjiang/all datas/maxfp")

library(xlsx)

# reading execl

k1<-read.xlsx("gly1.xlsx",sheetName="qd2-20",header=TRUE)

par(mfrow = c(2,1), mar = c(2,2.4,0.8,1), oma = c(1,1,1,1))
layout(matrix(c(1,2), 2, 1,byrow = TRUE))

plot(k1$fv,k1$deva,col="0",xlab = expression(italic(f["v"]) (Hz)),
          ylab =expression(italic(D)(um)), mgp=c(1.1, 0, 0),tck=0.02,
               main = "",xlim = c(0,4000),ylim=c(0,80))

points(k1$fv,k1$deva,col="red",pch=0)

z1=loess(k1$deva~k1$fv,span=0.5,degree=2)

lines(k1$fv,z1$fit,col="red",lwd=1.5,lty=2,type="b")

abline(lm(k1$deva~k1$fv),pch=0,type="b",col="blue",lwd=1.5,lty=2)

mtext("Droplet size and fitting",3,line=-1,font=2,cex=1)

leg1<-c("Droplet real","Droplet fit")

legend("topright",legend=leg1,col=c("red","blue"),pch=c(0,1),lwd=1.5,lty=2,
bty="n",inset=.02,cex=0.9)

plot(k1$fv,k1$deva,col=0,xlab = expression(italic(f["v"]) (Hz)),ylab =expression(italic(U["s"]) (mm/s)), mgp=c(1.1, 0, 0),tck=0.02,main = "",xlim = c(0,4000),ylim=c(0,80))

mtext("Critical velocity Us",3,line=0-1,font=2,cex=1)

# 临界速度的拟合

# 实际的临界速度为Sd=0，液滴k1$deva * k1$fv的结果

# 拟合的数据，为根据

fit<-(k1$deva*k1$fv*0.9)/1000 # 真实数据
fv<-1:4000

lines(k1$fv,fit,col="black",pch=0,type="b",lwd=2.5,lty=2)

x<-1:4000
y<-(x*(-0.01046*x+54)*0.9)/1000

lines(x,y,col="green3",lwd=2.5,pch=1,cex=0.5,lty=2)

leg2<-c("Us real","Us fitting")
legend("topleft",legend=leg2,pch=c(0,1),col=c("black","green3"),lwd=1.5,
bty="n",inset=.02,cex=0.9)


#!/usr/bin/env Rscript
# Title: rpkm_log2_fer.r
# Purpose of script: barplot with the log2 RPKM values
# Date created: 20.08.2021
# Author: Luigui Gallardo-Becerra (bfllg77@gmail.com)

# Packages
if (!require("ggplot2")) install.packages("ggplot2")
if (!require("ggpubr")) install.packages("ggpubr")
if (!require("svglite")) install.packages("svglite")
if (!require("optparse")) install.packages("optparse")

library("ggplot2")
library("ggpubr")
library("svglite")
library("optparse")

#Declaration of variables
option_list = list(
  make_option(c("-i", "--input"),
              default=NULL,
              help="Required: Input matrix (separated by tabs) whith the format: scaffold|value"),
  make_option(c("-o", "--output"),
              default=NULL,
              help="Required: Output prefix name"),
  make_option(c("-t", "--title"),
              default="",
              type="character",
              help="Title of graph"),
  make_option(c("-c", "--color"),
              default="skyblue4",
              type="character",
              help="Color of the bars")
)

opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

# Data input
rpkm_table <- read.table(opt$input,
                          sep = '\t',
                          header = TRUE)

# log2 transformation
rpkm_table$value = log2(rpkm_table$value)

# Graph
theme_set(theme_bw())

rpkm_histograpm_plot <- ggplot(rpkm_table, aes(x=value)) +
  geom_histogram(aes(x=value),
                 colour="black",
                 fill=opt$color,
                 binwidth = 0.1) + # Distance between values to plot (default = 1)
  labs(x="log2 (RPKM)",
       y="Frecuency",
       title=opt$title)

# Plot information
plot_information <- ggplot_build(rpkm_histograpm_plot)

plot_information_data <- plot_information$plot$data

write.table(plot_information_data,
            file = paste(opt$output,".txt", sep = ""),
            sep = '\t',
            row.names = FALSE)

# Output files
# svg
svglite(file = paste(opt$output,".svg", sep = ""))
  print(rpkm_histograpm_plot)
dev.off()

# png
png(file = paste(opt$output,".png", sep = ""))
  print(rpkm_histograpm_plot)
dev.off()


#Plot the memory model, first argument is the upperbound, the the dataset containing the plotting data
args<-commandArgs(TRUE)
lowerbound <-  as.integer(args[1])
upperbound <-  as.integer(args[2])
dataset <- read.csv(args[3])
filename = gsub(".csv", "", args[3])
fileNameEt <- paste(filename, "_FREQUENCE.png", sep="")
graphtitle1 <- paste(paste("RESULT EN0-EN9 ", lowerbound), upperbound)
graphtitle2 <- "FREQ AVG RESULT "
png(paste(fileNameEt), 1827, 1458)
xmean <- rowMeans(cbind(dataset$MEMB0,dataset$MEMB1 ,dataset$MEMB2 ,dataset$MEMB3 ,dataset$MEMB4,dataset$MEMB5,dataset$MEMB6,dataset$MEMB7,dataset$MEMB8,dataset$MEMB9))

#Plot first Graph: All the dataset for 5 experiments

#______ Window With 2 Rows, Top Row In 2 Columns ______#
split.screen(c(2,1)) # Makes Screen 1 and 2
split.screen(c(1,2), screen=1) # Makes Screen 3 and 4
screen(3)
d<- density(xmean)
plot(d, main = "Density" )
screen(4)
d<- density(xmean[lowerbound:upperbound])
plot(d, main = "Density Steady" )
screen(2)
split.screen(c(1,2), screen=2)
hist(xmean, main="Histogram", labels=TRUE, breaks=10)
screen(6)
hist(main="Histogram Steady", xmean[lowerbound:upperbound], labels=TRUE, breaks=10)

dev.off()


ascale <- function(freq, band) {
  rtn <- data.frame(amp=numeric(), freq=numeric(), band=numeric())
  n <- length(freq)
  for (i in 1:n) {
    a <- max(formant(freq[i], band[i], 8000, 8000))
    rtn <- rbind(rtn, data.frame(amp=a, freq=freq[i], band=band[i]))
  }
  return(rtn)
}

estAmp <- function() {
  rtn <- data.frame(band=numeric(), slope=numeric(), intercept=numeric(), row.names=NULL)
  for (b in seq(40,4000, 10)) {
    tmp <- data.frame(amp=numeric(), freq=numeric())
    for (f in seq(100,8000,10)) {
      a <- max(formant(f, b, 8000, 8000))
      tmp <- rbind(tmp, data.frame(amp=a, freq=f))
    }
    tmp.lm <- lm(amp ~ freq, data=tmp)
    rtn <- rbind(rtn, data.frame(band=b, intercept=tmp.lm$coefficients[1],
                 slope=tmp.lm$coefficients[2]), row.names=NULL)
  }
  return(rtn)
}


library(rvest)
library(httr)
library(data.table)
library(tidyverse)
library(WDI)
library(countrycode)
library(lmtest)
library(tseries)
library(plm)
library(rvest)
library(httr)
library(quantmod)
library(fredr)
library(scales)
library(quantreg)

stacked_oecd_wdi_data_lags_diffs = read_csv('data/stacked_oecd_wdi_data_lags_diffs.csv')
wide_oecd_wdi_data = read_csv('data/wide_oecd_wdi_data.csv')

##### Simple panel data models #####
oecd_wdi_pdata = pdata.frame(wide_oecd_wdi_data, index = c('Country', 'Year'))

pooling_model = plm(diff_value_TAXINCOME ~ diff_value_NY.GDP.PCAP.KD.ZG, model = 'pooling', data = oecd_wdi_pdata)
fixed_model = plm(diff_value_TAXINCOME ~ diff_value_NY.GDP.PCAP.KD.ZG, model = 'within', data = oecd_wdi_pdata)
random_model = plm(diff_value_TAXINCOME ~ diff_value_NY.GDP.PCAP.KD.ZG, model = 'random', data = oecd_wdi_pdata)
fixed_time_model = plm(diff_value_TAXINCOME ~ diff_value_NY.GDP.PCAP.KD.ZG + factor(Year), model = 'within', data = oecd_wdi_pdata)

summary(fixed_model)
summary(random_model)

# check whether to use random effects. <0.05 then use fixed
phtest(fixed_model, random_model)

# check for time based effects -- there are significant time based effects
pFtest(fixed_time_model, fixed_model)
plmtest(fixed_model, c("time"), type=("bp"))

# check for panel effects  -- there are time based but not individual effects
plmtest(pooling_model, type=c("bp"))

# check for cross-sectional dependence
pcdtest(fixed_model, test = c("lm")) # there is cross sectional dependence
pcdtest(fixed_model, test = c("cd")) # there is cross sectional dependence

# test for serial correlation
pbgtest(fixed_model) # there is serial correlation

# test for unit roots
adf.test(filter(oecd_wdi_pdata, !is.na(diff_value_TAXINCOME))$diff_value_TAXINCOME, k=1) # none present

# check for heteroskedacity
bptest(diff_value_TAXINCOME ~ diff_value_NY.GDP.PCAP.KD.ZG, data = oecd_wdi_pdata, studentize=F)
coeftest(fixed_model, vcovHC(fixed_model, method = "arellano"))


#' cn_uncertainty_neon.r
#' Calculates observation sd of C:N based on analytical replicates of NEON data.
#' sd scales with magnitude of C:N observation (heteroscedastic).
#'
#' @param x value or vector of C:N observations to estimate observation uncertainty of.
#'
#' @return vector of observation sd.
#' @export
#'
#' @examples
cn_uncertainty_neon <- function(x){
  #load model fit.
  source('paths.r')
  mod <- readRDS(cn_NEON_uncertainty_model.path)
  #grab k parameters that predict standard deviation.
  pars <- mod[grep('k',rownames(mod)),][,4]
  sd <- pars[1] + x*pars[2]
  #return standard deviation.
  return(sd)
}


#' pC_uncertainty_neon.r
#' Calculates observation sd of %C based on analytical replicates of NEON data.
#' sd scales with magnitude of %C observation (heteroscedastic).
#'
#' @param x value or vector of %C observations to estimate observation uncertainty of.
#'
#' @return vector of observation sd.
#' @export
#'
#' @examples
pC_uncertainty_neon <- function(x){
  #load model fit.
  source('paths.r')
  mod <- readRDS(pC_NEON_uncertainty_model.path)
  #grab k parameters that predict standard deviation.
  pars <- mod[grep('k',rownames(mod)),][,4]
  sd <- pars[1] + x*pars[2]
  #return standard deviation.
  return(sd)
  }


library(plm)

Panel <- read.csv("C:/data/financials/h2_variables.txt")

fixed <- plm(score ~ post + ifrs + post:ifrs + adopt + dROA + dCURRENT
             + dDEBTDUE + dLEVERAGE + dFCF + merger + split + big + first
             + factor(KSIC)
             , data=Panel, index=c("X10", "year")
             , effect = "twoway"
             , model="within")

summary(fixed)

library(fixest)


######    M-ComBat   ###########################################################################################
##
##   Overview:  Script necessary to perform M-ComBat to transform GEP data to
##              a pre-determined, 'gold-standard' subset of samples.
##
##   Requirements:
##    Load 'sva' package
##
##   Input:
##     'dat' = p by n data.frame or matrix , genomic measure matrix
##                 ( dimensions: probe by sample )
##     'batch' = numeric vector of batch association, length n
##     'center' = numeric value of 'gold-standard' batch
##     'mod' = model matrix of potential covariates
##     'numCovs' = column number of variables in 'mod' to be treated as continuous variables
##                   (otherwise all covariates treated as factors)
##  Source : https://github.com/SteinCK/M-ComBat
#############################################################################################################
M.COMBAT <- function (dat, batch, center , mod, numCovs = NULL )
{
  batch <- as.factor(batch)
  batchmod <- model.matrix(~-1 + batch)
  cat("Found", nlevels(batch), "batches\n")
  n.batch <- nlevels(batch)
  batches <- list()
  for (i in 1:n.batch) {
    batches[[i]] <- which(batch == levels(batch)[i])
  }
  n.batches <- sapply(batches, length)
  n.array <- sum(n.batches)
  design <- cbind(batchmod, mod)
  check <- apply(design, 2, function(x) all(x == 1))
  design <- as.matrix(design[, !check])
  n.batches <- sapply(batches, length)
  n.array <- sum(n.batches)
  NAs = any(is.na(dat))
  if (NAs) {
    cat(c("Found", sum(is.na(dat)), "Missing Data Values\n"),
        sep = " ")
    stop()
  }
  cat("Standardizing Data across genes\n")

  B.hat <- solve(t(design) %*% design) %*% t(design) %*% t(as.matrix(dat))

  # variance of batch of interest
  var.batch <- apply(dat[, batch==center], 1, var)
  var.pooled <- ((dat - t(design %*% B.hat))^2) %*% rep(1/n.array, n.array)

  grand.mean <- t(n.batches/n.array) %*% B.hat[1:n.batch, ]
  stand.mean <- t(grand.mean) %*% t(rep(1, n.array))

  # accounts for covariates here
  if (!is.null(design)) {
    tmp <- design
    tmp[, c(1:n.batch)] <- 0
    stand.mean <- stand.mean + t(tmp %*% B.hat)}

  # standardized data
  s.data <- (dat - stand.mean)/(sqrt(var.pooled) %*% t(rep(1, n.array)))

  cat("Fitting L/S model and finding priors\n")
  batch.design <- design[, 1:n.batch]

  gamma.hat <- solve(t(batch.design) %*% batch.design) %*% t(batch.design) %*% t(as.matrix(s.data))

  delta.hat <- NULL
  for (i in batches) {
    delta.hat <- rbind(delta.hat, apply(s.data[, i], 1, var,  na.rm = T)) }

  gamma.bar <- apply(gamma.hat, 1, mean)
  t2 <- apply(gamma.hat, 1, var)
  a.prior <- apply(delta.hat, 1, sva:::aprior)
  b.prior <- apply(delta.hat, 1, sva:::bprior)

  gamma.star <- delta.star <- NULL

  cat("Finding parametric adjustments\n")
  for (i in 1:n.batch) {

    temp <- sva:::it.sol(s.data[, batches[[i]]], gamma.hat[i,], delta.hat[i, ], gamma.bar[i], t2[i], a.prior[i], b.prior[i])

    gamma.star <- rbind(gamma.star, temp[1, ])
    delta.star <- rbind(delta.star, temp[2, ])
  }

  cat("Adjusting the Data\n")
  bayesdata <- s.data
  j <- 1
  for (i in batches) {
    bayesdata[, i] <- (bayesdata[, i] - t(batch.design[i,] %*% gamma.star))/(sqrt(delta.star[j, ]) %*% t(rep(1, n.batches[j])))
    j <- j + 1
  }

  bayesdata <- (bayesdata * (sqrt(var.batch) %*% t(rep(1, n.array)))) + matrix( B.hat[center,] , nrow(dat) , ncol(dat))

  return(bayesdata)
}

MComBat_harmonization = function(data, covariate, batch, ref_batch, numCovs)
{
  #=== Installing missing packages ===
  if (!requireNamespace("BiocManager", quietly = TRUE)){install.packages("BiocManager", repos = 'https://cloud.r-project.org/')}
  package_list = c("RCurl", "sva")
  for (package in package_list)
  {
    print(sprintf('%s', package))
    if (!require(package, character.only = TRUE)){BiocManager::install(package)}
    library(package, character.only = TRUE)
  }
  #=== Preprocess data ===
  data <- as.data.frame(sapply(data, as.numeric))
  data <- t(data)
  ref_batch <- seq(length(unique(batch)))[unique(batch) == ref_batch]
  batch <- factor(x = batch, levels = unique(batch), labels = seq(length(unique(batch))))
  mod <- model.matrix(~ ., data = as.data.frame(covariate))
  #=== ComBat ===
  RES <- M.COMBAT(data, batch, ref_batch, mod, numCovs)
  Combat_data <- as.data.frame(t(RES))
  return(Combat_data)
}


library(rstan)

d <- read.csv(file='…/ch.5/input/data-attendance-3.txt')
d_conv <- data.frame(X=c(1, 2, 3))
rownames(d_conv) <- c('A', 'B', 'C')
data <- list(I=nrow(d), A=d$A, Score=d$Score/200, WID=d_conv[d$Weather, ], Y=d$Y)

fit <- stan(file='…/ch.5/e/ex4.stan', data=data, pars=c('b', 'bw2', 'bw3'), seed=1234)


#
# Example R program using e1071 library
# See http://cran.r-project.org/web/packages/e1071/e1071.pdf for documentation
#

library("e1071")

## build a graph with 5 nodes
x <- matrix(NA, 5, 5)
diag(x) <- 0
x[1,2] <- 30; x[1,3] <- 10
x[2,4] <- 70; x[2,5] <- 40
x[3,4] <- 50; x[3,5] <- 20
x[4,5] <- 60
x[5,4] <- 10
print(x)

## compute all path lengths
z <- allShortestPaths(x)
print(z)

## the following should give 1 -> 3 -> 5 -> 4
extractPath(z, 1, 4)


# seed for replication
set.seed(297165)
SIZES = c(100, 200, 400, 800)
NOISEDIMS = 8

# ============ UNIFORMLY DISTRIBUTED NOISE
for (n in SIZES) {
    data <- rep(1, n)
    for (i in 1:NOISEDIMS) {
        data <- cbind(data, runif(n, min = 0, max = 1))
    }
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:NOISEDIMS))
    write.table(data, file = paste("data/uniform-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ NORMALLY DISTRIBUTED NOISE
for (n in SIZES) {
    data <- rep(1, n)
    for (i in 1:NOISEDIMS) {
        data <- cbind(data, rnorm(n, mean = 0.5))
    }
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:NOISEDIMS))
    write.table(data, file = paste("data/normal-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ LINEAR NOISE
for (n in SIZES) {
    data <- rep(1, 3*n)
    data <- cbind(data, runif(3 * n, min = -1, max = 2))
    for (i in 1:(NOISEDIMS-1)) {
        data <- cbind(data, data[, i + 1] + runif(3 * n, min = -0.1, max = 0.1))
    }
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:NOISEDIMS))
    for (i in 1:NOISEDIMS) {
        x <- data[, paste("dimension", i)]
        #data[,paste("dimension", i)] <-  (x >= 0 && x <= 1) * x
    }
    write.table(data, file = paste("data/linear-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ MAXIMUM VARIANCE DATA
C = 50 # number of datapoints per cluster
for (n in SIZES) {
    data <- c(rep(2, C), rep(3, C), rep(4, C))
    data <- cbind(data, c(runif(C, min = 0, max = 0.24), runif(C, min = 0.38, max = 0.62), runif(C, min = 0.76, max = 1)))
    data <- cbind(data, c(runif(C, min = 0, max = 0.24), runif(C, min = 0.38, max = 0.62), runif(C, min = 0.76, max = 1)))
    data <- cbind(data, c(runif(C, min = 0, max = 0.24), runif(C, min = 0.38, max = 0.62), runif(C, min = 0.76, max = 1)))
    data <- cbind(data, c(runif(C, min = 0.38, max = 0.62), runif(C, min = 0.76, max = 1), runif(C, min = 0, max = 0.24)))
    data <- cbind(data, c(runif(C, min = 0.38, max = 0.62), runif(C, min = 0, max = 0.24), runif(C, min = 0.76, max = 1)))
    if (n > 100) {
        m <- (n - 100)
        data <- rbind(cbind(rep(1, m), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1)), data)
    }
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:5))
    write.table(data, file = paste("data/variance-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ SYNTHETIC DATA 1
C = 30 # number of datapoints per cluster
for (n in SIZES) {
    data <- c(rep(1, C), rep(2, C), rep(3, C), rep(4, C))
    data <- cbind(data, c(runif(C, min = 0, max = 0.17), runif(C, min = 0.28, max = 0.45), runif(C, min = 0.56, max = 0.73), runif(C, min = 0.83, max = 1))) #1
    data <- cbind(data, c(runif(C, min = 0.28, max = 0.45), runif(C, min = 0, max = 0.17), runif(C, min = 0.56, max = 0.73), runif(C, min = 0.83, max = 1))) #2
    data <- cbind(data, c(runif(C, min = 0, max = 0.17), runif(C, min = 0.56, max = 0.73), runif(C, min = 0.56, max = 0.73),  runif(C, min = 0.83, max = 1))) #3
    data <- cbind(data, c(runif(C, min = 0.28, max = 0.45), runif(C, min = 0, max = 0.17), runif(C, min = 0.83, max = 1), runif(C, min = 0.73, max = 0.9))) #4
    data <- cbind(data, c(runif(C, min = 0, max = 0.17), runif(C, min = 0.04, max = 0.21), runif(C, min = 0.83, max = 1), runif(C, min = 0.59, max = 0.76))) #5
    data <- cbind(data, c(runif(C, min = 0.83, max = 1), runif(C, min = 0, max = 0.17), runif(C, min = 0.83, max = 1), runif(C, min = 0.20, max = 0.37))) #6
    data <- cbind(data, c(runif(C, min = 0, max = 0.17), runif(C, min = 0.82, max = 1), runif(C, min = 0.83, max = 1), runif(C, min = 0, max = 0.17))) #7
    data <- cbind(data, c(runif(C, min = 0.83, max = 1), runif(C, min = 0.83, max = 1), runif(C, min = 0.80, max = 0.97), runif(C, min = 0, max = 0.17))) #8
    if (n > 100) {
        m <- (n - 100)
        data <- rbind(cbind(rep(1, m), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1)), data)
    }
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:8))
    write.table(data, file = paste("data/synthetic-1-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ SYNTHETIC DATA 2
C = 30 # number of datapoints per cluster
for (n in SIZES) {
    data <- c(rep(1, C), rep(2, C), rep(3, C), rep(4, C))
    data <- cbind(data, sort(runif(n, min = 0, max = 1)))
    data <- cbind(data, sort(runif(n, min = 0, max = 1)))
    data <- cbind(data, sort(runif(n, min = 0, max = 1), decreasing = TRUE))
    data <- cbind(data, c(runif(C, min = 0.28, max = 0.45), runif(C, min = 0, max = 0.17), runif(C, min = 0.83, max = 1), runif(C, min = 0.73, max = 0.9))) #4
    data <- cbind(data, c(runif(C, min = 0, max = 0.17), runif(C, min = 0.04, max = 0.21), runif(C, min = 0.83, max = 1), runif(C, min = 0.59, max = 0.76))) #5
    data <- cbind(data, c(runif(C, min = 0.83, max = 1), runif(C, min = 0, max = 0.17), runif(C, min = 0.83, max = 1), runif(C, min = 0.20, max = 0.37))) #6
    data <- cbind(data, c(runif(C, min = 0, max = 0.17), runif(C, min = 0.82, max = 1), runif(C, min = 0.83, max = 1), runif(C, min = 0, max = 0.17))) #7
    data <- cbind(data, c(runif(C, min = 0.83, max = 1), runif(C, min = 0.83, max = 1), runif(C, min = 0.80, max = 0.97), runif(C, min = 0, max = 0.17))) #8
    if (n > 100) {
        m <- n - 100
        data <- rbind(cbind(rep(1, m), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1), runif(m, min = 0, max = 1)), data)
    }
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:8))
    write.table(data, file = paste("data/synthetic-2-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ CORRELATIONS
for (n in SIZES) {
    data <- rep(1, n)
    data <- cbind(data, sort(runif(n, min = 0, max = 1)))
    data <- cbind(data, sort(runif(n, min = 0, max = 1)))
    data <- cbind(data, sort(runif(n, min = 0, max = 1), decreasing = TRUE))
    data <- cbind(data, sort(runif(n, min = 0, max = 1), decreasing = TRUE))
    data <- cbind(data, sort(runif(n, min = 0, max = 1)))
    data <- data.frame(data)
    colnames(data) <- c("class", paste("dimension", 1:5))
    write.table(data, file = paste("data/correlations-", n, ".csv", sep=""), sep = ",", row.names = FALSE)
}

# ============ REALWORLD DATA
library("cluster.datasets")

data(acidosis.patients)
data <- data.frame(acidosis.patients)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-acidosis-patients.csv", sep = ",", row.names = FALSE)

data(all.mammals.milk.1956)
data <- data.frame(all.mammals.milk.1956)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-all-mammals-milk-1956.csv", sep = ",", row.names = FALSE)

data(life.expectancy.1971)
data <- data.frame(life.expectancy.1971)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-life-expectancy-1971.csv", sep = ",", row.names = FALSE)

data(mutation.distances.1967)
data <- data.frame(mutation.distances.1967)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-mutation-distances-1967.csv", sep = ",", row.names = FALSE)

data(rda.meat.fish.fowl.1959)
data <- data.frame(rda.meat.fish.fowl.1959)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-rda-meat-fish-fowl-1959.csv", sep = ",", row.names = FALSE)

data(sample.mammals.milk.1956)
data <- data.frame(sample.mammals.milk.1956)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-sample-mammals-milk-1956.csv", sep = ",", row.names = FALSE)

data(us.south.demographics.1965)
data <- data.frame(us.south.demographics.1965)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-us-south-demographics-1965.csv", sep = ",", row.names = FALSE)

data(mammal.dentition)
data <- data.frame(mammal.dentition)
for (c in colnames(data)) {
    x <- as.numeric(data[, c])
    data[, c] <- (x - min(x)) / (max(x) - min(x))
}
write.table(data, file = "data/realworld-mammal-dentition.csv", sep = ",", row.names = FALSE)


# read in data from github
deck <- read.csv('https://github.com/gumdropsteve/datasets/raw/master/deck.csv')

# filter by row
deck[2,]

# filter by rows
deck[2:5,]

# filter by row value
deck[deck$value > 2, ]

# filter by column
deck[, 2]

# filter by columns
deck[, 2:3]

# filter by row value and column
deck[deck$value > 2, 1]

# filter by row value and columns
deck[deck$value > 2, 1:2]


generate_stats <- function(f, name, table)
{
  res <- list(bigf="", aeronet=name,
               dist=f(table$dist),
               n=f(table$n),
               rmse=f(table$rmse),
               corr=f(table$corr),
               m=f(table$m),
               c=f(table$c),
               r2=f(table$r2),
               e_mean=f(table$e_mean),
               e_sd=f(table$e_sd),
               perc_e_mean=f(table$perc_e_mean),
               perc_e_sd=f(table$perc_e_sd))

  return(res)
}

print_val_tables <- function(table, station_type)
{
  stats1 <- generate_stats(min, "Min", table)
  stats2 <- generate_stats(mean, "Mean", table)
  stats3 <- generate_stats(max, "Max", table)

  if (station_type == "Radiosonde")
  {
    names(stats1)[names(stats1)=="aeronet"] <- "radiosonde"
    names(stats2)[names(stats2)=="aeronet"] <- "radiosonde"
    names(stats3)[names(stats3)=="aeronet"] <- "radiosonde"
  }

  print(names(table))
  print(names(stats1))

  table <- rbind(table, stats1, stats2, stats3)

  # Give new column names
  old_names <- colnames(table)
  colnames(table) <- c("BIGF site", paste(station_type, "site"), "Distance (km)", "$n$", "RMSE", "Correlation", "$m$", "$c$", "$r^2$", "Mean Error", "SD Error", "Mean % Error", "SD % Error")

  # Print
  myxtable(table)
}


overfit.graph <- function(analysis.dir, datname, export) {
    fname <- sprintf('%s/%s.csv', analysis.dir, datname)
    pdfname <- sprintf('%s/%s.pdf', analysis.dir, datname)
    testdf <- read.csv(fname, header=TRUE)
    y <- testdf[,'F.Measure']
    dps <- length(y)
    x <- testdf[,'Train']
    incy <- sapply(1:dps, function(i) {all(y[1:i] == cummax(y[1:i]))})
    elbow <- match(c(FALSE), incy)
    if (export) pdf(pdfname)
    par(new=FALSE)
    plot(x, y, ylab='F-Measure', xlab='Training Instances')
    lser <- y~x
    lines(lser, col='blue', lwd=1)
    eblser <- y[(elbow-1):elbow]~x[(elbow-1):elbow]
    lines(eblser, col='red', lwd=3)
    text(x, y, labels=x, cex=0.7, adj=c(0.5, -1), col="black")
    par(new=TRUE)
    if (export) {
        print(sprintf('writing pdf file: %s', pdfname))
        dev.off()
    }
}

#adir <- sprintf('%s/Desktop', Sys.getenv('HOME'))
adir <- '../../doc/results'
dname <- 'speech-act-J48-train-test-series'
overfit.graph(adir, dname, TRUE)


library(tidyverse)
pizza_names <-c(
    "Margherita",
    "Salami",
    "Funghi",
    "Prosciutto",
    "Spinaci",
    "Tonno",
    "Vegetaria"
    )

pref <- readr::read_csv("pizza/pizza_preferences.csv")

n <- nrow(pref)
num_pizza <- length(pizza_names)
X <- pref[, -1]

count_fun <- function(X, k, num_pizza) {
  sum(colSums(X == k) * num_pizza:1)
}

count_fun_internal <- function(k) {
  count_fun(X=X, k=k, num_pizza=num_pizza)
}

optimal_sol <- sapply(1:k, count_fun_internal)

optimal_df <- tibble(optimal_sol)
optimal_df <- cbind(optimal_df, pizza_names)

ggplot(optimal_df,
       aes(x = pizza_names,
           y = optimal_sol,
           fill = pizza_names)) +
  geom_bar(stat = "identity") +
  scale_fill_brewer(palette = "Spectral") +
  xlab("") +
  ylab("") +
  geom_text(
    aes(label = pizza_names),
    angle = 45,
    nudge_y = -10,
    size = 8
  ) +
  theme(
    axis.title.x = element_blank(),
    axis.text.x = element_blank(),
    axis.ticks.x = element_blank(),
    legend.position = "none"
  )


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')
library(rJava)

setwd("/Users/mengmengjiang/all datas/chap4")
library(xlsx)

library(xlsx)
 library(RColorBrewer)

 mycolors<-c("red","blue","darkgreen","yellow3")

 pchc<-c(21,22,23,24)

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12)  #流量

k<-c(0.2,0.3,0.4,0.5) #占空比

Rn<-c(0.845e-3, 0.715e-3, 0.46e-3, 0.305e-3, 0.26e-3, 0.21e-3,0.17e-3,0.15e-3,0.13e-3,0.12e-3,0.105e-3,0.09e-3,0.08e-3) #针头内径
Rnn<-1000*Rn

#对应于14G，15G，18G，20G，21G，22G，23G，24G，25G，26G，27G，28G，30G

par(fig=c(0,1,0,1), mar = c(2.5,2.5,1,0.8), oma = c(1,1,1,1),new=FALSE)

plot(Rnn, 1000*(q[1]/(pi*Rn^2)),mgp = c(1.5, 0.5, 0),tck=0.02,
     type="b", xlab=expression(italic(r["n"](mm))), ylab=expression(italic(U["o"](mm/s))), main="", lwd=2, lty=1, col="red",pch=21,cex=0.6,cex.axis=1,cex.lab=1, ylim=c(0,5e-2))

lines(Rnn, 1000*(q[2]/(pi*Rn^2)), type="b",lwd=2, col=mycolors[2], cex=0.6,pch=pchc[2], lty=1)
lines(Rnn, 1000*(q[3]/(pi*Rn^2)), type="b",lwd=2, col=mycolors[3], cex=0.6,pch=pchc[3], lty=1)
lines(Rnn, 1000*(q[4]/(pi*Rn^2)), type="b",lwd=2, col=mycolors[4], cex=0.6,pch=pchc[4], lty=1)

#######
par(fig=c(0.35,0.98,0.3,0.98), new=TRUE)

Rn2<-c(0.12e-3,0.105e-3,0.09e-3,0.08e-3) #针头内径
Rn22<-1000*Rn2

plot(Rn22, 1000*(q[1]/(pi*Rn2^2)), bty="n",cex=0.6,mgp = c(1.5, 0.5, 0),tck=0.02,type="b", xlab="30G\\28G\\27G\\26G(mm)", ylab=expression(italic(U["o"](mm/s))), main="", lwd=2, lty=1, col="red",cex.axis=0.9,cex.lab=0.9, pch=21, ylim=c(0,20e-2))

lines(Rn22, 1000*(q[2]/(pi*Rn2^2)),cex=0.6, type="b",lwd=2, col=mycolors[2], pch=pchc[2], lty=1)
lines(Rn22, 1000*(q[3]/(pi*Rn2^2)),cex=0.6, type="b",lwd=2, col=mycolors[3], pch=pchc[3], lty=1)
lines(Rn22, 1000*(q[4]/(pi*Rn2^2)), cex=0.6,type="b",lwd=2, col=mycolors[4], pch=pchc[4], lty=1)

legend("topright",c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.06, cex=0.9,col=mycolors, pch=pchc,lwd=2, lty=3,bty="n")

#######


ProjDirPath = "C:\\xampp\\htdocs\\Testing\\"

#Loading Necessary Packages for Forecasting
library(quantmod)
library(xts)
library(caret)
library(ggplot2)
library(forecast)

#Loading Stock data CSV File saved as table.csv for stock ticker entered by user
DataPath = paste0(ProjDirPath,"table.csv")
stockData=read.csv(DataPath)

#Ordering and Time Slicing the data monthly
OrderedData = xts(stockData$Close, order.by=as.Date(stockData$Date))
TimeSlicedData = to.yearly(OrderedData)
Open=Op(TimeSlicedData)
FinalData = ts(Open,frequency=2)

#Saving First Plot  into TimeSlice.png
TimeSlicePath = paste0(ProjDirPath,"TimeSlice.png")
png(filename= TimeSlicePath)
plot(FinalData, xlab="Years+1",ylab="Ordered Data")
dev.off()

#Saving Second plot into Trends.png
TrendsPath = paste0(ProjDirPath,"Trends.png")
png(filename= TrendsPath)
plot(decompose(FinalData),xlab="years+1")
dev.off()

TrainData = window(FinalData,start=1,end=5)
TestData = window(FinalData,start=5,end=(7-0.01))

#Saving Fourth plot into MovingAverage.png
MAPath = paste0(ProjDirPath,"MovingAverage.png")
png(filename= MAPath)
plot(TrainData)
lines(ma(TrainData,order=3),col="red")
dev.off()
etss = ets(TrainData,model="MMM")
fcast = forecast(etss)

#Saving Fifth Plot into ExpMovAvg.png
EMAPath = paste0(ProjDirPath,"ExpMovAvg.png")
png(filename=EMAPath)
plot(fcast)
lines(TestData,col="red")
dev.off()


library(ggplot2)
library(ggthemes)
library(scales)

fil <- c("house", "ukf", "cut4", "cut6", "cut8")
filter <- c("HOUSE", "UKF", "CUT-4", "CUT-6", "CUT-8")

dis <- c("gauss", "pearson")
dist <- c("Gaussian Distributions", "Pearson Type IV Distributions")

steps <- 6001
trials <- 100

Err <- c()
Filter <- c()
Dist <- c()

for (i in 1:2) {
    Dist <- c(Dist, rep(dist[i], 5*steps*trials))
    for (j in 1:5) {
        Filter <- c(Filter, rep(filter[j], steps*trials))
        file  <- paste("out/", fil[j], "_err_", dis[i], ".csv", sep="")
        table <- as.matrix(read.csv(file))
        err <- sqrt(rowSums(table[,1:3]^2))
        Err <- c(Err, err)
    }
}

data <- data.frame(Err, Filter, Dist)

data$Filter <- factor(data$Filter, levels=filter)

colors <- c("#cc3311", "#0077bb", "#ee7733", "#009988", "#ee3377")
dashes <- c("solid", "dotted", "dotdash", "longdash", "twodash")

ggplot(data, aes(x=Filter, y=Err, fill=Filter)) +
    scale_fill_manual(values=colors) +
    geom_violin(trim=FALSE) +
    geom_boxplot(width=0.1, outlier.shape=NA, fill="white") +
    theme_bw(base_size = 9) +
    theme(panel.grid.major = element_line(),
          legend.position = "none") +
    facet_grid(cols=vars(Dist),
        scales="free_y", switch="y", shrink=FALSE) +
    xlab(NULL) + ylab("Angular Velocity Error (rad/s)")

ggsave("rb_err.eps", width=6, height=3, units="in")


library(ssPopModel)
library(gplots)

#John
path.to.data <- "~/ssPopModel_sensitivity_test/ssPopModel_sensitivity_test_data"
path.to.git.repository <- "~/ssPopModel_sensitivity_test"
setwd(path.to.git.repository)

## MERGE MODEL OUTPUT (dt)
list.output <- list.files("output", "size",full.names=T)
DF <- NULL

for(path.distribution in list.output){
    #path.distribution <- list.output[1]
    print(path.distribution)
    load(path.distribution)
    file.name <- unlist(list(strsplit(basename(path.distribution), "_")))
    origin <- file.name[1]
    size <- as.numeric(file.name[3])
    dt <- as.numeric(file.name[4])

    # if(origin == "biomass"){
    #     params <- model2[,2][[1]]
    #     gr <- model2[,2][[2]]
    # }

    if(origin == "size"){
        params <- model1[,2][[1]]
        gr <- model1[,2][[2]]
    }
    df <- data.frame(origin, size, dt, params,gr=sum(gr,na.rm=T))
    DF <- data.frame(rbind(DF, df))
}

# A few of the outputs were from old runs, this gets rid of them
DF <- na.omit(DF)
# # Some of the GR's came out negative
# DF <- DF[(DF$gr >= 0),]

# Building the matrix to plot
# GR

# Get the number of unique size classes and dt's
size <- sort(unique(DF$size))
dt <- sort(unique(DF$dt))

# this function creates a matrix from the DF table given
# the column index
create.matrix <- function(DF, index) {
    # create the name of the matrix
    parameter <- colnames(DF)[index]
    name <- paste0(parameter, ".matrix")
    # create the empty matrix
    matrix <- matrix(,nrow = length(dt), ncol= length(size))
    index = 1
    # fill in the matrix
    for (i in c(1:length(size))) {
        for (j in c(1:length(dt))) {
            # makes negative entires 0
            if (DF[[parameter]][index] < 0) {
                matrix[j,i] <- 0
            }
            else {
                matrix[j,i] <- DF[[parameter]][index]
            }
            index <- index + 1
        }
    }
    rownames(matrix) <- dt
    colnames(matrix) <- size

    return (matrix)
}

# creates a matrix for each parameter
for (i in c(4:9)) {
    matrix <- create.matrix(DF, i)
    name <- paste0(colnames(DF)[i], ".matrix")
    # rownames(matrix) <- dt
    # colnames(matrix) <- size
    assign(name, matrix)
}

par(mfrow=c(3,2),pty='m')
image(gmax.matrix, xlab="dt", ylab="size")
image(dmax.matrix)
image(b.matrix)
image(E_star.matrix)
image(resnorm.matrix)
image(gr.matrix)


# Day 5: Hydrothermal Venture

get_day5_input_path <- function() {
    paste(getwd(), "/2021/Day 5/Day5_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day5_input_path())

    plot <- matrix(0, ncol = 1000, nrow = 1000)
    for (i in seq_len(length(readings))) {
        reading <- stringr::str_replace(readings[i], " -> ", ",")

        points <- matrix(unlist(strsplit(reading, ",")),
                        ncol = 2, byrow = TRUE)
        if (points[1, 1] == points [2, 1]) {
            x <- strtoi(points[1, 1])
            y1 <- strtoi(points[1, 2])
            y2 <- strtoi(points[2, 2])
            for (i in y1:y2) {
                # Add 1 to each index because 1-base :P
                plot[x + 1, i + 1] <- plot[x + 1, i + 1] + 1
            }
        } else if (points[1, 2] == points[2, 2]) {
            y <- strtoi(points[1, 2])
            x1 <- strtoi(points[1, 1])
            x2 <- strtoi(points[2, 1])
            for (i in x1:x2) {
                # Add 1 to each index because 1-base :P
                plot[i + 1, y + 1] <- plot[i + 1, y + 1] + 1
            }
        }
    }
    print(sum(plot > 1))
}

part2 <- function() {
    readings <- readLines(get_day5_input_path())

    plot <- matrix(0, ncol = 1000, nrow = 1000)
    for (i in seq_len(length(readings))) {
        reading <- stringr::str_replace(readings[i], " -> ", ",")

        points <- matrix(unlist(strsplit(reading, ",")),
                        ncol = 2, byrow = TRUE)
        if (points[1, 1] == points [2, 1]) {
            x <- strtoi(points[1, 1])
            y1 <- strtoi(points[1, 2])
            y2 <- strtoi(points[2, 2])
            for (i in y1:y2) {
                # Add 1 to each index because 1-base :P
                plot[x + 1, i + 1] <- plot[x + 1, i + 1] + 1
            }
        } else if (points[1, 2] == points[2, 2]) {
            y <- strtoi(points[1, 2])
            x1 <- strtoi(points[1, 1])
            x2 <- strtoi(points[2, 1])
            for (i in x1:x2) {
                # Add 1 to each index because 1-base :P
                plot[i + 1, y + 1] <- plot[i + 1, y + 1] + 1
            }
        } else {
            x1 <- strtoi(points[1, 1])
            x2 <- strtoi(points[2, 1])
            y1 <- strtoi(points[1, 2])
            y2 <- strtoi(points[2, 2])
            x_range <- x1:x2
            y_range <- y1:y2
            for (i in seq_len(length(x_range))) {
                # Add 1 to each index because 1-base :P
                plot[x_range[i] + 1, y_range[i] + 1] <-
                    plot[x_range[i] + 1, y_range[i] + 1] + 1
            }
        }
    }
    print(sum(plot > 1))
}

part1()
part2()


library(TSP, lib.loc = "~/R/local-packages/")

coordinates <- read.csv("djibouti.csv", sep=";", header=FALSE)
colnames(coordinates) <- c("X", "Y")

etsp <- ETSP(coordinates)
tour <- solve_TSP(etsp, method="nn", start=1)

write("--RESULTADO DA BIBLIOTECA 'TSP' DO R--", file = "r-tsp-results.txt", append = FALSE)
write("--CAMINHO ENCONTRADO--", file = "r-tsp-results.txt", append = TRUE)
write(as.integer(tour), sep = "-", file = "r-tsp-results.txt", append = TRUE, ncolumns = 100)
write("--CUSTO--", file = "r-tsp-results.txt", append = TRUE)
write(tour_length(tour), file = "r-tsp-results.txt", append = TRUE)


#--------------------------------------------------------------------------------
# Name:         myfunctions_CA.r
# Purpose:      Modules (functions) called by the main script
# Author:       Francesco Tonini
# Email:        ftonini84@gmail.com
# Created:      09/20/2013
# Copyright:    (c) 2013 by Francesco Tonini
# License:    	GNU General Public License (GPL)
# Software:     Tested successfully using R version 3.0.2 (http://www.r-project.org/)
#-----------------------------------------------------------------------------------------

habitat.survival <- function(a, z){

  out <- list()
  w <- habitat_block[] == 1
  z[w] <- 0

  out$rr <- z
  out$cl <- sapply(rasterToPoints(z)[,3], FUN=list)
  out$age <- mapply(FUN=function(x,y){if(x == 0) y <- NULL; return(list(y))}, out$cl, a)

  return(out)

}

max.age_fun <- function(x){

  if (!is.null(x) & any(x > 20)) {
    x <- x[-which(x > MaxAge)]
    if(length(x) == 0) x <- NULL
  }else{x}

  return(x)
}

alates.gen <- function(x, scenario='baseline'){

  if (scenario == 'baseline'){

    z <- ifelse(x < ColAge_swarmers, 0, 100000 * Survival)
    z <- ifelse(x >= ColAge_swarmers & x < 10, 1000 * Survival, z)
    z <- ifelse(x >= 10 & x < 15, 10000 * Survival, z)

  }else if (scenario == 'pessimistic'){

    z <- ifelse(x < ColAge_swarmers, 0, 100000 * Survival)
    z <- ifelse(x >= ColAge_swarmers & x < ColAge_swarmers * 2, 10000 * Survival, z)
    z <- ifelse(x >= ColAge_swarmers * 2 & x < ColAge_swarmers * 3, 50000 * Survival, z)

  }

  return(z)
}

newCol.gen <- function(x, tab){
  if (!is.na(x) & x > 1){
    idx <- sample(1:1000, 1)
    int <- findInterval(x, tab[,1])
    sub <- tab[(int - 1000 + 1):int,3]
    x <- sub[idx]
  }else{x <- 0}
  return(x)
}

newCol.addAge <- function(l1,l2,l3){

  out <- list()

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

    if(l3[[i]] == 0) next
    if(l2[[i]] < maxdensity) {
      if (l2[[i]] + l3[[i]] > maxdensity) {
        l1[[i]] <- append(l1[[i]], rep(0, maxdensity - l2[[i]]))
        l2[[i]] <- length(l1[[i]])
      }else{
        l1[[i]] <- append(l1[[i]], rep(0, l3[[i]]))
        l2[[i]] <- length(l1[[i]])
      }
    }

  }

  out$age <- l1
  out$cl <- l2

  return(out)

}

generate.Kernel <- function(x, d, FUN, alpha){

  rs <- res(x)

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  r[ceiling(ny/2), ceiling(nx/2)] <- 1

  dist <- as.matrix(distance(r))

  if (FUN == 'exp'){
    c <- 1
    m <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dist/alpha)^c  )
  }else if (FUN == 'gauss'){
    c <- 2
    m <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dist/alpha)^c  )
  }

  #sum of weights should add up to 1
  m/sum(m)

}


  plot.freq.distribution.prior.posterior = function( prior, posterior, legendadd=FALSE, br=75, xrange ) {

    qnt =  c(0.005, 0.995) # quants
    addr = c(0.9, 1.1)  # additional range

    # prior = NULL; prior$scale=1; prior$shape=1; prior$class="gamma"
    if ( prior$class=="none" ) {
      if(missing(xrange))xrange = range( posterior, prior$max, prior$min, na.rm=T )
      xval = seq( xrange[1], xrange[2], length=500 )
      postdat = hist( posterior, breaks=br, plot=FALSE )
      yrange = range( 0, postdat$density, na.rm=T ) * 1.02
      hist( posterior, freq=FALSE, breaks=br, xlim=xrange, ylim=yrange, main="", xlab="", ylab="Density", col="lightgray", border="gray")
      if (legendadd) legend( "topright", bty="n", legend=paste( c( "Prior  ")), lwd=c(1), col=c( "red" ), lty=c("solid") )
      return()
    }

    if ( prior$class == "uniform" ) {
      if(missing(xrange))xrange = range( posterior, prior$max, prior$min, na.rm=T )
      xval = seq( xrange[1], xrange[2], length=500 )
      dprior = dunif( xval, min=prior$min, max=prior$max )
    }

    if ( prior$class == "normal" ) {
      if(missing(xrange))xrange = quantile( posterior, qnt, na.rm=T )* addr
      xval = seq( xrange[1], xrange[2], length=500 )
      dprior = dnorm( xval, mean=prior$mean, sd=prior$sd )
    }

    if ( prior$class == "lognormal" ) {
      if(missing(xrange))xrange = quantile( posterior, qnt, na.rm=T ) * addr
      xrange[1] = min(posterior)
      xval =  exp( seq( log(xrange[1]), log(xrange[2]), length=500 ) )
      xrange[1] = 0
      dprior =  dlnorm( xval, meanlog=prior$meanlog, sdlog=prior$sdlog )
    }

    if ( prior$class == "beta" ) {
      if(missing(xrange))xrange = c( -0.1, 1.1 )
      xval = seq( 0, 1, length=500 )
      dprior = dbeta( xval, prior$a, prior$b )
    }

    if ( prior$class == "gamma" ) {
      if(missing(xrange))xrange = range( posterior, na.rm=T ) * addr
      xval = seq( xrange[1], xrange[2], length=500 )
      if ( exists( "rate", prior ) ) { prior$scale = 1/prior$rate }
      dprior = dgamma( xval, shape=prior$shape, scale=prior$scale )
    }

    postdat = hist( posterior, breaks=br, plot=FALSE )
    #dprior = dprior / sum( dprior) * sum(postdat$density)
    yrange = range( 0, dprior, postdat$density, na.rm=T ) * 1.02

    hist( posterior, freq=FALSE, breaks=br, xlim=xrange, ylim=yrange, main="", xlab="", ylab="Density", col="lightgray", border="gray")
    lines( xval, dprior, col="red", lwd=1, lty="solid" )
    if (legendadd) legend( "topright", bty="n", legend=paste( c( "Prior  ")), lwd=c(1), col=c( "red" ), lty=c("solid") )

  }