library(ggplot2)
library(readxl)

###########load primary data
load("SCDB_2017_01_caseCentered_Citation.Rdata")
load("scdbSalience.rdata")

salience_8_data <- read_excel("CSI-1953-2014.xls") #8 news sources
case_data <-SCDB_2017_01_caseCentered_Citation  #complete data about cases
salience_2_data <- scdbSalience #2 news sources

###########create salience_data and absolute_diff
salience_data <- merge(salience_8_data,salience_2_data[c("caseId","cqSalience")]) #augmented 9 news source salience measure
salience_data$cqSalience <- salience_data$cqSalience * 2 # match cqSalience measure with other news sources
salience_data$CSI <- salience_data$CSI + salience_data$cqSalience #include cqSalience in CSI measurement

maj_min_vote <- subset(case_data, select = c(majVotes, minVotes))
sum <- Reduce(function (x,y) x + y , maj_min_vote) # total votes
diff <- Reduce(function (x,y) x - y , maj_min_vote)# difference in majority and minority votes for a case
abs_diff <- abs(diff)
vote_pattern = data.frame(term=case_data$term, caseId = case_data$caseId, absVoteDifference = abs_diff, totalVotes = sum) #term,caseId,voteDifference,totalVotes

###########final data_frame
total <- merge(vote_pattern,salience_data) #case_data and salience_data
total_8 <- merge(vote_pattern,salience_8_data) #case_data and salience_8_data

dem_years <- c(1937:1952,1961:1968, 1977:1980, 1993:2000, 2009:2015)
years <- c(1953,2010)
years_8 <- c(1953:2014)

total_8_per_yr <- Map(function(x) total_8[total_8$term == x, ],years_8)#spit total_8 to years
CSI_8_per_yr <- unlist(unlist(Map(function(total_8_per_yr) mean(total_8_per_yr$CSI), total_8_per_yr)))#mean CSI_8 per year
abs_diff_8_per_yr<- unlist(unlist(Map(function(total_8_per_yr) mean(total_8_per_yr$absVoteDifference), total_8_per_yr)))#mean absDiff_8 per year

final_8_data <- data.frame(year = years_8 , salience = CSI_8_per_yr, voteRecord = abs_diff_8_per_yr) #final for 8 news sources

###########v
mean_votes = mean(total_8$totalVotes)
total_8$corr_abs_vote_diff <- total_8$absVoteDifference * sqrt(total_8$totalVotes / mean_votes) #correct for difference in totalvotes

###########analysis
sum(total_8$absVoteDifference  > total_8$totalVotes - 1)/length(total_8$absVoteDifference)
cor.test(total_8$absVoteDifference, total_8$CSI)
cor(final_8_data)

###########visualization
# ggplot(data=total_8, aes(corr_abs_vote_diff,fill=CSI))+
#   geom_histogram(bins = 40)
#
# sum(total_8$CSI == 0)
#
# ggplot(data=total_8, aes(x=totalVotes))+
#   geom_histogram()
# theme_bw()
#
# ggplot(data=total_8, aes(x=CSI))+
#   geom_histogram()
#   theme_bw()
#
#   ggplot(data=total_8, aes(x=absVoteDifference))+
#     geom_histogram()
#   theme_bw()
#
#   ggplot() +
#     geom_bar(data=total_8, aes(x=absVoteDifference, color = CSI, fill=CSI))+
#     guides(fill=guide_legend(title="Vote Difference")) +
#     xlab("Salience") + ylab("Number of cases") +
#     ggtitle("Cumulative Vote Difference of Cases by Salience")+
#     theme_bw()
#
#   ggplot() +
#     geom_bar(data=total_8, aes(x=CSI, y=corr_abs_vote_diff, fill=corr_abs_vote_diff),stat = "identity")+
#     guides(fill=guide_legend(title="Voting Pattern")) +
#     xlab("Salience") + ylab("Number of cases") +
#     ggtitle("Cumulative Vote Difference of Cases by Salience")+
#     theme_bw()
#
###visualization slaiency vs vote margin
ggplot() +
  geom_jitter(data=total_8, aes(x=CSI, y = absVoteDifference, color=totalVotes))+
  labs(title="",x="Saliency", y="Vote margin", colour="Total votes")+
  scale_y_continuous(breaks =seq(0,9,1),limits=c(-0.5,9.5)) +
  scale_x_continuous(breaks =seq(0,9,1),limits=c(-0.5,8.5))  +
  theme(
    panel.background = element_rect(fill = "transparent") # bg of the panel
  )

#visulaization incumbent party
ggplot(data=final_8_data, aes(x=year, y=salience, fill=salience)) +
  scale_y_continuous(breaks =seq(0,9,1),limits=c(-0.5,8.5)) +
  scale_x_continuous(breaks =seq(1950,2017,10),limits=c(1950,2017))  +
  geom_line(colour="black", stat="identity")+
  labs(x="Year", y= "Saliency")+
  guides(fill=FALSE)+
  geom_rect(aes(xmin = 1952, xmax = 1961, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1961, xmax = 1968, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 1968, xmax = 1977, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1977, xmax = 1980, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 1980, xmax = 1993, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1993, xmax = 2000, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 2000, xmax = 2009, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 2009, xmax = 2015, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  ggtitle("Average Saliency of Cases per Year")+

  theme_bw()

ggplot(data=final_8_data, aes(x=year, y=voteRecord, fill=voteRecord)) +
  scale_y_continuous(breaks =seq(0,9,1),limits=c(-0.5,8.5)) +
  scale_x_continuous(breaks =seq(1950,2017,10),limits=c(1950,2017))  +
  geom_line(colour="black", stat="identity")+
  labs(x="Year", y= "Vote Margin")+
  guides(fill=FALSE)+
  geom_rect(aes(xmin = 1952, xmax = 1961, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1961, xmax = 1968, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 1968, xmax = 1977, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1977, xmax = 1980, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 1980, xmax = 1993, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1993, xmax = 2000, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 2000, xmax = 2009, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 2009, xmax = 2015, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  ggtitle("Average Vote margin of Cases per Year")+
  theme_bw()

library(reshape2)
final_8_data.long<-melt(final_8_data,id.vars="year")

ggplot(data=final_8_data.long, aes(year,value , fill=variable)) +
  scale_y_continuous(breaks =seq(0,9,1),limits=c(-0.5,8.5)) +
  scale_x_continuous(breaks =seq(1950,2017,10),limits=c(1950,2017))  +
  geom_line(colour="black", stat="identity")+
  labs(x="Year", y= "Measure")+
  geom_rect(aes(xmin = 1952, xmax = 1961, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1961, xmax = 1968, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 1968, xmax = 1977, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1977, xmax = 1980, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 1980, xmax = 1993, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 1993, xmax = 2000, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  geom_rect(aes(xmin = 2000, xmax = 2009, ymin = -0, ymax = Inf),
            fill = "red", alpha = 0.002)+
  geom_rect(aes(xmin = 2009, xmax = 2015, ymin = -0, ymax = Inf),
            fill = "blue", alpha = 0.002)+
  ggtitle("Average vote margin and salience of Cases per Year")+
  theme_bw()


# Read GHCNDEX TXx temperature data (max daily max by month)
require(data.table)
require(reshape2)

# Read in TXx 1986-2005
tempsarray <- fread('data_dl/ghcndex/RawData_GHCNDEX_TXx_1986-2005_ANN_from-90to90_from-180to180.txt')
setnames(tempsarray, 1:4, c('lat', 'lon', 'year', 'txx'))

# Set -99 to NA
tempsarray[txx< -99, txx := NA]

# Check
tempsarray[,hist(txx)]

# function to find the max in a time-series, removing NA. Returns NA if no non-missing values
maxna <- function(x) {
	if(any(!is.na(x))) return(max(x, na.rm=TRUE))
	else return(as.numeric(NA))
}

# Calculate max by grid cell
txxdt <- tempsarray[,.(txx = maxna(txx)), by=.(lat, lon)]

# reorder lon so 0-360
txxdt[lon<0, lon := lon + 360]

# calculate grid centers (not sure what to do with lat, since goes -90 to 90)
txxdt[,longrd := lon + 1.25]

# Reshape so lat x lon
txxmelt <- melt(txxdt, na.rm=FALSE, value.name='txx', id.vars=c('lat', 'lon', 'longrd'))
ghcntxx <- acast(txxmelt, lat ~ longrd, value.var='txx')
	dim(ghcntxx)
	dimnames(ghcntxx)

	image(ghcntxx)

# Flip so lat is 90 to -90
ghcntxx <- ghcntxx[dim(ghcntxx)[1]:1,]

	image(ghcntxx)

# Write out
save(ghcntxx, file='temp/ghcndex_txx.rdata')


#--------------------------------------------------------------
#--------------------------------------------------------------
library(rstudioapi) # We load this libary in order to use the below command to set the working directory to the file --> path
setwd(dirname(getActiveDocumentContext()$path))

#### PART 1: Introduction to data on weather recorded in on station

#--------------------------------------------------------------
#--------------------------------------------------------------
library(readxl)

#weather <-data.frame(read_excel("weather.xlsx",sheet="02", skip = 0)) # if your data is recorded in excel file

#read from csv file
weather <- data.frame(read.csv("weather.csv",sep=";",stringsAsFactors=FALSE))
str(weather)
library(dplyr)
glimpse(weather)

#--------------------------------------------------------------
#--------------------------------------------------------------
#### PART 2: Data Wrangling
#--------------------------------------------------------------
#--------------------------------------------------------------

dim(weather) # Explore the dimension of data

names(weather) # see name of variables (columns)

head(weather) # view the first 10 rows of the data

str(weather) # see the type of each variable

# Check missing data
sum(is.na(weather))

# check number of observations
nrow(weather)
sum(complete.cases(weather))

nrow(weather) == sum(complete.cases(weather))

#############        CREATE FACTORS
# Variables can be convertted into Factors type by simply using as.factor() function. THis function is a function of factor() functional family. When using this function, R will arrange automatically based on alphabetic order if the data is STRING type.

class(weather$season) # check the class type for season variables
summary(weather$season)

weather$season <- factor(weather$season, levels = c("Spring","Summer","Autumn","Winter"))

class(weather$season) # now we have this variable as factor types instead of character type.
summary(weather$season)

#similarly we us as.factor() to convert data type for other columns.
weather$day <- as.factor(weather$day)
weather$month <- as.factor(weather$month)
weather$dir.wind <- as.factor(weather$dir.wind)

#we check our data again
str(weather)

# Examine and correct variables concerning windspeed

# we note that there are several ways in the world to categorize wind directions, 8, 16 or 32. SO we need to check which category they were recorded. Is this 16 directions or more or less.

length(unique(weather$dir.wind))
#https://www.pinterest.com/pin/606226799819409300/

# We count total numbers of days for each directions.
table(weather$dir.wind)
#
rel <- round(prop.table(table(weather$dir.wind))*100,1)
rel

# We arrange this variable
sort(rel,decreasing = TRUE)

# We now can convert 16 wind directions to 8 directions
weather$dir.wind.8 <- weather$dir.wind

weather$dir.wind.8 <- ifelse(weather$dir.wind %in%  c("NNE","ENE"),"NE",as.character(weather$dir.wind.8))

weather$dir.wind.8 <- ifelse(weather$dir.wind %in% c("NNW","WNW"),"NW",as.character(weather$dir.wind.8))

weather$dir.wind.8 <- ifelse(weather$dir.wind %in% c("WSW","SSW"),"SW",as.character(weather$dir.wind.8))

weather$dir.wind.8 <- ifelse(weather$dir.wind %in% c("ESE","SSE"),"SE",as.character(weather$dir.wind.8))

weather$dir.wind.8 <- factor(weather$dir.wind.8,levels = c("N","NE","E","SE","S","SW","W","NW"))

# We check again if now we have 8 directions
table(weather$dir.wind.8)
length(unique(weather$dir.wind.8))

# We create a proportion table for wind direction and season
round(prop.table(table(weather$dir.wind.8,weather$season),margin = 2)*100,1)

##### CHANGE DATA

first.day <- "2021-01-01"
class(first.day)
first.day <- as.Date(first.day)
class(first.day)

weather$date  <- first.day + weather$day.count - 1 # create a formulate to modify date

##### ROUNDING HOURS

# In R, working with date and time is quite hard so it requires patient.

### for low temperature
l.temp.time.date <- as.POSIXlt(paste(weather$date,weather$l.temp.time)) # declare new variable
head(l.temp.time.date)
l.temp.time.date <- round(l.temp.time.date,"hours")# rounding to the nearest hours
head(l.temp.time.date)
attributes(l.temp.time.date) # check the attribute
weather$l.temp.hour <- l.temp.time.date$hour # take out only hours
head(weather$l.temp.hour) #
weather$l.temp.hour <- as.factor(weather$l.temp.hour) # change it to factor
head(weather$l.temp.hour)

### for high temperature

h.temp.time.date <- as.POSIXlt(paste(weather$date,weather$h.temp.time))
head(h.temp.time.date)
h.temp.time.date <- round(h.temp.time.date,"hours")#
head(h.temp.time.date)
attributes(h.temp.time.date) #
weather$h.temp.hour <- h.temp.time.date$hour #
head(weather$h.temp.hour) #
weather$h.temp.hour <- as.factor(weather$h.temp.hour) #
head(weather$h.temp.hour)

gust.wind.time.date <- as.POSIXlt(paste(weather$date,weather$gust.wind.time))
head(gust.wind.time.date)
gust.wind.time.date <- round(gust.wind.time.date,"hours")#
head(gust.wind.time.date)
attributes(gust.wind.time.date) #
weather$gust.wind.hour <- gust.wind.time.date$hour #
head(weather$gust.wind.hour) #
weather$gust.wind.hour <- as.factor(weather$gust.wind.hour) #

head(weather$gust.wind.hour)

str(weather) #

## Note

# we see from the above code that data cleaning is a must before we analyze them. In fact, when we have tidydata, pivoting, visualization and analyze them will be done in less time. Efforst in cleaning data take most of the time of people.

# We note that R is quite powerful to visualize and modelling. but R is not the only language used to clean data, alternatively, you can use different way to do data cleaning.

### You can use excel with several useful function to do the same jobs, especially when data is small.

### Using other language like Python

### Using several cooked libraries for cleaning such as lubricate library.

#--------------------------------------------------------------
#--------------------------------------------------------------
#### PART4 : Visualization with ggplot2
#--------------------------------------------------------------

# This libaray was created by Hadley Wickham based on graphical method developed by Leland Wilkison. This defines a standard grammar used to create graphs. Since 2014, ggplots is the most downloadable libaries in R.

#GGplot2 works based on the concept of Layering. Each part of the graph is visualized using a specific layer such as layer for coordinate, layer for size, layer for lable, layer for specific type of graph..

# Ok then how can we practice, now if we want to visualize the relationship between low and high temperature, change color according to season and choose size, how can we do.

# Steps in using ggplot2

## A graph is created using ggplot() function, and right after this, we can add layer.

#### ggplot(data = dataframe, aes(x = var1, y= var2, colour = var3, size = var4))

### geom_xxx()   ---> this layer is added after ggplot() and used to create type of graph such as boxplot, histogram, etc. Note that if we do not specify anything inside the bracket, R will create a default graph, but if we want to decorate, we can declare inside the bracket what attributes we want for our graph. When we add attribute, new layer will be added on top of the previous declared attribute. that is how it works.

library(ggplot2)
ggplot(data = weather, aes(x = l.temp, y= h.temp, colour = season)) +
        geom_point()
#--> create graph and type of graph

ggplot(data = weather, aes(x = l.temp, y= h.temp, colour = season)) +
         geom_point(aes(colour=dir.wind))#  --> same as before but add in some decoration

ggplot(data = weather, aes(x = h.temp, y= l.temp)) +
         geom_point(colour = "blue")  #---> change for single colour

ggplot(data = weather, aes(x = l.temp, y= h.temp)) +
         geom_point(aes(size=rain), colour = "blue")  #--> change the size of dot

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

ggplot(weather,aes(x = date,y = ave.temp))+
  geom_point(colour = "green")+
  geom_smooth(colour = "red",size = 1)+
  scale_y_continuous(limits = c(5,30), breaks = seq(5,30,5))+
  labs(
    x = "Date",
    y = "Average Temperature (C)"
  )

ggplot(weather,aes(x = date,y = ave.temp)) +
  geom_point(aes(colour = ave.temp)) +
  scale_colour_gradient2(low = "blue", mid = "green" , high = "red", midpoint = 16) +
  geom_smooth(color = "red",size = 1) +
  scale_y_continuous(limits = c(5,30), breaks = seq(5,30,5))

### Analyze temperature per seasons

ggplot(weather,aes(x = ave.temp+10, colour = season)) +
  geom_density() +
  scale_x_continuous(limits = c(5,30), breaks = seq(5,30,5))+
  xlab("Average Temperature () ºC )") +  ylab ("Prob/Density")+
  labs(title = "Distribution of Temp/Season") +
  scale_color_manual(name = "Seasons",labels = c("Spring", "Summer", "Autumn", "Winter"), values = c("red", "blue","green","gray"))

#### Monthly Temperature - Using different type of graphs

ggplot(weather,aes(x = month, y = ave.temp+10)) +
  geom_violin(fill = "orange") +
  geom_point(aes(size = rain), colour = "blue", position = "jitter") +
  ggtitle ("Monthly Distribution of Temperature") +
  xlab("Month") +  ylab ("Average Temperature ( ºC )")+
  labs(size="Rain")

## Analyze the relationship between high and low temp.

ggplot(weather,aes(x = l.temp, y = h.temp)) +
  geom_point(colour = "firebrick", alpha = 0.3) +
  geom_smooth(aes(colour = season),se= F, size = 1.1) +
   xlab("Low Temp. ( ºC )") +  ylab ("High Temp ( ºC )")+
  labs(title = "Low Temp. and High Temp. relations") +
  scale_color_manual(name = "Seasons",labels = c("Spring", "Summer", "Autumn", "Winter"), values = c("red", "blue","green","gray"))

## Distribution of low and high temp. in daily hoursl.

library(reshape2) # Use this libarary to change from wide to long table

temperatures <- weather[c("day.count","h.temp.hour","l.temp.hour")] # only select necessary variables (day and temp) and set new name for this table.
head(temperatures)
head(temperatures)
tail(temperatures)

temperatures <- melt(temperatures,id.vars = "day.count",
                     variable.name = "l.h.temp", value.name = "hour")

temperatures$hour <- factor(temperatures$hour,levels=0:23) # Necessary to arrange the order

ggplot(temperatures) +
  geom_bar(aes(x = hour, fill = l.h.temp)) +
  scale_fill_discrete(name= "", labels = c("High","Low")) +
  scale_y_continuous(limits = c(0,100)) +
  ggtitle ("Daily templ. low and high") +
  xlab("Hours") +  ylab ("Freq")

# what can we see from this graph

#--------------------------------------------------------------
#--------------------------------------------------------------
#### PART 4: Using EDA and ggplot2
#--------------------------------------------------------------
#--------------------------------------------------------------

# In this section, we will do visualization and table pivoting to understand more on our data. but first let try to make some questions

#question 1: Why we need to explore --> because we want to know how to use some variables to predict the probability of raining that can happen in anytime. We can understand that the rain is the dependent variable or output. The other variables are then input and independent variables, these variables are also name explainable variables or predictive variables.

# EDA is method to visualize data for us to understand the data

# Step 1: Analyze dependent variables (continous variable) --> we need to draw the frequency graph of this variable, and also plot again time to see the tendency. Will this variable be transformed into binary variable? or transform into multiple factors such as no rain, litle rain, moderate, heavy rain???

# Step 2: --> finding relationshop among input and out put variables --> is it linear or non-linear.

# Step 3: Repeat the same steps but for other variables in the tables.

# Step 4 4: Find the correlation or relationship between output and inputs in factor types. How is outliners and how to deal with it.

# Let start

# Output variables are RAIN

#
ggplot(weather, aes(date,rain)) +
  geom_point(aes(colour = rain)) +
  geom_smooth(colour = "blue", size = 1) +
  scale_colour_gradient2(low = "green", mid = "orange",high = "red", midpoint = 20) +
  scale_y_continuous(breaks = seq(0,80,20))

# Histogram

ggplot(weather,aes(rain)) +
  geom_histogram(binwidth = 1,colour = "blue", fill = "darkgrey") +
  scale_x_continuous(breaks = seq(0,80,5)) +
  scale_y_continuous(breaks = seq(0,225,25))

summary(weather$rain) # độ lệch sang phải rất cao
summary(subset(weather, rain > 0)$rain) # độ lệch vẫn còn cao

#Boxplot

ggplot(weather,aes(rain)) +
  geom_boxplot()

ggplot(weather, aes(x="", y=rain)) +
  geom_boxplot(fill="red", alpha=0.2)+
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  theme(legend.position="none") +
  scale_fill_brewer(palette="Set1")

library(dplyr)

weather %>% filter(rain >0)

ggplot(weather %>% filter(rain >0), aes(x="", y=rain)) +
  geom_boxplot(fill="red", alpha=0.2)+
  stat_summary(fun=mean, geom="point", shape=20, size=4, color="red", fill="red")+
  theme(legend.position="none") +
  scale_fill_brewer(palette="Set1")

library(e1071) # Use this to estimate the srewness
skewness(weather$rain)
skewness(subset(weather, rain >0)$rain)

# Create binary variable

nrow(subset(weather, rain == 0)) # check no. of days without rain

nrow(subset(weather, rain <1 & rain >0)) # check no. of days with little rain

weather$rained <- ifelse(weather$rain >= 1, "Rain", "No Rain") # biến mới

table(rained = weather$rained) #

prop.table(table(rained = weather$rained)) #

# Continous variables

ggplot(weather, aes(season,rain)) +
  geom_jitter(aes(colour=rain), position = position_jitter(width = 0.2)) +
  scale_colour_gradient2(low = "blue", mid = "red",high = "black", midpoint = 30) +
  scale_y_continuous(breaks = seq(0,80,20))

# Quick estimate the rain per season
tapply(weather$rain,weather$season,summary)

# Using binary

#
ggplot(weather,aes(season)) +
  geom_bar(aes(fill = rained), position = "fill") +
  geom_hline(aes(yintercept = prop.table(table(weather$rained))["No"]),
             colour = "blue",linetype = "dashed", size = 1) +
  annotate("text", x = 1, y = 0.65, label = "yr. w/o = 0.60", colour = "blue")

round(prop.table(table(season = weather$season, rained= weather$rained),1),2)

#

weather.num <- weather[c("rain","l.temp","h.temp","ave.temp","ave.wind","gust.wind", "l.temp.hour","h.temp.hour","gust.wind.hour")]

weather.num$l.temp.hour <- as.numeric(weather.num$l.temp.hour)
weather.num$h.temp.hour <- as.numeric(weather.num$h.temp.hour)
weather.num$gust.wind.hour <- as.numeric(weather.num$gust.wind.hour)

str(weather.num)

round(cor(weather.num),2)

#
round(cor(weather.num),2)[1,] #

weather.num.season <- split(weather.num,weather$season)

class(weather.num.season) #

length(weather.num.season) #

summary(weather.num.season) #

attributes(weather.num.season) #

sapply(weather.num.season, function (x) round(cor(x)["rain",],2))

lapply(weather.num.season, function (x) round(cor(x)["rain",],2))

ggplot(weather,aes(gust.wind,rain)) +
  geom_point(colour = "firebrick") +
  geom_smooth(size = 0.75, se = F) +
  facet_wrap(~season)

quantile(weather$h.temp)

weather$h.temp.quant <- cut(weather$h.temp, breaks = quantile(weather$h.temp),
                            labels = c("Cold","Cool","Warm","Hot"),include.lowest = T)

table(weather$h.temp.quant)

ggplot(weather,aes(rained,gust.wind)) +
  geom_boxplot(aes(colour=rained)) +
  facet_grid(h.temp.quant~season)

#EDA --> Exploratory Data Analysis

#--------------------------------------------------------------
#--------------------------------------------------------------
#### PART 5: Modelling
#--------------------------------------------------------------
#--------------------------------------------------------------

set.seed(123) #

index <- sample(1:nrow(weather),size = 0.7*nrow(weather))

#
train <- weather[index,]

#
test <- weather [-index,]

nrow(train)
nrow(test)

#
group <- rep(NA,365)
group <- ifelse(seq(1,365) %in% index,"Train","Test")

df <- data.frame(date=weather$date,rain=weather$rain,group)

ggplot(df,aes(x = date,y = rain, color = group)) +
  geom_point() +
  scale_color_discrete(name="") +
  theme(legend.position="top")

#

write.csv(train,"weather02-train.csv", row.names = FALSE)
write.csv(test,"weather02-test.csv", row.names = FALSE)

#library(rattle)
#rattle()
## https://gmd.copernicus.org/articles/7/1247/2014/gmd-7-1247-2014.pdf

# Base model
best.guess <- mean(train$rain)
best.guess
# RMSE and MAE value
RMSE.baseline <- sqrt(mean((best.guess-test$rain)^2))

RMSE.baseline

MAE.baseline <- mean(abs(best.guess-test$rain))
MAE.baseline

# Multiple linear regression

#
lin.reg <- lm(log(rain+1) ~ season +  h.temp + ave.temp + ave.wind + gust.wind +
                dir.wind + as.numeric(gust.wind.hour), data = train)

summary(lin.reg)

#
exp(lin.reg$coefficients["gust.wind"])

test.pred.lin <- exp(predict(lin.reg,test))-1

RMSE.lin.reg <- sqrt(mean((test.pred.lin-test$rain)^2))
RMSE.lin.reg

MAE.lin.reg <- mean(abs(test.pred.lin-test$rain))
MAE.lin.reg

## Decision Tree Analysis

library(rpart) #
library(rpart.plot)
library(rattle) #

#rattle()

rt <- rpart(rain ~ month + season + l.temp + h.temp + ave.temp + ave.wind +
              gust.wind + dir.wind + dir.wind.8 + as.numeric(h.temp.hour)+
              as.numeric(l.temp.hour)+ as.numeric(gust.wind.hour), data=train)

rt

rpart.plot(rt)
fancyRpartPlot(rt)

#plot(rt)
#
test.pred.rtree <- predict(rt,test)

RMSE.rtree <- sqrt(mean((test.pred.rtree-test$rain)^2))

RMSE.rtree

MAE.rtree <- mean(abs(test.pred.rtree-test$rain))
MAE.rtree

printcp(rt)

min.xerror <- rt$cptable[which.min(rt$cptable[,"xerror"]),"CP"]
min.xerror

rt.pruned <- prune(rt,cp = min.xerror)

fancyRpartPlot(rt.pruned)

test.pred.rtree.p <- predict(rt.pruned,test)
RMSE.rtree.pruned <- sqrt(mean((test.pred.rtree.p-test$rain)^2))
RMSE.rtree.pruned

MAE.rtree.pruned <- mean(abs(test.pred.rtree.p-test$rain))
MAE.rtree.pruned

### RANDOM FOREST

library(randomForest)

train$h.temp.hour <- as.numeric(train$h.temp.hour)
train$l.temp.hour <- as.numeric(train$l.temp.hour)
train$gust.wind.hour <- as.numeric(train$gust.wind.hour)
test$h.temp.hour <- as.numeric(test$h.temp.hour)
test$l.temp.hour <- as.numeric(test$l.temp.hour)
test$gust.wind.hour <- as.numeric(test$gust.wind.hour)

# For reproducibility; 123 has no particular meaning
# Run this immediately before creating the random forest
set.seed(123)

library(randomForest)

rf <- randomForest(rain ~ month + season + l.temp + h.temp + ave.temp + ave.wind +
                     gust.wind + dir.wind + dir.wind.8 + h.temp.hour + l.temp.hour +
                     gust.wind.hour, data = train, importance = TRUE, ntree=1000)

which.min(rf$mse)

plot(rf)

imp <- as.data.frame(sort(importance(rf)[,1],decreasing = TRUE),optional = T)
names(imp) <- "% Inc MSE"
imp

test.pred.forest <- predict(rf,test)
RMSE.forest <- sqrt(mean((test.pred.forest-test$rain)^2))
RMSE.forest

MAE.forest <- mean(abs(test.pred.forest-test$rain))
MAE.forest

# SUMMARY of all above steps

accuracy <- data.frame(Method = c("Baseline","Linear Regression","Full tree","Pruned tree","Random forest"),
                       RMSE   = c(RMSE.baseline,RMSE.lin.reg,RMSE.rtree,RMSE.rtree.pruned,RMSE.forest),
                       MAE    = c(MAE.baseline,MAE.lin.reg,MAE.rtree,MAE.rtree.pruned,MAE.forest))

accuracy$RMSE <- round(accuracy$RMSE,2)
accuracy$MAE <- round(accuracy$MAE,2)
accuracy

all.predictions <- data.frame(actual = test$rain,
                              baseline = best.guess,
                              linear.regression = test.pred.lin,
                              full.tree = test.pred.rtree,
                              pruned.tree = test.pred.rtree.p,
                              random.forest = test.pred.forest)

head(all.predictions)

library(tidyr) #

all.predictions <- gather(all.predictions,key = model,value = predictions,2:6)

head(all.predictions)

tail (all.predictions)

ggplot(data = all.predictions,aes(x = actual, y = predictions)) +
  geom_point(colour = "blue") +
  geom_abline(intercept = 0, slope = 1, colour = "red") +
  geom_vline(xintercept = 23, colour = "green", linetype = "dashed") +
  facet_wrap(~ model,ncol = 2) +
  coord_cartesian(xlim = c(0,70),ylim = c(0,70)) +
  ggtitle("Predicted vs. Actual, by model")

#--------------------------------------------------------------
#### Continue with Decision Tree Analysis for Categorical variables
#--------------------------------------------------------------

# rename the table

weather_xl <-weather

summary(weather_xl$ave.temp) #
weather_xl$ave.temp.c = cut(weather_xl$ave.temp, breaks = c(-Inf,14,21,Inf), labels = c("cold", "mild", "warm"), include.lowest = TRUE)

summary(weather_xl$rain)
weather_xl$rain.c = cut(weather_xl$rain, breaks = c(-Inf, 25, 50, Inf), labels = c("low", "moderate", "high"), include.lowest = TRUE)

summary(weather_xl$ave.wind)
weather_xl$ave.wind.c = cut(weather_xl$ave.wind, breaks = c(-Inf, 3.5, 5.2, Inf), labels = c("light", "moderate", "strong"), include.lowest =  TRUE)

summary(weather_xl$gust.wind)
weather_xl$gust.wind.c = cut(weather_xl$gust.wind, breaks = c(-Inf, 22.5, 38.6, Inf), labels = c("light", "medium", "strong"), include.lowest =  TRUE)

weather_xl_tree = weather_xl %>%
  select(season, dir.wind, ave.temp.c, rain.c, ave.wind.c, gust.wind.c)
str(weather_xl_tree)

weather_xl_tree = weather_xl_tree %>%
  mutate_if(is.character, as.factor)
str(weather_xl_tree) #ok

names(weather_xl_tree)

num_weather = length(unique(weather_xl_tree$season)) *  length(unique(weather_xl_tree$dir.wind)) * length(unique(weather_xl_tree$ave.temp.c)) * length(unique(weather_xl_tree$ave.wind.c)) * length(unique(weather_xl_tree$rain.c)) * length(unique(weather_xl_tree$gust.wind.c))
num_weather

table(weather_xl_tree$season)
table(weather_xl_tree$dir.wind)
table(weather_xl_tree$ave.temp.c)
table(weather_xl_tree$rain.c)
table(weather_xl_tree$ave.wind.c)
table(weather_xl_tree$gust.wind.c)

library(vtree)

vtree(weather_xl_tree, "season", palette = 6, sortfill= TRUE)
vtree(weather_xl_tree, "dir.wind", palette = 6, sortfill= TRUE) #lưu ý: có nhánh 1%
vtree(weather_xl_tree, "ave.temp.c", palette = 6, sortfill= TRUE)
vtree(weather_xl_tree, "rain.c", palette = 6, sortfill= TRUE)
vtree(weather_xl_tree, "ave.wind.c", palette = 6, sortfill= TRUE)
vtree(weather_xl_tree, "gust.wind.c", palette = 6, sortfill= TRUE)

total = nrow(weather_xl_tree)
table(weather_xl_tree$rain.c)
vtree(weather_xl_tree, c("rain.c"), horiz = FALSE)
h.s = -342/total*log(342/total) -14/total*log(14/total) -9/total*log(9/total)
h.s #

#
table(weather_xl_tree$gust.wind.c)
vtree(weather_xl_tree, c("gust.wind.c"), horiz = FALSE)
h.s = -100/total*log(100/total) -185/total*log(185/total) -80/total*log(80/total)
h.s #

#
table(weather_xl_tree$ave.wind.c)
vtree(weather_xl_tree, c("ave.wind.c"), horiz = FALSE)
h.s = -186/total*log(186/total) -88/total*log(88/total) -91/total*log(91/total)
h.s #

table(weather_xl_tree$dir.wind)

table(weather_xl_tree$ave.temp.c)

table(weather_xl_tree$season)

table(weather_xl_tree$ave.wind.c)

table(weather_xl_tree$gust.wind.c)

control <- rpart.control(minsplit = 2, #
                         minbucket = 1, #
                         maxdepth = 6, #
                         cp = 0.01) #

tree <- rpart(rain.c~ season + ave.temp.c + ave.wind.c +  gust.wind.c + dir.wind , #
              data=weather_xl_tree, #
              parms=list(split='information'),
              control = control,
              method = "class")
tree
rpart.plot(tree, nn=TRUE)

## the end


## Functions for ecological model

date2doy <- function(yr, mo, dy){
  yr <- as.character(yr)
  mo <- as.character(mo)
  dy <- as.character(dy)

  dt <- paste(c(yr,'-',mo,'-',dy), collapse='')
  doy <- strftime(dt, format='%j')
  return(doy)
}

define_global_variables <- function(){

  # Site constants
  PAR2SWIR <<- 0.43 # PAR to shortwave radiation ratio
  STD_MERAD <<- -75.0 # Time zone longitude
  LATI <<- 35.9736 # Site latitude (CHANGE TO MMS)
  LONGI <<- -79.1004 # Site longitude (CHANGE TO MMS)
  hs <<- 20.0 # Screen height
  h2 <<- 16.2 # Default canopy height
  PA <<- 101325.0 # Air pressure in Pa
  CP <<- 1010.0 # Specific heat of air (J kg-1 K-1)
  CA <<- 410.0 # Atmospheric CO2 concentration (ppm)

  # Physical constants
  SO <<- 1367.0 # Solar constant (W m-2)

  # Leaf constants
  alpha_par <<- 0.80
  alpha_nir <<- 0.20
  rho_s <<- 0.10
  x <<- 1.0 # Leaf angle distribution parameter
  omega <<- 1.0 # Clumping index
  m <<- 8.0 # Ball-Berry model slope
  g1_blayer <<- 0.005 # Leaf boundary layer conductance in m/s
  g0 <<- 0.010 # Parameter in Leuning's gs function in mol m-2 s-1

  # Soil constants
  Ksat <<- 0.6 # Saturated conductance (m day-1)
  wilting_p <<- 0.08 # Wilting poit soil water content (unitless)
  porosity <<- 0.54 # Porosity at depth zero (unitless)
  p1 <<- 0.478 # Air entry pressure in meters of water
  p2 <<- 0.186 # Pore size index (unitless)
  p_0 <<- 4000.0 # Porosity decay in m-1
  m_z <<- 0.24 # Saturated conductivity decay parameter (in m-1)
  soil_depth <<- 0.325 # Soil depth in rooting zone

}

canopy_aerodynamic_resistance <- function(u_h, h, h_o){
  h_u <- 2.0
  cn <- 0.002 # wind attenuation coefficient

  # Compute zero plane displacement
  d_o <- 0.7 * h_o

  # Compute the roughness length
  zo_o <- 0.1 * h_o
  u_o <- compute_toc_wind(u_h, h, h_o)
  u_m <- (u_o * exp(cn * (0.5 * h_o)/h_o - 1))
  u_m <- sapply(u_m, function(x) max(x,0))

  if(h<d_o) h <- d_o + 0.0001

  ra <- (log((h_o-d_o)/zo_o)/0.41)^2 / u_m
  ra[u_m==0] <- 9999999

  return(ra)
}

canopy_bwb_stomatal_conductance <- function(psn, Tair, a1, vpda){
  svp <- 610.7 * exp(17.38 * Tair / (239.0+Tair))
  rh <- 1.0 - vpda/svp
  gc <- g0 + a1 * psn * rh/CA

  # convert mol m-2 s-1 to m s-1
  gc <- gc * (22.4 / 1000.0)

  # convert gc (Co2) to gs (H2O)
  gs <- 1.56 * gc

  return(data.frame(gc=gc, gs=gs))
}

compute_bwb_farq_psn <- function(psnp, apar_wm2, Tair, vpda, fstheta, leaftype){
  svp <- 610.7 * exp(17.38 * Tair / (239.0 + Tair))
  rh <- 1.0 - vpda/svp
  apar <- apar_wm2*4.55
  Ca <- CA

  # calculate atmospheric O2 in Pa, assuming 21% O2 by volume
  O2 <- psnp$O2
  Ko <- psnp$Ko

  # Convert Pa to ppm
  Kc <- psnp$Kc * 1e6/PA
  gamma <- psnp$gamma * 1e6/PA

  ppe <- psnp$ppe
  if(leaftype==1){
    Vmax <- psnp$Vmax_sunlit
    Rd <- psnp$Rd_sunlit
  } else {
    Vmax <- psnp$Vmax_shaded
    Rd <- psnp$Rd_shaded
  }

  Jmax <- 2.1 * Vmax

  g1 <- 0.01 + m * rh/Ca
  K <- Kc * (1.0 + O2/Ko)

  # Calculate rubisco-limited assimilation rate
  aa <- Ca*g1 + g1*K - 1.0
  bb <- Ca*g0 + g0*K - Vmax*Ca*g1 + Vmax + Vmax*g1*gamma + Rd*Ca*g1 - Rd + Rd*g1*K
  cc = -Vmax*Ca*g0 + Vmax*gamma*g0 + Rd*Ca*g0 + Rd*K*g0

  det <- bb*bb - 4.0*aa*cc
  Av <- (-bb + sqrt(det)) / (2.0*aa)
  Av[det<0] <- -1.0

  # Calculate RuBP regeneration limited assimilation rate
  aa <- 0.7
  bb <- -Jmax - (apar/ppe)
  cc <- Jmax * apar/ppe
  J <- (-bb - sqrt(bb*bb - 4*aa*cc)) / (2.0/aa)

  aa <- 4.5*Ca*g1 - 4.5 + 10.5*gamma*g1
  bb <- 4.5*Ca*g0 + 10.5*gamma*g0 - J*g1*Ca + J + gamma*g1*J + 4.5*Rd*Ca*g1-4.5*Rd+10.5*gamma*g1*Rd
  cc <- -J*Ca*g0+4.5*Rd*Ca*g0+10.5*gamma*g0*Rd

  det <- bb*bb - 4.0*aa*cc
  Aj <- (-bb+sqrt(det))/(2.0*aa)
  Aj[det<0] <- -1.0

  # Calculate net assimilation rate
  A = pmin(Aj,Av)
  A[Av == -1.0 & Aj == -1.0] <- 0.0
  A[Av == -1.0 & Aj != -1.0] <- Aj[Av == -1.0 & Aj != -1.0]
  A[Aj == -1.0 & Av != -1.0] <- Av[Aj == -1.0 & Av != -1.0]

  return(A)
}

compute_canopy_intercepted_shortwave_rad <- function(par_D, par_d, nir_D, nir_d, lai, Kb, Kd){
  Q_sc_par <- par_D*(exp(-Kb*sqrt(alpha_par)*lai)-exp(-Kb*lai))/2.0
  Q_d_par <- par_d*(1.0-exp(-Kd*sqrt(alpha_par)*lai))/(Kd*sqrt(alpha_par)*lai)
  Q_par_soil <- par_D*exp(-Kb*sqrt(alpha_par)*lai)+par_d*exp(-Kd*sqrt(alpha_par)*lai)
  Q_nir_soil <- nir_D*exp(-Kb*sqrt(alpha_nir)*lai)+nir_d*exp(-Kd*sqrt(alpha_nir)*lai)

  sunlit_apar <- alpha_par*(par_D*Kb+ Q_sc_par + Q_d_par)
  shaded_apar <- alpha_par*(Q_sc_par + Q_d_par)

  Q_sc_nir <- nir_D*(exp(-Kb*sqrt(alpha_nir)*lai)-exp(-Kb*lai))/2.0
  Q_d_nir <- par_d*(1.0-exp(-Kd*sqrt(alpha_par)*lai))/(Kd*sqrt(alpha_par)*lai)

  sunlit_anir <- alpha_nir*(nir_D*Kb+Q_sc_nir+Q_d_nir)
  shaded_anir <- alpha_nir*(Q_sc_nir+Q_d_nir)

  rad <- data.frame(sunlit_apar=sunlit_apar,
              shaded_apar=shaded_apar,
              sunlit_anir=sunlit_anir,
              shaded_anir=shaded_anir)
  return(rad)
}

compute_canopy_net_rad <- function(rad_short, rad_long, toc_rad, sunlit_lai, shaded_lai, Kb, Kd){

  lai <- sunlit_lai + shaded_lai

  Rnet_sunlit <- rad_short$sunlit_apar + rad_short$sunlit_anir +
    rad_long$floor * (1.0 - exp(-Kd*lai)) / (Kd*lai) +
    rad_long$air * (1.0 - exp(-Kd*lai)) / (Kd*lai) +
    -2.0 * rad_long$canopy * (1.0 - exp(-Kd*lai)) / (Kd*lai)

  Rnet_shaded <- rad_short$shaded_apar + rad_short$shaded_anir +
    rad_long$floor * (1.0 - exp(-Kd*lai)) / (Kd*lai) +
    rad_long$air * (1.0 - exp(-Kd*lai)) / (Kd*lai) +
    -2.0 * rad_long$canopy * (1.0 - exp(-Kd*lai)) / (Kd*lai)

  Rnet_floor <- (1.0 - rho_s) * (toc_rad$par_D * exp(-Kb*sqrt(alpha_par)*lai)+
                                  toc_rad$par_d * exp(-Kd*sqrt(alpha_par)*lai)+
                                  toc_rad$nir_D * exp(-Kb*sqrt(alpha_nir)*lai)+
                                  toc_rad$nir_d * exp(-Kd*sqrt(alpha_nir)*lai))+
                                  rad_long$air * exp(-Kd*lai)+
                                  rad_long$canopy * (1.0-exp(-Kd*lai))-
                                  rad_long$floor

  Rnet_canopy <- sunlit_lai*Rnet_sunlit + shaded_lai*Rnet_shaded
  Rnet_stand <- Rnet_canopy + Rnet_floor

  out <- data.frame(Rnet_sunlit = Rnet_sunlit,
                    Rnet_shaded = Rnet_shaded,
                    Rnet_floor = Rnet_floor,
                    Rnet_canopy = Rnet_canopy,
                    Rnet_stand = Rnet_stand)
  return(out)

}

compute_longwave_rad <- function(Tair, Tsoil, vpd, cloud){
  # Compute emitted longwave radiation from the canopy, floor, and air

  N = cloud
  e_s = 610.7 * exp(17.38 * Tair / ( 239.0 + Tair))
  e_a = (e_s-vpd)/100.0

  epsilon_air = 1.24 * (e_a/(Tair+273.13))^(1.0/7.0)
  epsilon_air =(1.0-0.84*N)*epsilon_air + 0.84*N

  Ln_air = epsilon_air*(5.6704e-8) * (Tair+273.13)^4.0
  Ln_canopy = 1.0*(5.6704e-8) * (Tair+273.13)^4.0
  Ln_floor = 0.97*(5.6704e-8) * (Tsoil+273.13)^4.0

  emitted_rad <- data.frame(air=Ln_air, canopy=Ln_canopy, floor=Ln_floor, air_emissivity=epsilon_air)
  return(emitted_rad)

}

compute_potential_exfiltration <- function(Sr, depth_s, K_sat, Ksat_decay, psi_air_entry, pore_size_index, pore_decay, pore0){
  # Estimate mean porosity
  porosity_average <- pore0 * pore_decay * (1.0-exp(-1.0*depth_s/pore_decay))

  # Estimate mean saturated conductivity
  if (Ksat_decay > 0){
    Ksat_average <- Ksat_decay* Ksat *(1.0-exp(-1.0*depth_s/Ksat_decay))
  } else Ksat_average <- Ksat

  S <- max(0,min(Sr,1))

  # Plug everything into the equation for max infiltration
  potential_exfiltration <- S ^ ((1.0 / (2.0*pore_size_index))+2.0) *
                            sqrt((8.0 * porosity_average *
                            Ksat_average * psi_air_entry) /
                            (3.0 * (1.0 + 3.0 * pore_size_index) *
                            (1.0 + 4.0 * pore_size_index)))

  potential_exfiltration = min(0.001, potential_exfiltration)
  pe_wm2 = potential_exfiltration * 1e6 * 597.3 * 4.18 / (24.0*3600.0)
  return(pe_wm2)
}

compute_psn_parameters <- function(t, Kb, L_sunlit, L_shaded){
  # Local static variables
  Kc25 <- 404.0  # (ubar) MM const carboxylase, 25 deg C
  q10Kc <- 2.1 # (DIM) Q_10 for kc
  Ko25 <- 248.0 # (mbar) MM const oxygenase, 25 deg C
  q10Ko <- 1.2 # (DIM) Q_10 for ko
  act25 <- 3.6 # (umol/mgRubisco/min) Rubisco activity
  q10act <- 2.4 # (DIM) Q_10 for Rubisco activity
  Kn <- 0.52 # extinction coefficient for Nitrogen distribution
  cica <- 0.67 # Ci to Ca ratio
  alpha <- 0.10 # quantum yield efficiency

  L <- L_sunlit + L_shaded

  # Calculate atmospheric O2 in Pa, assumes 21% O2 by volume
  O2 <- 0.21 * PA

  # Correct kinetic constants for temperature, and do unit conversions
  Ko <- Ko25 * q10Ko^((t-25.0)/10.0)
  Ko <- Ko * 100.0 # mbar --> Pa

  Kc <- Kc25 * (1.8*q10Kc)^((t-25.0)/10.0) / q10Kc
  Kc[t>15.0] <- Kc25 * q10Kc^((t[t>15.0]-25.0)/10.0)
  act <- act25 * (1.8*q10act)^((t-25.0)/10.0) / q10act
  act[t>15.0] <- act25 * q10act^((t[t>15.0]-25.0)/10.0)

  Kc <- Kc * 0.10 # ubar --> Pa
  act <- act * 1e6/60.0 # umol/mg/min --> umol/kg/s

  # Calculate gamma (Pa), assumes Vomax/Vcmax = 0.21
  gamma <- 0.5 * 0.21 * Kc * O2 / Ko

  # Calculate Vmax from leaf nitrogen data and Rubisco activity
  Vmax25 <- 59.0 # umol/m2leaf/s at the top of the canopy (Lai et al, 2002, PCE, 25:1095-1119)

  Vmax25_canopy <- L * Vmax25 * (1.0 - exp(-L*Kn)) / (Kn*L)
  Vmax25_sunlit <- L * Vmax25 * (1.0 - exp(-Kn-Kb*L)) / (Kn+Kb*L)
  Vmax25_shaded <- (Vmax25_canopy - Vmax25_sunlit) / L_shaded
  Vmax25_sunlit <- Vmax25_sunlit / L_sunlit

  Vmax_sunlit <- Vmax25_sunlit * exp(0.051*(t-25.0))/(1.0+exp(0.205*(t-41.0)))
  Vmax_shaded <- Vmax25_shaded * exp(0.051*(t-25.0))/(1.0+exp(0.205*(t-41.0)))

  Rd_sunlit <- 0.015 * Vmax_sunlit
  Rd_shaded <- 0.015 * Vmax_shaded

  ppe <- 1.0 / (alpha*(4.0*cica*CA+2.0*gamma)/(cica*CA-gamma))

  psn_para <- data.frame(gamma=gamma,
                   Vmax_sunlit=Vmax_sunlit,
                   Vmax_shaded=Vmax_shaded,
                   Ko=Ko,
                   Kc=Kc,
                   O2=O2,
                   Rd_sunlit=Rd_sunlit,
                   Rd_shaded=Rd_shaded,
                   ppe=ppe)

  return(psn_para)
}

compute_soil_surface_resistance <- function(theta){
  gs <- 1.0 / (-83000.0 * theta + 16100.0)
  gs[theta > 0.185] <- 0.001429

  rs <- 1.0 / gs
  return(rs)
}

compute_sun_angles <- function(lat, lon, yr, mo, dt, hr, mi){
  solar_time <- hr + mi/60.0 + (lon-STD_MERAD)/15.0
  hangle <- (12.0-solar_time)*15.0*pi/180.0

  # Compute Julian day
  jday <- as.numeric(mapply(date2doy, yr=yr, mo=mo, dy=dt))

  # Sun declination angle
  declangle <- 23.45 * sin(2.0*pi*(284.0+jday)/365.0) * pi/180.0

  # sin(sun_elevation)
  sinh <- sin(lat*pi/180.0)*sin(declangle)+cos(lat*pi/180.0)*cos(declangle)*cos(hangle)

  zenith <- acos(sinh)
  azimuth <- asin(cos(declangle)*sin(hangle)/cos(pi/2.0-zenith))

  out <- data.frame(jday = jday, zenith = zenith, sun_decl = declangle, hourangle = hangle)
  return(out)
}

compute_toc_down_rad <- function(par, sun_zenith, jday){
  tau_t <- (par/4.55)*(1.0/PAR2SWIR)/(SO*(1.0+0.033*cos(2.0*pi*(jday-10.0)/365.0)))

  # Constants from Weiss & Norman 1985, Eq. 12
  A <- 0.9
  B <- 0.7
  C <- 0.88
  D <- 0.68

  # Cosine of the solar zenith angle
  cos_theta <- cos(sun_zenith)
  cos_theta[cos_theta<0] <- 0

  # Potential visible (V) and NIR (N) radiation at top of atmosphere
  S_V <- 0.473*1367.0*(1.0+0.033*cos(2.0*pi*(jday-10)/365))
  S_N <- 0.527*1367.0*(1.0+0.033*cos(2.0*pi*(jday-10)/365))

  # Potential direct visible on a horizontal surface
  R_DV <- S_V*exp(-0.185/cos_theta)*cos_theta

  # Potential diffuse visible on a horizontal surface
  R_dV <- 0.4*(S_V-R_DV)*cos_theta

  # Total potential visible radiation on a horizontal surface
  R_V <- R_DV + R_dV

  # Absorbed NIR by atmospheric water vapor
  cos_theta_noZero <- cos_theta
  cos_theta_noZero[cos_theta==0] <- 0.0000000000000001 # avoid division by zero
  R_aN <- S_N * 10^(-1.195+0.4459*log10(1.0/cos_theta_noZero)-0.0345*(log10(1.0/cos_theta_noZero)^2.0))

  # Potential direct NIR on a horizontal surface
  R_DN <- (S_N*exp(-0.06/cos_theta)-R_aN)*cos_theta
  R_DN[R_DN<0] <- 0 # Can't have negative direct radiation

  # Potetial diffuse NIR on a horizontal surface
  R_dN <- 0.6*(S_N-R_DN-R_aN)*cos_theta

  # Total potential NIR on a horizontal surface
  R_N <- R_DN + R_dN

  # Ratio of actual total radiation to potential total radiation on the ground
  RATIO <- (par/4.55)*(1.0/PAR2SWIR) / (R_V+R_N)

  # Actual fraction of direct visible radiation
  RATIO[RATIO>A] <- A
  f_DV <- (R_DV/(R_V*0.928)) * (1.0 - ((A-RATIO)/B) ^ (2.0/3.0))
  f_DV[R_V==0] <- 0

  # Actual fraction of direct NIR radiation
  RATIO[RATIO>C] <- C
  f_DN <- (R_DN/R_N) * (1.0 - ((C-RATIO)/D) ^ (2.0/3.0))
  f_DN[R_N==0] <- 0

  rad <- data.frame(par_D = f_DV * par/4.55,
                    par_d = par/4.55 - f_DV * par/4.55,
                    nir_D = f_DN * (par/4.55) * ((1-PAR2SWIR)/PAR2SWIR),
                    nir_d = (par/4.55) * ((1-PAR2SWIR)/PAR2SWIR) - f_DN * (par/4.55) * ((1-PAR2SWIR)/PAR2SWIR),
                    cloud = max(1.0-tau_t/0.7, 0))

  return(rad)

}

compute_toc_wind <- function(u_h, h, z){
  # Returns wind speed at height z in stratum
  #   from RHESSys, which was from BGC 4.11.

  # Compute winds
  d_o <- 0.63 * z
  z_o <- 0.1 * z

  # Wind speed at toc log decrease from screen height to toc
  u_z <- u_h * log((z-d_o)/z_o) / log((h-d_o)/z_o)
  return(u_z)
}

penman_monteith <- function(Tair, Rnet, gs, ga, vpda){
  # Calculate forest canopy ET using penman-monteith equation

    # dt:     delta t, a small temperature increase
    # rho:    air density (kg/m2)
    # lhvap:  latent heat of water (J/kg)
    # s:      Slope of saturated vapor pressure - temp
    # es:     Saturated vapor pressure at t2 in Pa
    # ET:     Evapotranspiration in W/m2
    # gamma:  Psychrometric constant
    # z0:     Surface roughness
    # d0:     Zero plane displacement

  # Density of air (rho) as a f'n of air temp
  rho <- 1.292 - (0.00428*Tair)

  # Latent heat of vaporization as a f'n of air temp
  lhvap = 2.5023e6 - 2430.54*Tair

  # Saturation vapor pressures at Tair (Pa)
  es <- 610.7 * exp(17.38 * Tair / ( 239.0 + Tair))

  # Slope of es-T curve at Tair (Pa/deg C) (from Campbell & Norman 1998)
  s <- 17.38*239.0*es / (239.0+Tair)^2

  # Calculate gamma
  gamma <- CP * PA / ( 0.622*lhvap )

  # Evaporation in W/m2
  ET <- ((s*Rnet) + (rho*CP*vpda*ga)) / (gamma*(1.0 + ga/gs) +s)
}


# An introduction to R programming
# NDSU Analysis of Ecosystems
# Devan Allen McGranahan (devan.mcgranahan@ndsu.edu)

# Lesson 3: Introduction to graphing in R, continued
# More basic plotting with plot() + introducing ggplot

##
## S T A R T  H E R E

# Install and load packages for use in this session

  install.packages(c("tidyverse", "plyr"))
  library(plyr) # Always load plyr before tidyverse/dplyr
  library(tidyverse)

# Today we load data a different way - from a pre-defined workspace.
# It loads the same way as any other R object:

# Set your working directory:
  setwd("E:/R/")

# Load R object:
  load(file="./data/data_visualization.RData")
  # or
  load(file.choose())
  # or find it in the file list in Rstudio (lower right corner)

# This is more than just a single R object, it is an entire R session
# and includes all the objects from the session it saved.
  # To see objects from this session, run
    ls()

# Data today come from the Weissengerber et al. (2015) paper
    # which illustrated two main problems with barplots.
    # I digitized data from Figs. 1 and 2 to play with them here.

# Figure 1
    # check out data from Fig 1
    str(fig1)

    # Behold the evil dynamite plot:
  dyn.plot1 <-
      ddply(fig1, .(treatment, scenario),
                  summarise,
                  Mean = mean(response),
                  se   = sd(response) / sqrt(length(response)) ) %>%
      ggplot(aes(x=treatment,
                 y=Mean)) +
            geom_bar(fill="grey", stat="identity") + theme_bw() +
            geom_errorbar(aes(ymin=Mean - se,
                              ymax=Mean + se), width=0.3) +
            facet_wrap(~scenario)
  dyn.plot1

    # All seem equal until we look at patterns in data:
    dyn.plot1 + geom_jitter(data=fig1, # Different dataset? Need data=
                            aes(x=treatment,
                                y=response),
                  width=0.25, shape=21, size=3,
                  col="white", bg="black")

    # Plot with different geoms:
    fig1.gg <- ggplot(fig1, aes(x=treatment,
                                y=response)) +
                theme_bw() + facet_wrap(~scenario)
    fig1.gg + geom_boxplot()
    fig1.gg + geom_violin()
    fig1.gg + geom_violin() + geom_jitter(width=0.25, shape=21,
                                          size=3, col="white", bg="black")
# Figure 2

  dyn.plot2 <-
      ddply(fig2, .(period, scenario),
                  summarise,
                  Mean = mean(response),
                  se   = sd(response) / sqrt(length(response)) )  %>%
      ggplot(aes(x=period,
                 y=Mean)) +
        geom_bar(fill="grey", stat="identity") + theme_bw() +
        facet_wrap(~scenario) +
        geom_errorbar(aes(ymin=Mean - se,
                          ymax=Mean + se), width=0.3)

    dyn.plot2 + geom_jitter(data=fig2, aes(x=period,
                                           y=response),
                            width=0.25, shape=21, size=3,
                            col="white", bg="black")
    # Nothing appears to be amiss...
    # what is wrong with how these data are represented?

    dyn.plot2 + geom_point(data=fig2, aes(x=period,
                                          y=response),
                            shape=21, size=3, col="white", bg="black") +
                geom_line(data=fig2, aes(x=period,
                                         y=response,
                                         group=replicate))

    fig2.gg <- ggplot(fig2, aes(x=period,
                                y=response)) +
                theme_bw() + facet_wrap(~scenario)
    fig2.gg + geom_point(shape=21, size=3,
                         col="white", bg="black") +
              geom_line(aes(group=replicate))

    # Consider another variable?
    fig2c.gg <- ggplot(fig2, aes(x=period,
                                 y=response,
                                 color=conditional)) +
                  theme_bw() +
                  facet_wrap(~scenario)
    fig2c.gg + geom_point(shape=19, size=3) +
               geom_line(aes(group=replicate))

    # Summarize

    sum2c <- ddply(fig2, .(period, scenario, conditional),
                  summarise,
                  Mean = mean(response),
                  se   = sd(response) / sqrt(length(response)) )

    ggplot() + theme_bw() + facet_wrap(~scenario) +
        geom_point(data=fig2, aes(x=period,
                                  y=response,
                                  color=conditional),
                   shape=19, size=3, alpha=0.3) +
        geom_line(data=fig2, aes(x=period,
                                 y=response,
                                 color=conditional,
                                 group=replicate),
                  alpha=0.3) +
        geom_point(data=sum2c, aes(x=period,
                                   y=Mean,
                                  color=conditional),
                   shape=19, size=5,
                   position = position_dodge(0.2) ) +
        geom_errorbar(data=sum2c, aes(x=period,
                                      ymin=Mean - se,
                                      ymax=Mean + se,
                                      color=conditional),
                      width=0.2, size=1.5,
                      position = position_dodge(0.2)) +
        geom_line(data=sum2c, aes(x=period,
                                  y=Mean,
                                 color=conditional,
                                 group=conditional),
                      size=1.5, position=position_dodge(0.2))

  # One solution: plot as differences

    # Need before-after values side-by-side per replicate.
    # Currently "gathered" in a single column; must "spread"
    head(fig2)

    diff.d <- fig2 %>% spread(period, response) %>%
                        plyr::rename( c("1"="before",
                                        "2"="after"))
    head(diff.d)

    diff.d <- diff.d %>%
                mutate(diff = after - before) %>% # Calculate the difference
                  select(-before, -after) # drop unnecessary columns
    head(diff.d)

    diff.gg <-
      ddply(diff.d, .(conditional, scenario),
            summarise,
            Mean = mean(diff),
            se   = sd(diff) / sqrt(length(diff)) )  %>%
      ggplot(aes(x=conditional)) +
      geom_hline(aes(yintercept=0), col="black", linetype=3) +
      geom_errorbar(aes(ymin=Mean - se,
                        ymax=Mean + se,
                        color=conditional),
                    size=1.25, width=0.2) +
      geom_point(aes(y=Mean,
                     fill=conditional),
                 shape=21, size=4,
                 color="black", stroke=1.5) +
      labs(x = "Condition",
           y = "Difference (mean +/- s.e.)") +
      facet_wrap(~scenario) +
      theme(legend.position = "none",
            panel.grid.major.x = element_blank())
    diff.gg

    (diff.gg <- diff.gg + geom_jitter(data=diff.d, aes(x=conditional,
                                           y=diff,
                                           color=conditional),
                            width=0.1, shape=1, size=3) )

    diff.gg + geom_violin(data=diff.d, aes(y=diff,
                                           color=conditional),
                                      fill=NA, trim=FALSE)

Analysis of Ecosystems/03 - data visualization/3-2_bar_plot_critique.r


# Run the code below to set up the data
# Make a scatter plot with x=Male, y=Female

library(tidyverse)
# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")
casey <- unisex_data %>% # get just the data for "Casey" needed to plot
  filter(name=="Casey") %>%
  select(-prop) %>%
  spread(sex, n, fill=0)
casey

# make the plot
ggplot(casey, aes(x=Male, y=Female)) +
  geom_point()


#' convert_P.r
#' For phosphorus, but general two step linear converter.
#' Lets say you want to convert a value, A, to a different, value, C.
#' You have data relating A to B, and B to C.
#' This will take those datasets, and a vector of A values you want to convert.
#' It will return a list, where "mean" is the mean predicted value of c, given a, and "sd" is the predictions standard deviation.
#'
#' @param to_convert vector of values to convert from a->c
#' @param d1         dataframe that relates a to b, a in the first column, b in the second.
#' @param d2         dataframe that relates b to c, b in the first column, c in the second.
#' @param n.sim      number of simulations to generate mean and sd from. 1000 is default and fine.
#'
#' @return           returns a list where mean is the mean predicted value of c, given a, and sd is the predictions standard deviation.
#' @export
#'
#' @examples
#' #phosphorus data converter.
#' a <- runif(100, 0, 1)
#' b <- a*1.2 + rnorm(length(a), sd = 0.1)
#' c <- b*0.9 + rnorm(length(b), sd = 0.1)
#' d1 <- data.frame(a,b)
#' d2 <- data.frame(b,c)
#' to_convert <- runif(25, 0, 1)
#' convert_P(to_convert,d1,d2)
convert_P <- function(to_convert,d1,d2,n.sim=1000, log10_flip = F){
  #setup predictors for JAGS.----
  y1 <- d1[,2]
  x1 <- d1[,1]
  x1 <- cbind(rep(1,length(x1)),x1)
  y2 <- d2[,2]
  x2 <- d2[,1]
  x2 <- cbind(rep(1,length(x2)),x2)

  #JAGS data object.
  jd <- list(N = length(y1), N.pred = ncol(x1),
             y1=y1, y2=y2, x1=x1, x2=x2)

  #Define JAGS model.----
  jags.model = "
  model{
  #covariate parameter priors.
  for(k in 1:N.pred){
  m1[k] ~ dnorm(0,0.001)
  m2[k] ~ dnorm(0,0.001)
  }
  #data model precision priors.
  tau1 <- pow(sigma1, -2)
  sigma1 ~ dunif(0, 100)
  tau2 <- pow(sigma2, -2)
  sigma2 ~ dunif(0, 100)

  #regression models.
  for(i in 1:N){
  mu1[i] <- inprod(x1[i,], m1)
  mu2[i] <- inprod(x2[i,], m2)
   y1[i] ~ dnorm(mu1[i], tau1)
   y2[i] ~ dnorm(mu2[i], tau2)
  }
  } #end JAGS model loop.
  "

  #Fit JAGS model.----
  cat('Fitting JAGS model...\n')
  suppressWarnings(
    jags.out <- run.jags(jags.model,
                         data=jd,
                         n.chains=3,
                         adapt = 500,
                         burnin = 1000,
                         sample = 1000,
                         monitor=c('m1','m2'),
                         method = 'rjags')
  )
  jout <- summary(jags.out)

  #grab mcmc of model parameters.
  mcmc <- do.call(rbind, jags.out$mcmc)

  #convert to_convert data from a to c, propagating uncertainty!----
  convert.out <- list()
  for(i in 1:n.sim){
    par <- mcmc[sample(nrow(mcmc),1),]
    b <- par[2]*to_convert + par[1]
    c <- par[4]*b + par[3]
    convert.out[[i]] <- c
  }

  #wrap up output to return.----
  convert.out <- do.call(cbind, convert.out)
  #log10 variable?
  suppressWarnings(
    if(log10_flip == T){
      convert.out <- log10(convert.out)
    }
  )
  mu <- rowMeans(convert.out, na.rm = T)
  mu.sd <- apply(convert.out, 1, sd, na.rm = T)
  output <- list(mu, mu.sd)
  names(output) <- c('mean','sd')

  #return output, end function.----
  return(output)
} #end function.


#' Plot gene set correlation matrices given a an scamt. See version using metacells for potentially more robust behavior. This is used to detemrine initial feature selectio (e.g. filtering biologically irrelevant gene modules)
#'
#'
#'
#' @export

mcell_plot_gset_cor_mats = function(gset_id, scmat_id, downsamp=T)
{
	feat = gset_get_feat_mat(gset_id, scmat_id, downsamp=downsamp)
	gset = scdb_gset(gset_id)
	k_nonz_exp = get_param("scm_k_nonz_exp")
	feat = as.matrix(log2(1+k_nonz_exp*feat))

	mat = scdb_mat(scmat_id)
	cnms = colnames(feat)
	csize = colSums(mat@mat[,cnms])

	feat = rbind(feat, csize)
	rownames(feat)[nrow(feat)] = "tot_umi"
	gcor = tgs_cor(t(feat))
	diag(gcor) = NA

	dir_nm = scfigs_dir(gset_id, "gset_cors")
	if(!dir.exists(dir_nm)) {
		dir.create(dir_nm)
	}

	s_ids = unique(gset@gene_set)
	for(s_id in s_ids) {
		s_nms = names(gset@gene_set)[which(gset@gene_set==s_id)]
		s_nms = c(s_nms, "tot_umi")
		n = length(s_nms)
		fn = sprintf("%s/%s.png", dir_nm, s_id)
		png(fn, w=160+n*15, h=120+n*15)
		shades = colorRampPalette(c("darkblue", "blue","white", "red", "yellow"))(1000)
		breaks = seq(-0.5,0.5,l=1001)
		vs = pmin(pmax(gcor[s_nms,s_nms],-0.5),0.5)
		pheatmap::pheatmap(vs, col=shades, breaks=breaks, cluster_rows=n>2, cluster_cols=n>2)
		dev.off()
	}
}


################################################################################
# Part of the R/EpiILM package
#
# AUTHORS:
#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>,
#         Waleed Almutiry <wkmtierie@qu.edu.sa>, and
#         Rob Deardon <robert.deardon@ucalgary.ca>
#
#
# Algorithm based on:
#                Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
#                M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).
#                Inference for individual level models of infectious diseases in large
#                populations. Statistica Sinica, 20, 239-261.
#
#
# Free software under the terms of the GNU General Public License, version 2,
# a copy of which is available at http://www.r-project.org/Licenses/.
################################################################################

epilike <- function(object, tmin = NULL, tmax, sus.par, trans.par = NULL,
                    beta = NULL, spark = NULL, Sformula = NULL, Tformula = NULL) {

if (!is(object, "epidata")) {
   stop("The object must be in a class of \"epidata\"", call. = FALSE)
} else {

  # Error checks for input arguments
  if (any(is.null(object$type) | !(object$type %in% c("SI", "SIR"))) == TRUE) {
    stop("epilike: Specify type as \"SI\" or \"SIR\" ", call. = FALSE)
  }

  ns <- length(sus.par)
  if (!is.null(trans.par)){
    nt <- length(trans.par)
    flag.trans <- 1
    phi <- trans.par
  } else if (is.null(trans.par)) {
    nt <- 1
    flag.trans <- 0
    phi <- 1
    trans.par <- 1
  }

  if (!is.vector(object$inftime)) {
    stop('epilike: inftime is not a vector')
  }
  n <- length(object$inftime)

  if (all(is.null(object$contact) &  is.null(object$XYcoordinates)) == TRUE) {
      stop('epilike: Specify contact network or x, y coordinates')
  }

  if (all(is.null(object$remtime) & object$type == "SIR") == TRUE) {
    stop(' epilike: Specify removal times')
  }

  if(object$type == "SIR") {
      infperiod <- object$remtime - object$inftime
  }

  if (is.null(tmin)) {
    tmin <- 1
  }
  if (is.null(spark)) {
    spark <- 0
  }

  if (is.null(object$contact)) {
    ni <- length(beta)
    if (is.null(beta)) {
      stop("epilike: A scalar value of the spatial parameter beta must be specified", call. = FALSE)
    }
    if (ni != 1) {
      stop("epilike: The input of beta has more than one value while the considered distance-based ILM needs only one spatial parameter, beta.", call. = FALSE)
    }
  } else {
    if (length(object$contact)/(n * n) == 1) {
      ni <- 1
      if (is.null(beta)) {
        beta <- 1
      } else {
        stop("epilike: As the model has only one contact network, The model does not need a network parameter beta, beta must be assigned to its default values = NULL", call. = FALSE)
      }
    } else if (length(object$contact)/(n * n) > 1) {
      ni <- length(beta)
      if (is.null(beta)) {
        stop("epilike: A vector values of the network parameters beta must be specified", call. = FALSE)
      }
      if (length(object$contact)/(n * n) != ni) {
        stop('epilike: Dimension of beta and the number of contact networks are not matching')
      }
    }
    network <- array(object$contact, c(n, n, ni))
  }

  # formula for susceptibility function
  	if (!is.null(Sformula)) {
  		covmat.sus <- model.matrix(Sformula)

  		if (all((ncol(covmat.sus) == length(all.vars(Sformula))) & (ns != length(all.vars(Sformula)))) == TRUE) {
  			stop("epilike: Check Sformula (no intercept term) and the dimension of susceptibility parameters", call. = FALSE)
  		} else if (all((ncol(covmat.sus) > length(all.vars(Sformula))) & (ns != ncol(covmat.sus))) == TRUE) {
  			stop("epilike: Check Sformula (intercept term) and the dimension of susceptibility parameters", call. = FALSE)
  		}
  	} else {
  		if (ns == 1) {
  			covmat.sus <- matrix(1.0, nrow = n, ncol = ns)
  		}
  	}

    # formula for transmissibility function
    if (flag.trans == 1) {
      if (is.null(Tformula)) {
        stop("epilike: Tformula is missing. It has to be specified with no intercept term and number of columns equal to the length of trans.par", call. = FALSE)
      } else if (!is.null(Tformula)) {
    		covmat.trans <- model.matrix(Tformula)

    		if (all((ncol(covmat.trans) == length(all.vars(Tformula))) & (nt != length(all.vars(Tformula)))) == TRUE) {
    			stop("epilike: Check Tformula. It has to be with no intercept term and number of columns equal to the length of trans.par", call. = FALSE)
    		}
      }
    } else if (flag.trans == 0) {
    	covmat.trans <- matrix(1.0, nrow = n, ncol = nt)
    }

# Calling fortran subroutines for Purely Spatial models : SI and SIR

  if (all((object$type == "SI") & is.null(object$contact)) == TRUE) {

    tmp1 <- .Fortran("like",
                   x = as.vector(object$XYcoordinates[,1], mode = "double"),
                   y = as.vector(object$XYcoordinates[,2], mode = "double"),
                   tau = as.vector(object$inftime, mode = "integer"),
                   n = as.integer(n),
                   tmin = as.integer(tmin),
                   tmax = as.integer(tmax),
                   ns = as.integer(ns),
                   nt = as.integer(nt),
                   ni = as.integer(ni),
                   alpha = as.vector(sus.par, mode = "double"),
                   phi = as.vector(trans.par, mode = "double"),
                   beta = as.vector(beta, mode = "double"),
                   spark = as.double(spark),
                   covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                   covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                   val = as.double(0))

  } else if (all((object$type == "SIR") & is.null(object$contact)) == TRUE) {

    tmp1 <- .Fortran("likesir",
                    x = as.vector(object$XYcoordinates[,1], mode = "double"),
                    y = as.vector(object$XYcoordinates[,2], mode = "double"),
                    tau = as.vector(object$inftime, mode = "integer"),
                    lambda = as.vector(infperiod, mode = "integer"),
                    n = as.integer(n),
                    tmin = as.integer(tmin),
                    tmax = as.integer(tmax),
                    ns = as.integer(ns),
                    nt = as.integer(nt),
                    ni = as.integer(ni),
                    alpha = as.vector(sus.par, mode = "double"),
                    phi = as.vector(trans.par, mode = "double"),
                    beta = as.vector(beta, mode = "double"),
                    spark = as.double(spark),
                    covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                    covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                    val = as.double(0))

  } else if (all((object$type == "SI") & !is.null(object$contact)) == TRUE) {
    tmp1 <- .Fortran("likecon",
                    tau = as.vector(object$inftime, mode = "integer"),
                    n = as.integer(n),
                    ns = as.integer(ns),
                    nt = as.integer(nt),
                    ni = as.integer(ni),
                    tmin = as.integer(tmin),
                    tmax = as.integer(tmax),
                    alpha = as.vector(sus.par, mode = "double"),
                    phi = as.vector(trans.par, mode = "double"),
                    beta = as.vector(beta, mode = "double"),
                    spark = as.double(spark),
                    covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                    covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                    network = as.vector(network),
                    val = as.double(0))

  } else if (all((object$type == "SIR") & !is.null(object$contact)) == TRUE) {

    # Calling fortran subroutines for Contact network models: SI and SIR

    if (length(object$contact)/(n * n) != ni) {
      stop('epilike:  Dimension of beta  and the number of contact networks are not matching')
    }
    network <- array(object$contact, c(n, n, ni))

    tmp1 <- .Fortran("likeconsir",
                      tau = as.vector(object$inftime, mode = "integer"),
                      lambda = as.vector(infperiod, mode = "integer"),
                      n = as.integer(n),
                      ns = as.integer(ns),
                      nt = as.integer(nt),
                      ni = as.integer(ni),
                      tmin = as.integer(tmin),
                      tmax = as.integer(tmax),
                      alpha = as.vector(sus.par, mode = "double"),
                      phi = as.vector(trans.par, mode = "double"),
                      beta = as.vector(beta, mode = "double"),
                      spark = as.double(spark),
                      covmatsus = matrix(as.double(covmat.sus), ncol = ncol(covmat.sus), nrow = n),
                      covmattrans = matrix(as.double(covmat.trans), ncol = ncol(covmat.trans), nrow = n),
                      network = as.vector(network),
                      val = as.double(0))
  }
  return(tmp1$val)
}# End of function
}


conditionalModels <- function(dependent.df, independent.list, covariates.df, timelevels, events,marker) {
  library(dplyr)
  require(dplyr)

  # Tables and lists to store results:
  coef.tb <- tibble()
  vcov.list <- vector(mode = 'list', length = length(events))
  names(vcov.list) <- events

  for (event in events) {

    #### Create a model dataframe ####
    independent.list[[event]] %>%
      mutate_if(is.numeric, list( ~replace_na(., 0))) -> X.df

    # Join the target event with the outcome variable and scale
    dependent.df %>%
      inner_join(X.df, by = c('xwaveid', 'wave')) %>%
      group_by(xwaveid) %>%
      mutate(Y = scale(Y)) %>% # scaling produces NaN when no variation
      ungroup() %>%            # so replace NaN with 0 and leave NA in
      mutate(Y = ifelse(is.nan(Y), NA, Y)) -> vars.df

    # get other events as covariates
    covariate.events = events[which(events != event)]
    covars.df <- select(vars.df, xwaveid, wave)
    for (covar in covariate.events) {
      independent.list[[covar]] %>%
        rename_at(vars(starts_with('p')), ~ paste0(., covar)) %>%
        mutate_if(is.numeric, list(~ replace_na(., 0))) %>%
        right_join(covars.df, by = c("xwaveid", "wave")) -> covars.df
    }

    covars.df %>%
      mutate_if(is.numeric, list(~ replace_na(., 0))) -> covars.df

    # join target variables with covariates
    vars.df %>%
      left_join(covars.df, by = c("xwaveid", "wave")) %>%
      left_join(covariates.df, by = c("xwaveid", "wave")) -> full.df

    rm(vars.df,covars.df)
    # test for missing covariates
    # full.df %>%
    #   select(xwaveid, edu, seifa) %>%
    #   group_by(xwaveid) %>%
    #   summarise_all(funs(sum(is.na(.)))) %>%
    #   filter(edu > 0 | seifa > 0) -> nacount
    #
    # if (nrow(nacount) > 0) {
    #   # browser()
    #   message(unique(nacount$xwaveid))
    #   }

    # Build the model
    full.df %>%
      ungroup() %>%
      select(-Y, -xwaveid) %>%
      select(-wave, everything()) %>%
      colnames() -> var.names

    full.df<-full.df[sample(nrow(full.df), 1500), ]

    if(marker=="female"){

      full.df <- full.df %>% filter(sex==1)

      }else if(marker=="male"){

      full.df <- full.df %>% filter(sex==0)

      }else if(marker=="seifa_top_half"){

      full.df <- full.df %>% filter(seifa==10|seifa==9|seifa==8|seifa==7|seifa==6)

      }else if(marker=="seifa_bottom_half"){

      full.df <- full.df %>% filter(seifa==5|seifa==4|seifa==3|seifa==2|seifa==1)

      }else{
      full.df<-full.df[sample(nrow(full.df), 1500), ]

      }

    full.df %>%
      ungroup() %>%
      select(-Y, -xwaveid) %>%
      select(-wave,-sex, everything()) %>%
      colnames() -> var.names

    # Formula and model
    full.formula <- as.formula(paste('Y ~', paste(var.names[-1], collapse = ' + ')))
    fe <- plm(full.formula, full.df, index = c('xwaveid'), method = 'within')

    # Add details to coefficient table
    n.tb <- tibble (n = colSums(full.df[, 5:13]))
    n.tb$term <- colnames(full.df[, 5:13])

    tidy(coeftest(fe, vcov. = vcovHC(fe, type = 'HC1'))) %>%
      filter(term %in% timelevels) %>%
      left_join(n.tb, by = c("term")) %>%
      mutate(df = fe$df.residual,
             N = pdim(fe)$nT$n,
             #r2 = summary(fe)$r.squared[1],
             code = event) %>%
      bind_rows(coef.tb) -> coef.tb

    # Get the variance-covariance matrix
    # vcov.mat <- vcovHC(fe, type = "HC1")[1:9, 1:9]
    vcov.mat <- vcovHC(fe, type = "sss")[1:9, 1:9]
    vcov.list[[event]] <- vcov.mat
  }

  return(list(coefs = coef.tb, covar = vcov.list))
}


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

# author - akashraj

# genetic algorithm for feature selection using random forests for fitness function

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

#load required libraries
library("foreign")
library("randomForest")
#library("pROC")
library("ROCR")

set.seed(71)

#load data
CM1 <- read.arff("data/CleanedData/MDP/D'/CM1.arff")
CM1_train <- CM1[1:240, ]
CM1_val <- CM1[241:nrow(CM1) ,] #validation set

#random forest - train model
model.rf <- randomForest(Defective~., data = CM1_train, importance = T, proximity = T, keep.forest = T, test = CM1_val)

#to find AUC of ROC
model.rf.probability = predict(model.rf, type = "prob", newdata = CM1_val)[ ,2]
model.rf.pred = prediction(model.rf.probability, CM1_val$Defective)
model.rf.perf = performance(model.rf.pred, "tpr", "fpr")

plot(model.rf.perf, main = "ROC Curve for Random Forest", col = 2, lwd = 2)
abline(a = 0, b = 1, lwd = 2, lty = 2, col = "gray")

auc <- performance(model.rf.pred, "auc")


require(rms)
n = 800
x = rnorm(n)
x[4:6] = NA
y = x + rnorm(n)
fit = ols(y ~ x)
print(fit, latex=TRUE)


# import data

wd = "D:/Ruo_data/2019_Paper_Publish/Publish"
setwd(wd)

sp_TL.result <- read.csv("./SizeAggregTend_data/output/1_size_TL/all_TL_result_16_compiled.csv",stringsAsFactors = F,sep=",",header = T)
sp_TL.result$spwn <- as.factor(sp_TL.result$spwn)
sp_TL.result$quarter <- as.factor(sp_TL.result$quarter)
sp_TL.result$sp_ID <- as.factor(sp_TL.result$sp_ID)
sp_TL.result$mat_stage <- as.factor(sp_TL.result$mat_stage)

####### species fitted respectively #################################

library("coxed")
library("mgcv")
library("tidymv")

sp_common_name <- c("Herring","Cod","Haddock","Whiting","Plaice",
                    "Saithe", "Mackerel","Sprat","Norwaypout")

sp_fit_summary <- list()
sp_resp_humppeak <- NULL
sp.resp_slope_Q1 <- NULL
sp.resp_slope_Q3 <- NULL

TL_BSdata <- read.csv("./SizeAggregTend_data/output/1_size_TL/resample_TL_bs_data.csv")
TL_BSdata <- TL_BSdata[,-1]
TL_BSdata <- cbind(sp_TL.result$b,TL_BSdata)

size_at_maturity_stage = read.csv("./SizeAggregTend_data/compiled/size_at_maturityStage_byQ.csv")
sp.mid.L <- as.matrix(read.table("./SizeAggregTend_data/compiled/allsp_length_mid_16class.txt"))
mature.L <- as.matrix(read.table("./SizeAggregTend_data/compiled/mature_L.txt"))

all_sp_peak_slope_95CI <-NULL
all_bs_pred_result_Q1 <- list()
all_bs_pred_result_Q3 <- list()

# bootstrap 999 times for model fitting and prediction

newdat_Q1 <- expand.grid(std_L = seq(-0.69,0.75,length=200),
                         quarter = c("Q1"))
newdat_Q3 <- expand.grid(std_L = seq(-0.69,0.75,length=200),
                         quarter = c("Q3"))

for(i in 1:9){

  sp_bs_pred_result_Q1 <- NULL
  sp_bs_pred_result_Q3 <- NULL
  for(bs in 1:1000){
    bs_TL_result <- cbind(TL_BSdata[,bs],sp_TL.result[,9:20])
    colnames(bs_TL_result)[1] <- "b"
    sp_bs_fit <- gam(b~quarter+s(std_L,by=quarter,bs="ts"),
                     data=bs_TL_result[which(bs_TL_result$sp_ID==i),],
                     method = "REML")
    # Q1 prediction
    sp_bs_pred_b_Q1 <- tapply(predict(sp_bs_fit, newdata = newdat_Q1, type="response"),newdat_Q1$std_L,mean)
    sp_bs_pred_result_Q1 <- cbind(sp_bs_pred_result_Q1,sp_bs_pred_b_Q1)

    # Q3 prediction
    sp_bs_pred_b_Q3 <- tapply(predict(sp_bs_fit, newdata = newdat_Q3, type="response"),newdat_Q3$std_L,mean)
    sp_bs_pred_result_Q3 <- cbind(sp_bs_pred_result_Q3,sp_bs_pred_b_Q3)

  }
  all_bs_pred_result_Q1[[i]] = sp_bs_pred_result_Q1
  all_bs_pred_result_Q3[[i]] = sp_bs_pred_result_Q3

  ## hump shape peak ##

  main <- c(max(sp_TL.result$std_L[(i*32-31):(i*32)]),min(sp_TL.result$std_L[(i*32-31):(i*32)]))

  peak_fuc <- function(x){
    x = rbind(x,newdat_Q1$std_L)
    x = x[,which(newdat_Q1$std_L<main[1] & newdat_Q1$std_L>main[2])]
    max_b = max(x[1,])
    peak_loc = x[2,which(x[1,]==max_b)]
    return(c(max_b,peak_loc))
  }

  peak_info_Q1 <- apply(sp_bs_pred_result_Q1,2,peak_fuc)
  peak_info_Q3 <- apply(sp_bs_pred_result_Q3,2,peak_fuc)

  sp_resp_humppeak <- rbind(sp_resp_humppeak, peak_info_Q1, peak_info_Q3)

  ## hump shape slope ##
  sp_TL.result_Q1 <- filter(sp_TL.result,quarter=="Q1" & sp_ID==i)
  sp_TL_BSdata_Q1 <- filter(TL_BSdata,sp_TL.result$quarter=="Q1" & sp_TL.result$sp_ID==i)

  sp_TL.result_Q3 <- filter(sp_TL.result,quarter=="Q3" & sp_ID==i)
  sp_TL_BSdata_Q3 <- filter(TL_BSdata,sp_TL.result$quarter=="Q3" & sp_TL.result$sp_ID==i)

  std_L05_Q1 = (size_at_maturity_stage$L05[i]-mature.L[i])/(max(sp.mid.L[i,])-min(sp.mid.L[i,]))
  std_L95_Q1 = (size_at_maturity_stage$L95[i]-mature.L[i])/(max(sp.mid.L[i,])-min(sp.mid.L[i,]))
  std_L05_Q3 = (size_at_maturity_stage$L05[i+9]-mature.L[i])/(max(sp.mid.L[i+9,])-min(sp.mid.L[i+9,]))
  std_L95_Q3 = (size_at_maturity_stage$L95[i+9]-mature.L[i])/(max(sp.mid.L[i+9,])-min(sp.mid.L[i+9,]))

  for(bs in 1:1000){
    #Q1
    sp_TLBS_result_Q1 <- cbind(sp_TL_BSdata_Q1[,bs],sp_TL.result_Q1[,10:20])
    colnames(sp_TLBS_result_Q1)[1] <-"b"
    mat1_dat_1 = filter(sp_TLBS_result_Q1,std_L<std_L05_Q1)
    mat2_dat_1 = filter(sp_TLBS_result_Q1,std_L>=std_L05_Q1 & std_L<std_L95_Q1)
    mat3_dat_1 = filter(sp_TLBS_result_Q1,std_L>=std_L95_Q1)

    if(length(mat1_dat_1[,1])>2) {
      mat1_line_fit_1 <- summary(gam(b~std_L,mat1_dat_1,family = Gamma(link = "log")))
      mat1_line_Rst_1 <- c(mat1_line_fit_1$p.table[2,],mat1_line_fit_1$r.sq,mat1_line_fit_1$dev.expl)
    }else{mat1_line_Rst_1 <- matrix(0,nrow = 1,ncol=5)}

    if(length(mat2_dat_1[,1])>2) {
      mat2_line_fit_1 <- summary(gam(b~std_L,mat2_dat_1,family = Gamma(link = "log")))
      mat2_line_Rst_1 <- c(mat2_line_fit_1$p.table[2,],mat2_line_fit_1$r.sq,mat2_line_fit_1$dev.expl)
    }else{mat2_line_Rst_1 <- matrix(0,nrow = 1,ncol=5)}

    if(length(mat3_dat_1[,1])>2) {
      mat3_line_fit_1 <- summary(gam(b~std_L,mat3_dat_1,family = Gamma(link = "log")))
      mat3_line_Rst_1 <- c(mat3_line_fit_1$p.table[2,],mat3_line_fit_1$r.sq,mat3_line_fit_1$dev.expl)
    }else{mat3_line_Rst_1 <- matrix(0,nrow = 1,ncol=5)}

    #Q3
    sp_TLBS_result_Q3 <- cbind(sp_TL_BSdata_Q3[,bs],sp_TL.result_Q3[,10:20])
    colnames(sp_TLBS_result_Q3)[1] <-"b"
    mat1_dat_3 = filter(sp_TLBS_result_Q3,std_L<std_L05_Q3)
    mat2_dat_3 = filter(sp_TLBS_result_Q3,std_L>=std_L05_Q3 & std_L<std_L95_Q3)
    mat3_dat_3 = filter(sp_TLBS_result_Q3,std_L>=std_L95_Q3)

    if(length(mat1_dat_3[,1])>2) {
      mat1_line_fit_3 <- summary(gam(b~std_L,mat1_dat_3,family = Gamma(link = "log")))
      mat1_line_Rst_3 <- c(mat1_line_fit_3$p.table[2,],mat1_line_fit_3$r.sq,mat1_line_fit_3$dev.expl)
    }else{mat1_line_Rst_3 <- matrix(0,nrow = 1,ncol=5)}

    if(length(mat2_dat_3[,1])>2) {
      mat2_line_fit_3 <- summary(gam(b~std_L,mat2_dat_3,family = Gamma(link = "log")))
      mat2_line_Rst_3 <- c(mat2_line_fit_3$p.table[2,],mat2_line_fit_3$r.sq,mat2_line_fit_3$dev.expl)
    }else{mat2_line_Rst_3 <- matrix(0,nrow = 1,ncol=5)}

    if(length(mat3_dat_3[,1])>2) {
      mat3_line_fit_3 <- summary(gam(b~std_L,mat3_dat_3,family = Gamma(link = "log")))
      mat3_line_Rst_3 <- c(mat3_line_fit_3$p.table[2,],mat3_line_fit_3$r.sq,mat3_line_fit_3$dev.expl)
    }else{mat3_line_Rst_3 <- matrix(0,nrow = 1,ncol=6)}

    sp.resp_slope_Q1 <- rbind(sp.resp_slope_Q1,
                           #Q1
                          c(mat1_line_Rst_1,length(mat1_dat_1[,1]),
                            mat2_line_Rst_1,length(mat2_dat_1[,1]),
                            mat3_line_Rst_1,length(mat3_dat_1[,1])))
    sp.resp_slope_Q3 <- rbind(sp.resp_slope_Q3,
                              #Q3
                              c(mat1_line_Rst_3,length(mat1_dat_3[,1]),
                                mat2_line_Rst_3,length(mat2_dat_3[,1]),
                                mat3_line_Rst_3,length(mat3_dat_3[,1])))
  }

  all_same_logic_fuc = function(x=peak_info_Q3[2,]){
    not_same_lengt = length(which(x[2:length(x)]!=x[1]))
    if(not_same_lengt<100){logit=c(T,T)}else{logit=c(F,F)}
    return(logit)
  }

  max_b_95CI = rbind(ifelse(all_same_logic_fuc(peak_info_Q1[1,]),c(peak_info_Q1[1,1],peak_info_Q1[1,1]),bca(peak_info_Q1[1,])),
                     ifelse(all_same_logic_fuc(peak_info_Q3[1,]),c(peak_info_Q3[1,1],peak_info_Q3[1,1]),bca(peak_info_Q3[1,])))
  peak_loc_95CI = rbind(ifelse(all_same_logic_fuc(peak_info_Q1[2,]),c(peak_info_Q1[2,1],peak_info_Q1[2,1]),bca(peak_info_Q1[2,])),
                        ifelse(all_same_logic_fuc(peak_info_Q3[2,]),c(peak_info_Q3[2,1],peak_info_Q3[2,1]),bca(peak_info_Q3[2,])))
  mat1_slope_95CI = rbind(bca(sp.resp_slope_Q1[,1]),bca(sp.resp_slope_Q3[,1]))
  mat2_slope_95CI = rbind(bca(sp.resp_slope_Q1[,8]),bca(sp.resp_slope_Q3[,8]))
  mat3_slope_95CI = rbind(bca(sp.resp_slope_Q1[,15]),bca(sp.resp_slope_Q3[,15]))

  all_sp_peak_slope_95CI = rbind(all_sp_peak_slope_95CI,
                                 max_b_95CI, peak_loc_95CI,
                                 mat1_slope_95CI,mat2_slope_95CI,mat3_slope_95CI)
  #all_sp_resp_humppeak[[i]] = sp_resp_humppeak
  #all_sp.resp_slope_Q1[[i]] = sp.resp_slope_Q1
  #all_sp.resp_slope_Q3[[i]] = sp.resp_slope_Q3

  print(i)
}

all_sp_peak_slope_95CI <- as.data.frame(all_sp_peak_slope_95CI)
all_sp_peak_slope_95CI$sp_ID <- rep(1:9,each=10)
all_sp_peak_slope_95CI$quarter <- rep(c("Q1","Q3"),45)
all_sp_peak_slope_95CI$hump_char <- rep(rep(c("max_b","peak_loc","mat1_slope","mat2_slope","mat3_slope"),each=2),9)

write.csv(sp_resp_humppeak,"./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_humppeak.csv")
write.csv(sp.resp_slope_Q1,"./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_slope_Q1.csv")
write.csv(sp.resp_slope_Q3,"./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_slope_Q3.csv")
write.csv(all_sp_peak_slope_95CI,"./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_peak_slope_95CI.csv")

save(all_bs_pred_result_Q1,file = "./SizeAggregTend_data/output/3_humpshape_characteristics/sp_bs_pred_Q1.RData")
save(all_bs_pred_result_Q3,file = "./SizeAggregTend_data/output/3_humpshape_characteristics/sp_bs_pred_Q3.RData")

##########################################
# plot species fit
##########################################
sp_resp_humppeak <- read.csv("./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_humppeak.csv")
sp.resp_slope_Q1 <- read.csv("./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_slope_Q1.csv")
sp.resp_slope_Q3 <- read.csv("./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_slope_Q3.csv")
all_sp_peak_slope_95CI <- read.csv("./SizeAggregTend_data/output/3_humpshape_characteristics/sp_resp_peak_slope_95CI.csv")

load("./SizeAggregTend_data/output/3_humpshape_characteristics/sp_bs_pred_Q1.RData")
load("./SizeAggregTend_data/output/3_humpshape_characteristics/sp_bs_pred_Q3.RData")

jpeg("./SizeAggregTend_data/output/fig/Fig_sp_resp_fit_byQ_bs_matstagebyQ.jpeg", width=1476, height=1476, units = "px",res=300)

par(mfrow=c(3,3),mar=c(3,2,3,1),oma=c(3,3,1,0),xpd=F)
for(i in 1:9){

  sp_bs_pred_b_main_Q1 = as.data.frame(cbind(all_bs_pred_result_Q1[[i]],newdat_Q1$std_L))
  sp_bs_pred_b_main_Q3 = as.data.frame(cbind(all_bs_pred_result_Q3[[i]],newdat_Q3$std_L))

  main <- c(max(sp_TL.result$std_L[(i*32-31):(i*32)]),min(sp_TL.result$std_L[(i*32-31):(i*32)]))
  sp_bs_pred_b_main_Q1 = sp_bs_pred_b_main_Q1[which(sp_bs_pred_b_main_Q1$V1001<main[1] &
                                                      sp_bs_pred_b_main_Q1$V1001>main[2]),]
  sp_bs_pred_b_main_Q3 = sp_bs_pred_b_main_Q3[which(sp_bs_pred_b_main_Q3$V1001<main[1] &
                                                      sp_bs_pred_b_main_Q3$V1001>main[2]),]

  sp_fit_95CI_Q1 = apply(sp_bs_pred_b_main_Q1[,1:1000],1,bca)
  sp_fit_95CI_Q3 = apply(sp_bs_pred_b_main_Q3[,1:1000],1,bca)

  plot(sp_bs_pred_b_main_Q1$V1001,sp_bs_pred_b_main_Q1[,1],
       col = c("grey40"),lty = 1,type="l",lwd=2,
       xlim = c(-0.8,0.8),
       ylim = c(0.5,3.5),
       family="newrom",xlab = "",ylab="",main = sp_common_name[i])
  polygon(c(rev(sp_bs_pred_b_main_Q1$V1001), sp_bs_pred_b_main_Q1$V1001),
          c(rev(sp_fit_95CI_Q1[ 2,]), sp_fit_95CI_Q1[ 1,]),
          col = rgb(150, 150, 150, 80, maxColorValue=255), border = NA)
  points(sp_TL.result$std_L[(32*i-31):(32*i-16)],
         sp_TL.result$b[(32*i-31):(32*i-16)],col="grey10",cex=0.8)

  lines(sp_bs_pred_b_main_Q3$V1001,sp_bs_pred_b_main_Q3[,1],
        col = rgb(220, 34, 34, 100, maxColorValue=255),lwd=2,
        xlim = c(-0.8,0.8),
        ylim = c(0.5,3.5))
  polygon(c(rev(sp_bs_pred_b_main_Q3$V1001), sp_bs_pred_b_main_Q3$V1001),
          c(rev(sp_fit_95CI_Q3[ 2,]), sp_fit_95CI_Q3[ 1,]),
          col = rgb(220, 34, 34, 80, maxColorValue=255), border = NA)
  points(sp_TL.result$std_L[(32*i-15):(32*i)],
         sp_TL.result$b[(32*i-15):(32*i)],pch=1,col=2,cex=0.8)

  abline(v=((size_at_maturity_stage$L05[i]-mature.L[i])/(max(sp.mid.L[i,])-min(sp.mid.L[i,]))),lty=2)
  abline(v=((size_at_maturity_stage$L95[i]-mature.L[i])/(max(sp.mid.L[i,])-min(sp.mid.L[i,]))),lty=2)
  abline(v=((size_at_maturity_stage$L05[i+9]-mature.L[i])/(max(sp.mid.L[i+9,])-min(sp.mid.L[i+9,]))),lty=2,col=2)
  abline(v=((size_at_maturity_stage$L95[i+9]-mature.L[i])/(max(sp.mid.L[i+9,])-min(sp.mid.L[i+9,]))),lty=2,col=2)

}

mtext("Standardized length",side=1,line=1,outer = T,cex = 1)
mtext("Taylor's exponents",side=2,line=1,outer = T,cex = 1)

dev.off()

###########################################################################
# check bootstrapped result
###########################################################################

# peak
sp_resp_humppeak = sp_resp_humppeak[,-1]
par(mfrow=c(3,3))
for(i in 1:9) {
  hist(as.numeric(sp_resp_humppeak[4*(i-1)+1,]),main=sp_common_name[i])
}

jpeg("./SizeAggregTend_data/output/fig/Appendix/Fig_bs_peaklocat_Q1.jpeg", width=6.5, height=5, units = "in",res=300)
par(mfrow=c(3,3),mar=c(2,2,4,2),oma=c(3,3,1,1))
for(i in 1:9) {
  no_not_hump = length(which(sp_resp_humppeak[4*(i-1)+2,]==max(sp_resp_humppeak[4*(i-1)+2,]) | sp_resp_humppeak[4*(i-1)+2,]==min(sp_resp_humppeak[4*(i-1)+2,])))
  hist(as.numeric(sp_resp_humppeak[4*(i-1)+2,]),main=paste0(sp_common_name[i]," \n not humped shape = ",no_not_hump),xlab ="",ylab="")
}
mtext("Peak location (mm)", side =1,outer= T,line=1)
mtext("Frequency", side =2,outer=T,line=1)
dev.off()

jpeg("./SizeAggregTend_data/output/fig/Appendix/Fig_bs_peaklocat_Q3.jpeg", width=6.5, height=5, units = "in",res=300)
par(mfrow=c(3,3),mar=c(2,2,4,2),oma=c(3,3,1,1))
for(i in 1:9) {
  no_not_hump = length(which(sp_resp_humppeak[4*(i-1)+4,]==max(sp_resp_humppeak[4*(i-1)+4,]) | sp_resp_humppeak[4*(i-1)+4,]==min(sp_resp_humppeak[4*(i-1)+2,])))
  hist(as.numeric(sp_resp_humppeak[4*(i-1)+4,]),main=paste0(sp_common_name[i]," \n not humped shape = ",no_not_hump),xlab ="",ylab="")
}
mtext("Peak location (mm)", side =1,outer= T,line=1)
mtext("Frequency", side =2,outer=T,line=1)
dev.off()

# slope

sp.resp_slope_Q1 = sp.resp_slope_Q1[,-1]
sp.resp_slope_est_Q1 = sp.resp_slope_Q1[,c(1,8,15)]
par(mfrow=c(3,3))
for(i in 1:9) {
  hist(sp.resp_slope_est_Q1[1000*(i-1)+1:1000*i,1],main=sp_common_name[i])
}
for(i in 1:9) {
  hist(sp.resp_slope_est_Q1[1000*(i-1)+1:1000*i,2],main=sp_common_name[i])
}
for(i in 1:9) {
  hist(sp.resp_slope_est_Q1[1000*(i-1)+1:1000*i,3],main=sp_common_name[i])
}

sp.resp_slope_Q3 = sp.resp_slope_Q3[,-1]
sp.resp_slope_est_Q3 = sp.resp_slope_Q3[,c(1,8,15)]
par(mfrow=c(3,3))
for(i in 1:9) {
  hist(sp.resp_slope_est_Q3[1000*(i-1)+1:1000*i,1],main=sp_common_name[i])
}
for(i in 1:9) {
  hist(sp.resp_slope_est_Q3[1000*(i-1)+1:1000*i,2],main=sp_common_name[i])
}
for(i in 1:9) {
  hist(sp.resp_slope_est_Q3[1000*(i-1)+1:1000*i,3],main=sp_common_name[i])
}


  convert.degdec2degmin = function (x) {
    x$lat = trunc(x$lat) + round(((x$lat - trunc(x$lat))/100) * 60, 6)
    x$lon = trunc(x$lon) + round(((x$lon - trunc(x$lon))/100) * 60, 6)
    return (x)
  }


#performing the statistical analyses described in the paper and creating the figures. Set threshold to the desired value below. Make sure the necessary packages (lmerTest etc) are installed, change the R directory to the Data folder.

library(lmerTest)
library(effsize)
library(ggplot2)
library(gridExtra)

langs <- c("Italian", "French","Spanish", "English")
threshold <- 200
for (lang in langs){
    print(lang)
    dataset <- read.csv(paste(lang, "_messages_ttrplain_tokenthr", threshold, "_msgthr1.csv", sep = ""),header=TRUE,sep="\t",dec=".",quote="")
    dataset$ltype <- as.factor(dataset$ltype)
    print("l1 vs l2")
    print(summary(lmer(ttr ~ ltype + (1|speaker) , data = dataset)))
    #boxplot(dataset[dataset$ltype == "L1",]$ttr, dataset[dataset$ltype == "L2",]$ttr)

    print("FDS")
    dataset2 <- read.csv(paste(lang, "_messagestowhom_ttrplain_tokenthr", threshold, "_msgthr1_onlysecondtrue.csv", sep = ""),header=TRUE,sep="\t",dec=".",quote="")
    dataset2a <- dataset2[dataset2$ltype == "L1",]
    dataset2b <- dataset2[dataset2$ltype == "L2",]
    print(summary(lmer(ttr ~ ltype * topicstarter_ltype + (1|speaker), data = dataset2)))

    if (lang == "Italian"){
      p1 <- ggplot(dataset, aes(x=ltype, y=ttr, fill=ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Speaker status")
      b1 <- ggplot(dataset2a, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
      c1 <- ggplot(dataset2b, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
    }
    if (lang == "French"){
      p2 <- ggplot(dataset, aes(x=ltype, y=ttr, fill=ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Speaker status")
      b2 <- ggplot(dataset2a, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
      c2 <- ggplot(dataset2b, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
    }
    if (lang == "Spanish"){
      p3 <- ggplot(dataset, aes(x=ltype, y=ttr, fill=ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Speaker status")
      b3 <- ggplot(dataset2a, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
      c3 <- ggplot(dataset2b, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
    }
    if (lang == "English"){
      p4 <- ggplot(dataset, aes(x=ltype, y=ttr, fill=ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Speaker status")
      b4 <- ggplot(dataset2a, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
      c4 <- ggplot(dataset2b, aes(x=topicstarter_ltype, y=ttr, fill=topicstarter_ltype)) + geom_violin(trim=FALSE) + geom_boxplot(width = 0.1) + theme(legend.position="none") + ggtitle(lang) + xlab("Topicstarter status")
    }

}

grid.arrange(p1,p2,p3,p4)
dev.new()
grid.arrange(b1,b2,b3,b4)
dev.new()
grid.arrange(c1,c2,c3,c4)


library("RColorBrewer")
library("circlize")
library("plyr")
library("shape") # for arrows
library(extrafont)
loadfonts()

rm(list=ls())
base_dir = 'C:\\Users\\ritvik\\Documents\\PhD\\Projects\\GLM\\Output\\GLM\\LUH2_v1h_beta\\'
file_name = 'df_trans.csv'
col_type = 'Set1'

reg = c('crop',	'pastr',	'primf',	'primn',	'range',	'secdf',	'secdn',	'urban')

num_reg = length(reg)

circ<- matrix(data=0.0,nrow=num_reg,ncol=num_reg,byrow=TRUE)
diag(circ) <- 100.0

matrix1 <-read.table(paste(base_dir,file_name,sep=""), header=T, row.names=1,sep=",")
m <- as.matrix(matrix1)
dimnames(m) <- NULL
tiff(file=paste(base_dir,"Activity_Matrix.tiff",sep=""), family='Arial',width=4,height=4,units="in",res=400)
# Convert all diagonal elements to 0
#diag(m) <- 0.0
# Put all negative elements to 0
#m[m<0.0] <- 0.0
# Normalize
#reg_sum <- sum(m)
#m <- m*100./reg_sum
# Put all below threshold elements to 0
#m[m<1.0] <- 0.0
rownames(m) = reg
colnames(m) = reg
chordDiagram(m, grid.col=brewer.pal(num_reg,col_type), annotationTrack = "grid",
             preAllocateTracks = list(track.height = 0.3))
circos.trackPlotRegion(track.index = 1, panel.fun = function(x, y) {
  xlim = get.cell.meta.data("xlim")
  ylim = get.cell.meta.data("ylim")
  sector.name = get.cell.meta.data("sector.index")
  circos.text(mean(xlim), ylim[1], sector.name, facing = "clockwise",
              niceFacing = TRUE, adj = c(0, 0.5))
}, bg.border = NA) # here set bg.border to NA is important
Arrows(0.56,-0.31,0.34,-0.13,col='black',lwd=1.0,arr.lwd=1.0)

dev.off()


#  James Rekow

DOCNSSelector = function(doc){

  #  ARGS: doc - input doc
  #
  #  RETURNS: docNS - doc with points outside the NS region (region of OD plane with
  #                   overlap < xns) removed

  source("trimmer.r")
  source("firstDeriv.r")
  source("changePointComputer.r")

  #  pass NULL inputs through the function (in case a doc with value NULL was produced)
  if(is.null(doc)){
    return(NULL)
  } #  end if

  #  extract overlap and dissimilarity vectors
  over = doc[[1]]
  diss = doc[[2]]

  #  grid of overlap values on which derivatives and means will be computed
  x = seq(0, 1, 10 ^ (-4))

  #  create a DOC curve fitting the points in the DOC plane
  smoothDOC = lowess(over, diss, f = 0.2)

  #  trim redundant values in the x and y elements of the lowess object (e.g. if an (x, y) point
  #  is repeated multiple times, remove duplicates)
  #  needed so we can use approx in the next step
  smoothDOC = trimmer(smoothDOC)

  #  approximate the values of the DOC curve on the grid of overlap values x
  smoothDOC = approx(smoothDOC$x, smoothDOC$y, xout = x, method = "linear", rule = 2)

  #  compute centered first derivative of the DOC curve
  firstDeriv = firstDeriv(smoothDOC$y, 10 ^ (-4))

  #  TEST (remove this after NULL check?)
  if(length(firstDeriv) == 0) print(firstDeriv)

  #  compute change point
  changePoint = changePointComputer(firstDeriv)

  #  if an error was generated in changePointComputer and NULL was output, carry NULL through this
  #  function
  if(is.null(changePoint)){
    return(NULL)
  } #  end if

  #  compute xns, the maximal overlap value such that the DOC curve has a negative slope for all overlap
  #  values greater than or equal to xns
  xns = smoothDOC$x[changePoint]

  #  select the indices of the overlap vector whose corresponding elements are in the NS region (greater
  #  than or equal to xns)
  NS = over >= xns

  #  select the overlap and dissimilarity values in the NS region
  overNS = over[NS]
  dissNS = diss[NS]

  #  create a new data frame with the NS values
  docNS = data.frame(x = overNS, y = dissNS)

  return(docNS)

} #  end DOCNSSelector function


#Récupération des données dans une liste
data=c(12, 9, 6, 13, 10, 9, 8, 16, 11, 17, 9, 9, 16, 13, 17, 9, 14)

# Résumer intéressant des principales caractéristiques de la série
summary(data)

# Histogramme
hist(data,breaks=17,col="red")

# Nuage de points
dotchart(data)
plot(data)

# Diagramme en baton
barplot(data)


#!/usr/bin/env Rscript

data = read.csv("hw1_data.csv")
ozone = data[['Ozone']]
nonMissingFilter = !is.na(ozone)
mean(ozone[nonMissingFilter])


#' @title Rsquared_glm
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  Rsquared_glm <- function(o) {
    typ <- matrix(c(
            "Logit: log(mu/(1 - mu))",
            "Log: log(mu)",
            "Identity: mu",
            "Binomial: mu(1-mu)",
            "Identity: mu",
            "Constant: 1"
            ), 2, 3, byrow=T)
    # typ is matrix of supported link and variance combinations

    # Remainder of code is for binomial and poisson families
    # (perhaps with provision for overdispersion)

    n <- length(o$residuals) # number of observations

    R2 <- ( 1 - exp( (o$deviance - o$null.deviance)/n ) ) / ( 1 - exp( -o$null.deviance/n ) )
    names(R2) <- "pseudo.Rsquared"
    R2
  }