#import libraries
library(tidyverse)
library(boot)
library(stringr)
library(lubridate)
library(DT)
library(leaflet)
library(caret)
library(corrplot)
library(ggplot2)
library(ggmap)
library(randomcoloR)
library(scatterplot3d)
library(RColorBrewer)
library(randomForest)
library(leaps)
library(rpart)
library(rpart.plot)

fillColor = "#FFA07A"
fillColor2 = "#F1C40F"

#import the dataset
kc_house<-read.csv("kc_house_data.csv")

#TODO: dove abbiamo preso i dati, spiegare ogni colonna cosa significa

#check the dimension of the dataset
dim(kc_house)

#convert date from string to observation number of the day (starting from 1)
new.date<-as.Date(kc_house$date,'%Y%m%d')
new.date<-new.date-(sort(new.date))[1]

#We add this column to the dataset instead of the original one
kc_house[2]<-as.numeric(new.date)
kc_house

# We note that there are some duplicated id (a ID is linked to a specific house), that are less
# than 1% of the data. Hence, since we want to keep the latest evaluation of the houses, we get
# rid of the previous price of the house (the house have been, in the meantime, renovated and this
# effect are not registered in the dataset).
kc_house <- kc_house[order(kc_house$date, decreasing = TRUE), ]

kc_house<-kc_house[!duplicated(kc_house$id),]
#our observation is confirmed by this check
#hence, id not useful to understand data and to predict
kc_house<-kc_house[-1]
kc_house

# kc_house
dim(kc_house)
kc_house

#we now take into account the column "yr_renovated": this column express the year of the last renovation of the
#house. Since the null values are coded as 0 and the other are coded as a year, this two are not very consistent and
#so we want to transform this column into a feature that express the year of the last renovation: if no renovation
#is done on a house, we use the year of construction.

#we firtsly check that there are no errors in the data, i.e. year of renovation smaller than year of construction.
any(kc_house$yr_built>kc_house$yr_renovated && kc_house$yr_renovated!=0)

#since there are no errors, we now want to substitute the "yr_renovated" feature with the year of the last renovation
#or, if not present, the year of construction.
mask<-kc_house$yr_renovated==0
mask
ylr<-kc_house$yr_renovated
ylr[mask]<-kc_house$yr_built[mask]
ylr

#rename the column
kc_house["yr_renovated"]<-ylr

colnames(kc_house)[15]<-"yr_last_renovation"
length(kc_house$yr_last_renovation)
#move the target feature (price) to the last column
kc_house<-kc_house[,c("date", "bedrooms", "bathrooms", "sqft_living","sqft_lot", "floors", "waterfront","view","condition",
           "grade", "sqft_above", "sqft_basement", "yr_built", "yr_last_renovation", "zipcode",  "lat", "long","sqft_living15",
           "sqft_lot15", "price")]

kc_house

#EXPLORING DATA

#The grade is a classification by construction quality which refers to the types of materials used and the quality
#of workmanship. Buildings of better quality (higher grade) cost more to build per unit of measure and command
#higher value (https://info.kingcounty.gov/assessor/esales/Glossary.aspx?type=r#g). For this reason it is a
#value (from 1 to 13) established before and independently wrt the price of the house; so, it makes sense to keep it in
#the dataset to predict the price of the house.
#First of all, we note that the column "bathrooms" has real (and not only integer) values: this is because
#it expresses the #bathroom/#bedrooms.
#Moreover, also the column "floors" has float values: this is because there can be "partial" (half) floors (like
#the mansard) that cannot be considered as a whole floor.
#Condition is a value from 1 to 5 that expresses the condition state of the house.
#sqft_living is the sum of sqft_above + sqft_basement

#we start the exploration of the data with an overall numerical summary
summary(kc_house)

#we notice that the maximum number of bedrooms is 33, a very high number. Moreover we note that this house
#must have also 33*1.75 bathrooms, which is 57 total bathrooms, i.e. 90 total rooms (excluding other possible
#spaces.)
#We want to see the other values of that row, that are the values of that house.
kc_house[kc_house$bedrooms==33,]
boxplot(kc_house$bedrooms)
# We note that the total living space is 1620 square feet, equal to about 150 m^2. This would imply that each room has a mean of 1.66 m^2,
#which is clearly impossible. So, there must be some errors in the reporting of the data (the number of
#bedrooms could be 3 for example).

#So, we decide to delete that row.

kc_house<-kc_house[kc_house$bedrooms<33,]
dim(kc_house)

#In general, we want to check the mean square footage of the rooms per each house, to see if there are
#other unlikely values as the previous one.

#Define the mean dimension of a room in a house, in squared meters
mean_sqm<-(kc_house$sqft_living/(kc_house$bedrooms+(kc_house$bedrooms*kc_house$bathrooms)))/10.764
length(mean_sqm)
#we note that there are some infinite values due to the fact that there are no bedrooms and bathrooms in
#that building. So, we want to boxplot the mean_sqft excluding those houses.

boxplot(mean_sqm[mean_sqm<Inf])
min(mean_sqm)

#We see that now the minimum value of the mean square meters of the rooms in a house is 3 times the
#previous, so we have no evidence that this is an unlikely value.

#using the lm function, we notice an issue in the outcome of the summary
model<-lm(kc_house$price ~ ., data=kc_house)
summary(model)

#From the summary of the model we have just applied we can see that the coefficient of the column
#"sqft_basement" are labeled as NA: this is because there is a collinearity between that feature and
#the two column "sqft_living" and "sqft_above". In fact, "sqft_basement" = "sqft_living" - "sqft_above".
#We give the proof of that:

sqft_diff<-kc_house$sqft_living-(kc_house$sqft_basement + kc_house$sqft_above)
any(sqft_diff!=0)

#As we notice, all the values in "sqft_diff" are zero.
#So, for the prediction we get rid of the feature "sqft_basement" because it doesn't add any valuable
#information wrt to what we know from the other two columns.

#we delete the column sqft_basement because it add no infos and it can be add in future if we want (lossless delete)
kc_house<-kc_house[,-12]
kc_house<-kc_house[,c("date", "bedrooms", "bathrooms", "sqft_living","sqft_lot", "floors", "waterfront","view","condition",
                      "grade", "sqft_above", "yr_built", "yr_last_renovation",  "lat", "long","sqft_living15",
                      "sqft_lot15", "price")]
summary(kc_house)

#we plot the distribution of sqft_lot
hist(kc_house$sqft_lot, breaks=30,main= "sqft_lot distribution", xlab = "sqft_lot")
hist(kc_house$sqft_lot15, breaks=30,main= "sqft_lot15 distribution", xlab = "sqft_lot15")
#we can see that this feature has a really bad distribution, so we can try applying the log10 to it.
kc_house[5]<-log10(kc_house$sqft_lot)
kc_house[17]<-log10(kc_house$sqft_lot15)

hist(kc_house$sqft_lot, breaks=30, main = "log(sqft_lot) distribution", xlab= "sqft_lot")

#We want to see the type of houses we're dealing with; thus, we check the distribution of the grade of the
#houses and we compare it to a normal distribution.
hist(kc_house$price, breaks = 30, main = "Price frequency", xlab="Price")

out_threshold<-min(boxplot(kc_house$price)$out)

# We are cutting out 5% of the data (outliers) that are not representative wrt to the type
# of houses our predictor has to deal with
dim(kc_house[kc_house$price>out_threshold,])[1]/dim(kc_house)[1]*100
kc_house<-kc_house[kc_house$price<out_threshold,]
dim(kc_house)

hist(kc_house$price, breaks=100)
qqnorm(kc_house$price)

#Instead, if we would consider the log10 transformation of the target value, the distribution
#becomes really close to a Normal one. We are going to use this later.
qqnorm(log10(kc_house$price))
#we also log the price
kc_house[18]<-log10(kc_house[18])
hist(kc_house$price, breaks = 30, main= "Frequency of log(price)", xlab = "log(price)")
dim(kc_house)

# Plot correlation between covariates
par(mfrow=c(1,1))
corrplot(cor(kc_house))

attach(kc_house)

# MAP
# Set location bounds (King County)
location <- c(-140, 35, -90, 57)
# Fetch the map (osm = OpenStreetMap)
points.kc <- get_map(location=location, source="osm")
# Draw the map
map.kc <- ggmap(points.kc)
# Add the points layer
map.kc <- map.kc + geom_point(data = kc_house, aes(x = kc_house$long, y = kc_house$lat), size = .0001)
# Plot map
map.kc

# More zoom
# Set location bounds (King County)
location <- c(-123.25, 47.15, -121.25, 47.9)
# Fetch the map (osm = OpenStreetMap)
points.kc <- get_map(location=location, source="osm")
# Draw the map
map.kc <- ggmap(points.kc)
# Add the points layer
map.kc <- map.kc + geom_point(data = kc_house, aes(x = kc_house$long, y = kc_house$lat), size = .0001)
# Plot map
map.kc

# Print a table containing correlation between covariables
cor(kc_house)

# DATE (cor=-0.00570)
# We notice we have a continuous detection for the dates: almost every day (starting from the initial one)
# there are some house sold and so we don't have time intervals in which values of price are not present,
# as we can see from this plot.
plot(sort(date))
# Plot of price as a function of the date
plot(price~date, main="Price by date")
# Plot using boxplot to gain more information about the correlation between price and date
boxplot(price~sort(date), main="Price by date")
# To see in a better way the data, we can average for each date the prices of the houses sold in that
# day. Obviously we get an approximation, but this is not a big deal having a lot of examples (about 60
# per day) and this allows us to see really data in a nicer way.
average_price_bydate <-aggregate(price~date, FUN=mean, data=kc_house)
plot(average_price_bydate, col=1,main="Average price by date")
lines(loess.smooth(date, price), col=2, lty=5)
# Hence, the date does not influence much the price

# BEDROOMS (cor=0.35100546)
boxplot(price~bedrooms, xlab="bedrooms", ylab="price",main="Price by bedrooms")
# We see that the greater the number of bedrooms, the greater the price. Also we can notice that
# there is a big number of outliers in the upper part for values of bedrooms in the range 2-6.

kc_house %>%
  group_by(bedrooms) %>%
  summarise(PriceMedian = median(10**(price), na.rm = TRUE)) %>%
  ungroup() %>%
  mutate(bedrooms = reorder(bedrooms,PriceMedian)) %>%
  arrange(desc(PriceMedian)) %>%

  ggplot(aes(x = bedrooms,y = PriceMedian)) +
  geom_bar(stat='identity',colour="white", fill = "lightblue") +
  geom_text(aes(x = bedrooms, y = 1, label = paste0(" ",PriceMedian, sep="")),
            hjust=0, vjust=.5, size = 4, colour = 'black',
            fontface = 'bold') +
  labs(x = 'bedrooms',
       y = 'Median Price',
       title = 'Median price per number of bedrooms') +
  coord_flip() +
  theme_bw()

#BATHROOMS (cor=0.55082290)
boxplot(price~bathrooms, xlab="bathrooms", ylab="price",main="Price by bathrooms")
# Also in this case, and more than for the previous one, it is clear that if we increase the number of
# bathrooms, also the price increases.

kc_house %>%
  group_by(bathrooms) %>%
  summarise(PriceMedian = round(median(10**(price)),0), na.rm = TRUE) %>%
  ungroup() %>%
  mutate(bathrooms = reorder(bathrooms,PriceMedian)) %>%
  arrange(desc(PriceMedian)) %>%
  head(10) %>%

  ggplot(aes(x = bathrooms,y = PriceMedian)) +
  geom_bar(stat='identity',colour="white", fill = fillColor2) +
  geom_text(aes(x = bathrooms, y = 1, label = paste0(" ", PriceMedian, sep="")),
            hjust=0, vjust=.5, size = 4, colour = 'black',
            fontface = 'bold') +
  labs(x = 'bathrooms', y = 'Median Price', title = 'Median Price per number of bathrooms') +
  coord_flip() +
  theme_bw()

# SQFT_LIVING (cor=0.69536476)
plot(price~sqft_living,main="Price by sqft_living")
lines(loess.smooth(sqft_living, price), col=3)
# Check averages instead of actual data
average_price_bysqftliving <-aggregate(price~sqft_living, FUN=mean, data=kc_house)
plot(average_price_bysqftliving, col=1,main="Average price by living area")
lines(loess.smooth(sqft_living, price), col=3)
# Also in this case there is an evident association between the dimensions of the living area and the price.

# SQFT_LOT (cor=0.09962940)
plot(price~sqft_lot)
# Apply the aggregate function
average_price_bysqftlot <-aggregate(price~sqft_lot, FUN=mean, data=kc_house)
plot(average_price_bysqftlot, col=1,main="Average price by lot dimension")
lines(loess.smooth(sqft_lot, price), col=3)
# The plot shows that This feature does not influence so much the targe

# FLOORS (cor= 0.31059266)
boxplot(price~floors, xlab="floors", main="Price by floor")
# There is a little increase in the median price as floors increase, but not so much

# WATERFRONT (cor=0.17459026)
boxplot(price~waterfront, xlab="waterfront", main="Price by waterfront")

# VIEW (cor= 0.34653430)
boxplot(price~view, xlab="view", main="Price by view")
# The plot shows that there is a correlation between the covariate view and price

# CONDITION (cor= 0.03949428)
boxplot(price~condition, xlab="condition", main="Price by condition")

# GRADE (cor= 0.70366105)
boxplot(price~grade, xlab="grade", main="Price by grade")
# The plot shows that the grade has a strong correlation with the target

# We suspect correlation between GRADE and almost every other covariate
# since GRADE is the mark given by an expert after evaluating many aspects of an house.
# Hence, we try to fit a linear model in order to predict the grade using every covariate, except from price
lm_grade <- lm(grade ~ . -price -sqft_lot15 -date, data=kc_house)
summary(lm_grade)

kc_house %>%
  group_by(grade) %>%
  # summarise(PriceMedian = median(10**(price)), na.rm = TRUE) %>%
  summarise(PriceMedian = round(median(10**(price),2)), na.rm = TRUE) %>%
  ungroup() %>%
  mutate(grade = reorder(grade,PriceMedian)) %>%
  arrange(desc(PriceMedian)) %>%

  ggplot(aes(x = grade,y = PriceMedian)) +
  geom_bar(stat='identity',colour="white", fill = fillColor) +
  geom_text(aes(x = grade, y = 1, label = paste0(" ",PriceMedian, sep="")),
            hjust=0, vjust=.5, size = 4, colour = 'black',
            fontface = 'bold') +
  labs(x = 'Grade',
       y = 'Median price',
       title = 'Grade and median price') +
  coord_flip() +
  theme_bw()

# SQFT_ABOVE(cor=0.60184347)
plot(price~sqft_above)
# Check average values instead of median
average_price_bysqftabove <-aggregate(price~sqft_above, FUN=mean, data=kc_house)
plot(average_price_bysqftabove, col=1,main="Average price by above dimension")
lines(loess.smooth(sqft_above, price), col=5)
# The plot shows that price is linearly dependent from the feature sqft_above

# YR_BUILT (cor=0.08067957)
plot(price~yr_built)
lines(loess.smooth(yr_built, price), col=5)
# Plot using the means
average_price_yb <-aggregate(price~yr_built, FUN=mean, data=kc_house)
plot(average_price_yb, col=1,main="Average price by construction year", ylim=c(5,6.5))
lines(loess.smooth(yr_built, price), col=5)
# Previous plots shows that there is no linear relationship between when an house has been built and its price

# YR_LAST_RENOVATION (cor=0.13032651)
plot(price~yr_last_renovation)
lines(loess.smooth(yr_last_renovation, price), col=5)
# Plot using the means
average_price_ylr <-aggregate(price~yr_last_renovation, FUN=mean, data=kc_house)
plot(average_price_ylr, col=1,main="Average price by year of last renovation", ylim=c(4.9,6.7))
lines(loess.smooth(yr_last_renovation, price), col=5)

# LAT (cor=0.44916082)
plot(price~lat)
lines(loess.smooth(lat, price), col=5)
# Plot using the means
average_price_lat <-aggregate(price~lat, FUN=mean, data=kc_house)
plot(average_price_lat, col=1,main="Average price by lat")
lines(loess.smooth(lat, price), col=5)
# The plot shows that latitude and price are quite correlated

# LONG (cor=0.04996692)
plot(price ~ long)
lines(loess.smooth(long, price), col=5)
# Plot using the means
average_price_long <-aggregate(price~long, FUN=mean, data=kc_house)
plot(average_price_long, col=1,main="Average price by long")
lines(loess.smooth(long, price), col=5)
# The logitude seems to be less correlated with price

# ZIPCODE (cor=0.03831967)
# plot(price~zipcode)
# lines(loess.smooth(zipcode, price), col=5)
# Plot using the means
# average_price_zc <-aggregate(price~zipcode, FUN=mean, data=kc_house)
# plot(average_price_zc, col=1,main="Average price by zipcode", ylim=c(5,6.8))
# lines(loess.smooth(zipcode, price), col=5)
# Plots using boxplots
# boxplot(price~zipcode)
#
# # Since we suspect a strong correlation between LONG, LAT and ZIPCODE, we plot them on the map
# # There are 70 zipcodes
# n_zipcodes <- length(unique(zipcode))
# # Define colors scheme (randomly)
# set.seed(3)
# # Select one different color per zipcode
# palette <- randomColor(n_zipcodes)
# # Set location bounds (King County)
# location <- c(-123.25, 47.15, -121.25, 47.9)
# # Fetch the map (osm = OpenStreetMap)
# map <- get_map(location=location, source="osm")
# # Plot the points on the map using lat and long, while the color is given by the zipcode
# plt <- ggmap(map)
# plt <- plt + geom_point(data=kc_house, aes(x=long, y=lat, col=as.factor(zipcode)))
# plt <- plt + theme(legend.position='none')
# plt <- plt + scale_colour_manual(values=palette)
# plt
#
# # We hence try to fit a linear model to predict correlation between LONG, LAT and ZIPCODE
# lm_zipcode <- lm(zipcode ~ long + lat, data=kc_house)
# summary(lm_zipcode)
# The linear model does not provide a significantly high R squared value, hence we can keep all the variables

# PRICE with respect to LAT and LONG
# Get colors for labeling the points
plotvar <- kc_house$price # pick a variable to plot
nclr <- 8 # number of colors
plotclr <- brewer.pal(nclr, "PuBu") # get the colors
colornum <- cut(rank(plotvar), nclr, labels=FALSE)
colcode <- plotclr[colornum] # assign color
plot.angle <- 70
# 3D Scatter plot
scatterplot3d(kc_house$long, kc_house$lat, plotvar, type="h", angle=plot.angle, color=colcode, pch=20, cex.symbols=2,
              col.axis="gray", col.grid="gray", xlab="Longitude", ylab="Latitude", zlab="Price",
              main="Price as a function of latitude and longitude")

#We plot the houses in the map
bins<-cut(kc_house$price, c(0,log10(250e3),log10(500e3),log10(750e3),log10(1e6),log10(2e6)))

center_lon = median(kc_house$long,na.rm = TRUE)
center_lat = median(kc_house$lat,na.rm = TRUE)

factpal <- colorFactor(c("black","blue","yellow","orange","#0B5345"),
                       bins)

leaflet(kc_house) %>% addProviderTiles("Esri.NatGeoWorldMap") %>%
  addCircles(lng = ~long, lat = ~lat,
             color = ~factpal(bins))  %>%
  # controls
  setView(lng=center_lon, lat=center_lat,zoom = 12) %>%

  addLegend("bottomright", pal = factpal, values =~bins,
            title = "House Price Distribution",
            opacity = 1)

PriceBinGrouping = function(limit1, limit2)
{
  return(

    kc_house%>%
      filter(price > limit1) %>%
      filter(price <= limit2)
  )
}

PriceGroup1 = PriceBinGrouping(0,log10(250e3))
PriceGroup2 = PriceBinGrouping(log10(250e3),log10(500e3))
PriceGroup3 = PriceBinGrouping(log10(500e3),log10(750e3))
PriceGroup4 = PriceBinGrouping(log10(750e3),log10(1e6))
PriceGroup5 = PriceBinGrouping(log10(1e6),log10(2e6))

MapPriceGroups = function(PriceGroupName,color)
{
  center_lon = median(PriceGroupName$long,na.rm = TRUE)
  center_lat = median(PriceGroupName$lat,na.rm = TRUE)

  leaflet(PriceGroup2) %>% addProviderTiles("Esri.NatGeoWorldMap") %>%
    addCircles(lng = ~long, lat = ~lat,
               color = ~c(color))  %>%
    # controls
    setView(lng=center_lon, lat=center_lat,zoom = 12)
}
#to show the houses of that group, do for example:
MapPriceGroups(PriceGroup1,"black")
MapPriceGroups(PriceGroup2,"blue")
MapPriceGroups(PriceGroup3,"yellow")
MapPriceGroups(PriceGroup4,"orange")
MapPriceGroups(PriceGroup5,"#0B5345")

# SQFT_LIVING_15 (cor=0.61935746)
plot(price~sqft_living15)
lines(loess.smooth(sqft_living15, price), col=3)
# Plot using means
average_price_l15 <-aggregate(price~sqft_living15, FUN=mean, data=kc_house)
plot(average_price_l15, col=1,main="Average price by sqft_living15")
lines(loess.smooth(sqft_living15, price), col=5)
# The plot shows that price and sqft_living are strictly correlated

# SQFT_LOT15 (cor=0.09160121)
plot(price~log10(sqft_lot15))
lines(loess.smooth(log10(sqft_lot15), price), col=3)
# Plot using means
average_price_lot15 <-aggregate(price~sqft_lot15, FUN=mean, data=kc_house)
plot(average_price_lot15, col=1,main="Average price by sqft_lot15")
lines(loess.smooth(sqft_lot15, price), col=5)

# WHAT ARE MOST IMPORTANT FEATURE TO PREDICT THE PRICE?
# We try to answer the question looking at the features that causes the greatest decrease in
# the R2 value, repeating the process iteratively for each feature.
# Linear model of price against every feature
model <- lm(price~ ., data=kc_house)
sm <- summary(model)

# Definition of an empty matrix which contains model, R2, adjusted R2
models <- matrix(data=NA, nrow=17, ncol=5, dimnames=list(c(), c('deleted', 'r2', 'adj.r2', 'diff.r2', 'diff.adj.r2')))
# Define the features names
features <- colnames(kc_house)[-18]
# Loop through every model combination without a single feature
for(i in 1:length(features)) {
  # Define a linear model without the current feature
  curr_model <- lm(as.formula(paste('price ~ . -', features[i], sep='')), data=kc_house)
  # Save the summary
  curr_sm <- summary(curr_model)
  # Save deleted feature, r2 and adjusted r2
  models[i,1] <- features[i]
  models[i,2] <- curr_sm$r.squared
  models[i,3] <- curr_sm$adj.r.squared
  # Add difference between previous and current r2 and adjusted r2
  models[i,4] <- sm$r.squared - curr_sm$r.squared
  models[i,5] <- sm$adj.r.squared - curr_sm$adj.r.squared
}

# table for visualisation of results
# View(models)
# Find the feature which causes the greatest decrease in R2 value when deleted
models[which.max(models[,4]),1]
# Order the matrix by r2 difference
models <- models[order(as.numeric(models[,4]), decreasing=TRUE),]
# Show models
# fix(models)
# Plot the features "importance"
plot(models[,4], xlab="", ylab="R2 difference", main="Feature importance by R2 reduction", xaxt='n', type='p')
# Add labels
axis(1, at=1:length(models[,1]), labels=models[,1], las=2)

#Calculation of variable importance for regression in another way
fitControl <- trainControl(method="cv",number = 10)
model_1 = train(price~ ., data = kc_house, method = "lm",trControl = fitControl,metric="RMSE")
importance_model_1 = varImp(model_1)

# we then plot

PlotImportance = function(importance)
{
  varImportance <- data.frame(Variables = row.names(importance[[1]]),
                              Importance = round(importance[[1]]$Overall,2))

  # Create a rank variable based on importance
  rankImportance <- varImportance %>%
    mutate(Rank = paste0('#',dense_rank(desc(Importance))))

  rankImportancefull = rankImportance

  ggplot(rankImportance, aes(x = reorder(Variables, Importance),
                             y = Importance)) +
    geom_bar(stat='identity',colour="white", fill=fillColor) +
    geom_text(aes(x = Variables, y = 1, label = Rank, color="blue"),
              hjust=0, vjust=.5, size = 4, colour = 'black',
              fontface = 'bold') +
    labs(x = 'Variables', title = 'Relative Variable Importance') +
    coord_flip() +
    theme_bw()
}

PlotImportance(importance_model_1)

# The same result can be achieved looking at the decision tree fitted on the data
fit <- rpart(price~ ., data = kc_house)
rpart.plot(fit, digits = 3)

# we can notice, in fact, that the last two features (sqft_above, long) are the first to be
# deleted when doing backward variable selection!

# Plot of price as function of the covariates, taken one by one
# Note that heare only the best 7 covariates, by importance given by r2 difference, are taken
pairs(price ~ lat + grade + yr_built + sqft_living + sqft_living15 + condition + view, data=kc_house)

##########
# BACKWARD FEATURE SELECTION

#Define the random seed (otherwise we cannot repeat exactly the same experiment)
set.seed(29)
#try to evaluate performance of different models splitting the whole set into training-validation-test set
id.train<-createDataPartition(price, p=.90, list=FALSE)
train_set<-kc_house[id.train,] #90
test_set<-kc_house[-id.train,] #10

par(mfrow=c(1,2))
boxplot(train_set$price, main="Train", ylim=c(4.5,7))
boxplot(test_set$price, main="Test", ylim=c(4.5,7))
par(mfrow=c(1,1))

# We want to find the best model of grade 1: first of all we try considering the 18 best models
# (one for each number of variables) and then with the step function, using Schwarz Information Criterion as metrics.
# We then also find the best models of grade 2-5 with the step function using BIC.

# grade 1

#we want to find the best model to predict, so first of all we find the best model for each
#number of covariates, then we apply a 10-fold Cross Validation to see which of those
#has the smaller error in the prediction

#maximum number of predictors
max_var=17

#find the best model per number of predictors
regfit.best <- regsubsets(price~ ., data=train_set, nvmax=max_var, method="backward")
reg.summary <- summary(regfit.best)

# K-fold cross-validation
predict.regsubsets <- function(object, newdata, id, ...){
  form <- as.formula(object$call[[2]])
  mat <- model.matrix(form, newdata)
  coefi <- coef(object,id=id)
  xvars <- names(coefi)
  mat[,xvars]%*%coefi
}

k=10
set.seed(1)
folds <- sample(1:k, dim(train_set)[1], replace=TRUE)
cv.errors <- matrix(NA, k, max_var, dimnames=list(NULL, paste(1:max_var)))

for(j in 1:k){
  best.fit <- regsubsets(price~ ., data=train_set[folds!=j,], nvmax=max_var)

  for(i in 1:max_var){
    pred <- predict(best.fit, train_set[folds==j,], id=i)
    cv.errors[j,i] <- sqrt(mean((train_set$price[folds==j]-pred)^2))
  }
}

plot(reg.summary$rss,xlab="Number of Variables",ylab="RSS",type="l")
points(which.min(reg.summary$rss),reg.summary$rss[which.min(reg.summary$rss)], col="red",cex=2,pch=20)

plot(reg.summary$adjr2,xlab="Number of Variables",ylab="Adjusted RSq",type="l")
which.max(reg.summary$adjr2)
points(which.max(reg.summary$adjr2),reg.summary$adjr2[which.max(reg.summary$adjr2)], col="red",cex=2,pch=20)

plot(reg.summary$cp,xlab="Number of Variables",ylab="Cp",type='l')
plot(reg.summary$bic,xlab="Number of Variables",ylab="BIC",type='l')

mean.cv.errors <- apply(cv.errors, 2, mean)

#vector of mean errors
mean.cv.errors

#number of variables in the best model
which.min(mean.cv.errors)

#error with the best model (17 variables)
mean.cv.errors[which.min(mean.cv.errors)]

plot(mean.cv.errors, type="l", main="RMSE for each model", xlab="Number of variables in the model",
     ylab = "RMSE")
points(which.min(mean.cv.errors), mean.cv.errors[which.min(mean.cv.errors)], col=2, pch=16)
#######

# We try to find the best model for each grade of polynomial

# Set n as training set dimension
n <- dim(train_set)[1]

# grade 1

# We try with BIC
full.mod <- lm(price~ ., data=train_set)
step.mod <- step(full.mod, steps=1000, k=log(n), trace=1, direction="backward")
formula1 <- step.mod$call$formula

# Try using the AIC as metric for the selection

# full.mod <- lm(price~ ., data=train_set)
# step.mod <- step(full.mod, steps=1000, trace=1, direction="backward")
#
# formula1 <- step.mod$call$formula
model1 <- lm(formula1, data=train_set)
par(mfrow=c(2,2))
plot(model1)

# NOTE: the BIC penalize more in the number of variables (the optimal number according to BIC is
# 16), while with AIC we get the a model with one more variable.

# cv.glm function: The data is divided randomly into K groups. For each group the
# linear model is fit to data omitting that group, then the function cost (by default the
# average squared error function) is applied to the observed responses in the group
# that was omitted from the fit and the prediction
# made by the fitted models for those observations.
set.seed(17)
glm.fit <- glm(formula1,data=train_set)
cv.error1 <- cv.glm(train_set, glm.fit, K=10, cost=RMSE)$delta[1]
cv.error1

# We then proceed trying to find the best model for each degree of the polynomial
#grade 2
full.mod <- lm(price~date+I(date^2)+
              +bedrooms+I(bedrooms^2)+
              +bathrooms+I(bathrooms^2)
              +sqft_living+I(sqft_living^2)
              +sqft_lot+I(sqft_lot^2)
              +floors+I(floors^2)
              +waterfront
              +view+I(view^2)
              +condition+I(condition^2)
              +grade+I(grade^2)
              +sqft_above+I(sqft_above^2)
              +yr_built+I(yr_built^2)
              +yr_last_renovation+I(yr_last_renovation^2)
              +lat+I(lat^2)
              +long+I(long^2)
              +sqft_living15+I(sqft_living15^2)
              +sqft_lot15+I(sqft_lot15^2),
              data=train_set)
step.mod <- step(full.mod, steps=100, trace=1, k=log(n),direction="backward")
formula2<-step.mod$call$formula

set.seed(17)
glm.fit <- glm(formula2,data=train_set)
cv.error2 <- cv.glm(train_set,glm.fit,K=10, cost=RMSE)$delta[1]
cv.error2

#grade 3
full.mod <- lm(price~date+I(date^2)+I(date^3)+
            +bedrooms+I(bedrooms^2)+I(bedrooms^3)+
            +bathrooms+I(bathrooms^2)+I(bathrooms^3)
            +sqft_living+I(sqft_living^2)+I(sqft_living^3)
            +sqft_lot+I(sqft_lot^2)+I(sqft_lot^3)
            +floors+I(floors^2)+I(floors^3)
            +waterfront
            +view+I(view^2)+I(view^3)
            +condition+I(condition^2)+I(condition^3)
            +grade+I(grade^2)+I(grade^3)
            +sqft_above+I(sqft_above^2)+I(sqft_above^3)
            +yr_built+I(yr_built^2)+I(yr_built^3)
            +yr_last_renovation+I(yr_last_renovation^2)+I(yr_last_renovation^3)
#           +zipcode+I(zipcode^2)+I(zipcode^3)
            +lat+I(lat^2)+I(lat^3)
            +long+I(long^2)+I(long^3)
            +sqft_living15+I(sqft_living15^2)+I(sqft_living15^3)
            +sqft_lot15+I(sqft_lot15^2)+I(sqft_lot15^3),
            data=train_set)
step.mod <- step(full.mod, steps=100, trace=1, k=log(n),direction="backward")
formula3<-step.mod$call$formula

set.seed(17)
glm.fit <- glm(formula3,data=train_set)
cv.error3 <- cv.glm(train_set, glm.fit, K=10, cost=RMSE)$delta[1]
cv.error3

#grade 4
full.mod <- lm(price~date+I(date^2)+I(date^3)+I(date^4)
            +bedrooms+I(bedrooms^2)+I(bedrooms^3)+I(bedrooms^4)
            +bathrooms+I(bathrooms^2)+I(bathrooms^3)+I(bathrooms^4)
            +sqft_living+I(sqft_living^2)+I(sqft_living^3)+I(sqft_living^4)
            +sqft_lot+I(sqft_lot^2)+I(sqft_lot^3)+I(sqft_lot^4)
            +floors+I(floors^2)+I(floors^3)+I(floors^4)
            +waterfront
            +view+I(view^2)+I(view^3)+I(view^4)
            +condition+I(condition^2)+I(condition^3)+I(condition^4)
            +grade+I(grade^2)+I(grade^3)+I(grade^4)
            +sqft_above+I(sqft_above^2)+I(sqft_above^3)+I(sqft_above^4)
            +yr_built+I(yr_built^2)+I(yr_built^3)+I(yr_built^4)
            +yr_last_renovation+I(yr_last_renovation^2)+I(yr_last_renovation^3)+I(yr_last_renovation^4)
#            +zipcode+I(zipcode^2)+I(zipcode^3)+I(zipcode^4)
            +lat+I(lat^2)+I(lat^3)+I(lat^4)
            +long+I(long^2)+I(long^3)+I(long^4)
            +sqft_living15+I(sqft_living15^2)+I(sqft_living15^3)+I(sqft_living15^4)
            +sqft_lot15+I(sqft_lot15^2)+I(sqft_lot15^3)+I(sqft_lot^4),
            data=train_set)
step.mod <- step(full.mod, steps=100, trace=1, k=log(n),direction="backward")
formula4 <- step.mod$call$formula

set.seed(17)
glm.fit <- glm(formula4, data=train_set)
cv.error4 <- cv.glm(train_set, glm.fit, K=10, cost=RMSE)$delta[1]
cv.error4

#grade 5
full.mod <- lm(price~date+I(date^2)+I(date^3)+I(date^4)+I(date^5)
               +bedrooms+I(bedrooms^2)+I(bedrooms^3)+I(bedrooms^4)+I(bedrooms^5)
               +bathrooms+I(bathrooms^2)+I(bathrooms^3)+I(bathrooms^4)+I(bathrooms^5)
               +sqft_living+I(sqft_living^2)+I(sqft_living^3)+I(sqft_living^4)+I(sqft_living^5)
               +sqft_lot+I(sqft_lot^2)+I(sqft_lot^3)+I(sqft_lot^4)+I(sqft_lot^5)
               +floors+I(floors^2)+I(floors^3)+I(floors^4)+I(floors^5)
               +waterfront
               +view+I(view^2)+I(view^3)+I(view^4)+I(view^5)
               +condition+I(condition^2)+I(condition^3)+I(condition^4)+I(condition^5)
               +grade+I(grade^2)+I(grade^3)+I(grade^4)+I(grade^5)
               +sqft_above+I(sqft_above^2)+I(sqft_above^3)+I(sqft_above^4)+I(sqft_above^5)
               +yr_built+I(yr_built^2)+I(yr_built^3)+I(yr_built^4)+I(yr_built^5)
               +yr_last_renovation+I(yr_last_renovation^2)+I(yr_last_renovation^3)+I(yr_last_renovation^4)+I(yr_last_renovation^5)
#              +zipcode+I(zipcode^2)+I(zipcode^3)+I(zipcode^4)+I(zipcode^5)
               +lat+I(lat^2)+I(lat^3)+I(lat^4)+I(lat^5)
               +long+I(long^2)+I(long^3)+I(long^4)+I(long^5)
               +sqft_living15+I(sqft_living15^2)+I(sqft_living15^3)+I(sqft_living15^4)+I(sqft_living^5)
               +sqft_lot15+I(sqft_lot15^2)+I(sqft_lot15^3)+I(sqft_lot^4)+I(sqft_lot^5),
               data=train_set)
step.mod <- step(full.mod, steps=150, trace=1,k=log(n), direction="backward")
formula5 <- step.mod$call$formula

set.seed(17)
glm.fit <- glm(formula5, data=train_set)
cv.error5 <- cv.glm(train_set, glm.fit, K=10, cost=RMSE)$delta[1]
cv.error5

# Define the vector of errors
cv.errors <- c(cv.error1, cv.error2, cv.error3, cv.error4, cv.error5)
par(mfrow=c(1,1))
# Plot the errors (RMSE) according to the degree of the model
plot(cv.errors, type="l", main="RMSE of the different models", xlab="Degree of the model")

# Define the final model
final_model <- glm(formula5, data = train_set) #polynomial (degree 5)
par(mfrow=c(2,2))
plot(final_model)

basic_model <- glm(formula1, data = train_set) #linear (degree 1)

# Prediction over the test set with the final model
prediction_final_model <- predict(final_model, test_set[,-18])
prediction_basic_model <- predict(basic_model, test_set[,-18])

# Errors with prediction using polynomial model and basic one
postResample((prediction_final_model),(test_set[,18]))
postResample((prediction_basic_model),(test_set[,18]))

###########
palette = colorRampPalette(c("green", "white", "red")) (20)
heatmap(x = cor(kc_house), col = palette, symm = TRUE)
#############

# We want to plot the most important features of our best model
best_model = train(formula5, data = train_set, method = "lm",trControl = fitControl,metric="RMSE")
importance_best_model = varImp(best_model)
PlotImportance(importance_best_model)

##trees
fit <- rpart(price~ ., data = kc_house)
rpart.plot(fit, digits = 3)


#' kmh2mph
#'
#' Conversion kilometer per hour to mile per hour.
#'
#' @param numeric  kmh Speed in Kilometer per hour.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  kmh2mph
#'
#' @export
#'
#'
#'
#'

kmh2mph<-function(kmh)
{
  return (kmh * 0.621371);
}


#!/usr/bin/Rscript

library(DNAshapeR)
library(seqinr)

args <- commandArgs(trailingOnly=T)

file = args[1] #fasta file

pred = getShape(file)

pdf(paste(file, 'DNAshapes_plot.pdf', sep="."))

par(mfrow=c(2,2))

for (i in 1:4) {plotShape(pred[[i]], colLine= 'red', main=names(pred)[i])}

dev.off()

fas = read.fasta(file, seqtype="DNA", as.string=T)

seqlen= c()

for (i in 1:4) {

	rownames(pred[[i]]) = names(fas)

	pred[[i]] = data.frame(pred[[i]])

	seqlen[i] = ncol(pred[[i]]) # sequence length
}

for (i in 1:4) {

	pred[[i]] = cbind(pred[[i]], 	mean=apply(pred[[i]], 1, function(x) mean(x, na.rm=T)),
					max= apply(pred[[i]], 1, function(x) max(x, na.rm=T)),
					min= apply(pred[[i]], 1, function(x) min(x, na.rm=T)))

}

for (i in 1:4) {

	n = ncol(pred[[i]])

	for (j in 1:ncol(pred[[i]])) { colnames(pred[[i]])[j] = paste(names(pred)[i], colnames(pred[[i]])[j], sep=".") }

	write.table(pred[[i]][,(n-2):n], file=paste(file, names(pred)[i], "txt" ,sep="."), sep="\t", col.names=T, row.names=F,append=FALSE, quote=FALSE)
}


setVtPars <- function(par, spect, fsc) {
  pks <- peaks(spect)
  pks$x <- fsc * pks$x
  fidx <- c(7,10,13,16,19,22,25,28)
  aidx <- fidx + 2
  for (i in 1:length(pks$x)) {
    par[fidx[i]] <- pks$x[i]
    par[aidx[i]] <- pks$y[i]
  }
  par
}


#===============================================================================
#  File:    03-running-lda.R
#  Date:    May 3, 2019
#  Paper:   Who Leads? Who Follows? Measuring Issue Attention and Agenda Setting
#           by Legislators and the Mass Public Using Social Media Data
#  Journal: American Political Science Review
#  Authors: Pablo Barbera, Andreu Casas, Jonathan Nagler, Patrick J. Egan,
#           Richard Bonneau, John Jost, Joshua A. Tucker
#  Purpose: run topic model on tweets by Members of Congress; then apply model
#           to compute posterior model probabilities for all corporsa
#  Data In:
#           ./data/tweets/text/* & data/dfm/congress-*
#  Data Out:
#           LDA output
#===============================================================================

# PACKAGES
#===============================================================================
library(slam)
library(Matrix)
library(tm)
library(topicmodels)

# DATA
#===============================================================================
## preparing Congress matrix
fls <- scan("data/dfm/fls-list.txt", what="character", sep="\n")
ind <- scan("data/dfm/congress-dtm-indices.txt")
pointers <- scan("data/dfm/congress-dtm-pointers.txt")
values <- scan("data/dfm/congress-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")

X <- sparseMatrix(j=ind, p=pointers, x=values,
                  dims=c(length(fls), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- apply(dtm, 2, sum)
tail(sort(rs),n=100)

# removing empty rows
cs <- row_sums(dtm)
dtm <- dtm[cs>0,]

# MAIN: CONGRESS
#===============================================================================
# running regular LDA
lda.fit <- LDA(dtm, k=100, method="Gibbs",
    	control=list(verbose=50L, iter=2000))

save(lda.fit, file="topics/lda_results-twokenizer.Rdata")

# OTHER GROUPS
#===============================================================================

########################
#### MEDIA ARTICLES ####
########################

load("topics/lda_results-twokenizer.Rdata")

## preparing  matrix
ind <- scan("data/dfm/media-tweets-dtm-indices.txt")
pointers <- scan("data/dfm/media-tweets-dtm-pointers.txt")
values <- scan("data/dfm/media-tweets-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")

X <- sparseMatrix(j=ind, p=pointers, x=values,
	dims=c(365*2, length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- col_sums(dtm)
tmp <- data.frame(word=Terms(dtm),rs=rs,stringsAsFactors=F)
tmp <- tmp[order(tmp$rs),]
tail(tmp,n=100)

# removing empty rows
cs <- row_sums(dtm)
dtm <- dtm[cs>0,]

## getting posterior estimates
results <- posterior(lda.fit, dtm,
    control=list(verbose=10L, iter=1000))

# saving output
save(results, file='topics/lda-output/lda-media-results.Rdata')

########################################
#### MEDIA ARTICLES (RANDOM SAMPLE) ####
########################################

load("topics/lda_results-twokenizer.Rdata")

ind <- scan("data/dfm/media-rs-dtm-indices.txt")
pointers <- scan("data/dfm/media-rs-dtm-pointers.txt")
values <- scan("data/dfm/media-rs-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")
tweets <- read.csv("data/tweets/media-tweets-random-sample.csv", stringsAsFactors=F, colClasses="character")

X <- sparseMatrix(j=ind, p=pointers, x=values,
    dims=c(nrow(tweets), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

# deleting empty rows
todelete <- which(rowSums(X)==0)
X <- X[-todelete,]
tweets <- tweets[-todelete,]

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- col_sums(dtm)
tmp <- data.frame(word=Terms(dtm),rs=rs,stringsAsFactors=F)
tmp <- tmp[order(tmp$rs),]

## getting posterior estimates
results <- posterior(lda.fit, dtm,
    control=list(verbose=10L, iter=1000))

# saving output
save(results, file='topics/lda-output/lda-media-rs-results.Rdata')

#################################
#### RANDOM SAMPLE OF TWEETS ####
#################################

load("topics/lda_results-twokenizer.Rdata")

## preparing  matrix
ind <- scan("data/dfm/rs-dtm-indices.txt")
pointers <- scan("data/dfm/rs-dtm-pointers.txt")
values <- scan("data/dfm/rs-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")
tweets <- read.csv("data/tweets/tweets-random-sample.csv", stringsAsFactors=F, colClasses="character")

X <- sparseMatrix(j=ind, p=pointers, x=values,
	dims=c(nrow(tweets), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

# deleting empty rows
todelete <- which(rowSums(X)==0)
X <- X[-todelete,]
tweets <- tweets[-todelete,]

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- col_sums(dtm)
tmp <- data.frame(word=Terms(dtm),rs=rs,stringsAsFactors=F)
tmp <- tmp[order(tmp$rs),]

## getting posterior estimates
results <- posterior(lda.fit, dtm,
    control=list(verbose=10L, iter=1000))

# saving output
save(results, file='topics/lda-output/lda-rs-results.Rdata')

########################
#### INDIVIDUAL MCS ####
########################

load("topics/lda_results-twokenizer.Rdata")

## preparing  matrix
ind <- scan("data/dfm/mcs-dtm-indices.txt")
pointers <- scan("data/dfm/mcs-dtm-pointers.txt")
values <- scan("data/dfm/mcs-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")
mcs <- scan("data/dfm/mcs-list.txt", what='character')

X <- sparseMatrix(j=ind, p=pointers, x=values,
	dims=c(length(mcs), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- col_sums(dtm)
tmp <- data.frame(word=Terms(dtm),rs=rs,stringsAsFactors=F)
tmp <- tmp[order(tmp$rs),]

## getting posterior estimates
results <- posterior(lda.fit, dtm,
    control=list(verbose=10L, iter=500))

# saving output
save(results, file='topics/lda-output/lda-mcs-results.Rdata')

#################################
#### USERS                  ####
#################################

load("topics/lda_results-twokenizer.Rdata")

## preparing  matrix
ind <- scan("data/dfm/users-dtm-indices.txt")
pointers <- scan("data/dfm/users-dtm-pointers.txt")
values <- scan("data/dfm/users-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")
users <- scan("data/dfm/users-list.txt", what='character')

X <- sparseMatrix(j=ind, p=pointers, x=values,
	dims=c(length(users), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- col_sums(dtm)
tmp <- data.frame(word=Terms(dtm),rs=rs,stringsAsFactors=F)
tmp <- tmp[order(tmp$rs),]

#################
## REPUBLICANS
#################

reps <- grep('republicans', users)
dtm2 <- dtm[reps,]

## getting posterior estimates
results <- posterior(lda.fit, dtm2,
    control=list(verbose=1L, iter=500))

# saving output
save(results, file='topics/lda-output/lda-reps-results.Rdata')

##############
## DEMOCRATS
##############

dems <- grep('democrats', users)
dtm2 <- dtm[dems,]

## getting posterior estimates
results <- posterior(lda.fit, dtm2,
    control=list(verbose=1L, iter=500))

# saving output
save(results, file='topics/lda-dems-results.Rdata')

##############
## PUBLIC
##############

pub <- grep('_public', users)
dtm2 <- dtm[pub,]

## getting posterior estimates
results <- posterior(lda.fit, dtm2,
    control=list(verbose=1L, iter=500))

# saving output
save(results, file='topics/lda-output/lda-public-results.Rdata')

#################################
#### RANDOM USERS            ####
#################################

cat("Random sample of users\n")

load("topics/lda_results-twokenizer.Rdata")

## preparing  matrix
ind <- scan("data/dfm/random-users-dtm-indices.txt")
pointers <- scan("data/dfm/random-users-dtm-pointers.txt")
values <- scan("data/dfm/random-users-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")
users <- scan("data/dfm/random-users-list.txt", what='character')

X <- sparseMatrix(j=ind, p=pointers, x=values,
    dims=c(length(users), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# sanity check
rs <- col_sums(dtm)
tmp <- data.frame(word=Terms(dtm),rs=rs,stringsAsFactors=F)
tmp <- tmp[order(tmp$rs),]

## getting posterior estimates
results <- posterior(lda.fit, dtm,
    control=list(verbose=1L, iter=500))

# saving output
save(results, file='topics/lda-output/lda-USrs-results.Rdata')


# Analysis of differences between two barometers: mainly their variance.

locations <- read.csv('./../../data/meta/inbo/Baro_Position_Lambert72.csv',
                      dec = ',', sep = ';', na.strings = 'NULL', stringsAsFactors = FALSE)
data.table::setDT(locations)
data.table::setkey(locations, ppnt_cde)

d <- function(xy1, xy2) sqrt(sum((xy1 - xy2)^2))
d.vec <- function(xy.from, xy.to.df) {
  stopifnot(length(xy.from) == 2L)
  stopifnot(!is.null(nrow(xy.to.df)))

  apply(xy.to.df, 1, d, xy1 = xy.from)
}

read.full <- function(location) {
  loggers <- grep(paste0('barometer/', location), gwloggeR.data::enumerate(), value = TRUE)
  df <- data.table::rbindlist(lapply(loggers, function(logger) gwloggeR.data::read(logger)$df), use.names = TRUE)
  if (nrow(df) == 0L) return(df)
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  data.table::setkey(df, TIMESTAMP_UTC)
  structure(df, 'location' = location)
}

compare <- function(df1, df2, distance = NA, save.plot = FALSE) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(NA)
  df1.name <- attr(df1, 'location')
  df2.name <- attr(df2, 'location')

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]
  if (nrow(diff.df) < 250L) return(NA)

  ap <- gwloggeR::apriori('air pressure')
  df1.operc <- sum(gwloggeR::detect_outliers(df1[J(diff.df), PRESSURE_VALUE], apriori = ap))/nrow(diff.df)
  df2.operc <- sum(gwloggeR::detect_outliers(df2[J(diff.df), PRESSURE_VALUE], apriori = ap))/nrow(diff.df)
  if (df1.operc > 0.1 || df2.operc > 0.1) return(NA)

  filename <- sprintf('./drifts/analysis_01/%s.png', paste0(sort(c(df1.name, df2.name)), collapse = '-'))

  on.exit({if (save.plot) dev.off(); par(mfrow = c(1, 1))})
  if (save.plot) png(filename = filename, width = 768L, height = 480L)
  par(mfrow = c(2, 2))

  mad <- mad(diff.df$PRESSURE_DIFF)
  with(df1[J(diff.df),], plot(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, type = 'l', xlab = df1.name))
  with(df2[J(diff.df),], plot(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, type = 'l', xlab = df2.name))
  with(diff.df, plot(x = TIMESTAMP_UTC, y = PRESSURE_DIFF, type = 'l'))
  with(diff.df, hist(PRESSURE_DIFF, breaks = 50, main = ''))
  mtext(sprintf('%s vs. %s SD: %.3f (%.0f km)', df1.name, df2.name, mad, distance),
        outer = TRUE, line = -2.5, cex = 1.5)

  mad
}

compute <- function(logger.loc) {
  logger.xy <- unlist(locations[J(logger.loc), .(Lambert72_X, Lambert72_Y)])
  logger.df <- read.full(logger.loc)

  distances <- d.vec(logger.xy, locations[, .(Lambert72_X, Lambert72_Y)])/1000
  names(distances) <- locations$ppnt_cde
  distances <- sort(distances, na.last = TRUE)

  sd <- sapply(names(distances), function(other.loc) {
    if(logger.loc > other.loc) return(NA)
    other.df <- read.full(other.loc)
    compare(logger.df, other.df, distances[other.loc], save.plot = TRUE)
  })

  data.frame('A' = logger.loc, 'B' = names(distances), 'dist' = distances, 'sd' = sd,
             stringsAsFactors = FALSE)
}

# A, B, dist, sd
# tmp <- compute(locations$ppnt_cde[15L])
# tmp <- lapply(locations$ppnt_cde, compute)

parallel::setDefaultCluster(parallel::makeCluster(spec = 7L))
parallel::clusterExport(varlist = c('d', 'd.vec', 'compare', 'read.full', 'locations'))
results <- parallel::clusterApplyLB(x = locations$ppnt_cde, fun = compute)
parallel::stopCluster(cl = parallel::getDefaultCluster())

results <- data.table::rbindlist(results, use.names = TRUE)
results[, key := paste0(ifelse(A>B,B,A), '#', ifelse(A>B,A,B))]
data.table::setkey(results, key)
results <- results[!is.na(dist) & !is.na(sd), ] # before duplicate key removal due to: if(logger.loc > other.loc) return(NA)
results <- results[!duplicated(key), ]
results <- results[dist != 0, ]
with(results, plot(x = dist, y = sd))

results[order(sd, decreasing = TRUE),][1:10]

summary((fit.rq.5 <- quantreg::rq(data = results, formula = sd ~ dist)))
summary((fit.rq.1 <- quantreg::rq(data = results, formula = sd ~ dist, tau = 0.1)))

ggplot2::ggplot(data = results, mapping = ggplot2::aes(x = dist, y = sd)) +
  ggplot2::geom_point() +
  # ggplot2::geom_smooth(method = 'lm', formula = y ~ x, col = 'yellow', size = 1.2, alpha = 0.9) +
  ggplot2::geom_quantile(quantiles = c(0.1, 0.5), formula = y ~ x, size = 1.2, alpha = 0.9) +
  ggplot2::coord_cartesian(ylim = quantile(results$sd, probs = c(0.01, 0.99)),
                           xlim = quantile(results$dist, probs = c(0.01, 0.99))) +
  ggplot2::xlab('Distance (km)') + ggplot2::ylab('Standard deviation (MAD, cmH2O)') +
  ggplot2::ggtitle('Air pressure difference SD in function of barometer distance') +
  ggplot2::theme_light()


#' Add one variable to the XGBoost scorecard
#' @param df a disk.frame
#' @param target a character string indicating the variable name of the target
#' @param feature a character string indicating the variable name of the feature
#' @param monotone_constraints 1 higher value of feature equals higher success, -1 = the opposite, 0 = neither
#' @param prev_pred a vector of score equal to the nrow(df) which is the previous predictions used for hot-start
#' @param format_fn a function to transform the feature vector before fitting a model
#' @param save_model_fname the file name to save the xgboost model as
#' @param weight The weight of each entry
#' @importFrom xgboost xgb.DMatrix xgboost xgb.save setinfo
#' @importFrom data.table timetaken setnames
#' @importFrom stats predict
add_var_to_scorecard <- function(df, target, feature, monotone_constraints = 0, prev_pred = NULL, format_fn = base::I, weight = NULL, save_model_fname = "") {
  if(!requireNamespace("xgboost", quietly = T)) {
    stop("you must install xgboost to use this function; e.g. install.packages('xgboost')")
  }

  print(glue::glue("doing {feature}"))
  xy = df %>%
    srckeep(c(target, feature, weight)) %>%
    collect(parallel = F)

  # format the input if necessary
  code = glue::glue("xy = xy %>% mutate({feature} = format_fn({feature}))")
  eval(parse(text = code))

  not_numeric = !is.numeric(xy[1, feature, with = F][[1]])

  weight_name = weight
  if(!is.null(weight)) {
    weight = xy$weight
  }

  if(not_numeric) {
    # it must be character or factor. Now create a  default rate
    monotone_constraints = 1

    eval(parse(text = glue::glue("xy[, feature_s := sum({target})/.N, {feature}]")))
    dtrain <- xgboost::xgb.DMatrix(label = xy[,target, with = F][[1]], data = as.matrix(xy[,.(feature_s)]))
  } else {
    dtrain <- xgboost::xgb.DMatrix(label = xy[,target, with = F][[1]], data = as.matrix(xy[,c(feature), with = F]))
  }

  if(is.null(prev_pred)) {
    pt = proc.time()
    m2 <- xgboost::xgboost(
      data=dtrain,
      nrounds = 1,
      eta=1,
      objective = "binary:logitraw",
      tree_method="exact",
      monotone_constraints = monotone_constraints,
      base_score = sum(xy[,target, with = F][[1]])/nrow(xy),
      weigth = weight
    )
    timetaken(pt)
  } else {
    xgboost::setinfo(dtrain, "base_margin", prev_pred)
    pt = proc.time()
    m2 <- xgboost::xgboost(
      data=dtrain,
      nrounds = 1,
      eta=1,
      objective = "binary:logitraw",
      tree_method="exact",
      monotone_constraints = monotone_constraints,
      weigth = weight
    )
    timetaken(pt)
  }

  # code to obtain the unique for merging
  if(not_numeric) {
    # in case where multiple categories have the same default rate
    udtrain_df = evalparseglue("xy[, .({feature} = unique({feature})), feature_s]")

    # keep the categories separate because xgb.DMatrix can't convert categoricals
    udtrain_df_cat = evalparseglue("udtrain_df[,.({feature})]")
    udtrain_df = udtrain_df[,.(feature_s)]
  } else {
    udtrain_df = evalparseglue("xy[, .({feature} = unique({feature}))]")
  }

  udtrain = xgboost::xgb.DMatrix(as.matrix(udtrain_df))
  a3 = predict(m2, udtrain, predcontrib = T) %>% data.table

  setnames(a3, names(a3), c("score", "bias"))

  stopifnot(length(unique(a3$bias)) == 1)
  bias = a3[1, bias]

  # summarise a4 to get the cutting points
  if(not_numeric) {
    a4 = cbind(udtrain_df, udtrain_df_cat, a3)
    a5 = a4
  } else {
    a4 = cbind(udtrain_df, a3)
    a5 = evalparseglue("a4[,.({feature} = max({feature})), score][order({feature}),]")
  }

  if(!is.null(save_model_fname) & save_model_fname != "") {
    xgboost::xgb.save(m2, save_model_fname)
  }

  res = list(feature = feature, model = save_model_fname, bins = a5, prev_pred = predict(m2, dtrain), bias = bias, format_fn = format_fn, auc = auc(xy[,target, with = F][[1]], predict(m2, dtrain)), weight_name = weight_name, monotone_constraints = monotone_constraints)
  class(res) <- "xgdf_scorecard"
  res
}

#' Print xgboost scorecard
#' @param x the Xgboost modelling result
#' @param ... not used. Kept for compatibility
print.xgdf_scorecard <- function(x, ...) {
  print(glue::glue("AUC: {res$auc}; GINI: {2*res$auc-1}"))
  print(x$bins)
}


#' Remove longest common prefix and suffix
#' @export
rlcps <- function(x) {
  require('Biostrings')
  xo <- order(x)
  s1 <- x[xo[1]]
  s2 <- x[xo[length(x)]]
  plen <- Biostrings::lcprefix(s1, s2)
  slen <- Biostrings::lcsuffix(s1, s2)
  result <- substring(x, 1+plen, nchar(x)-slen)
  attr(result, 'prefix') <- substring(s1, 1, plen)
  attr(result, 'suffix') <- substring(s1, nchar(s1)-slen+1)
  return (result)
}

#' Find a minimal unique representation
#' @export
mur <- function(x, name.result=TRUE) {
  require('Biostrings')
  require('stringr')
  orig.x <- x
  if ( any(duplicated(x))) stop('Duplicate values not allowed.')

  clean <-  stringr::str_replace_all(x, '[._\\s]', '')
  if ( !any(duplicated(clean)) ) x <- clean

  n <- length(x)
  xo <- order(x)
  sx <- x[xo]
  mx <- rep('', n)

  mxs <- NULL

  i <- 1
  j <- n
  while ( j < n || i < n ) {
    lcp <- Biostrings::lcprefix(sx[i], sx[j])
    if ( lcp > 0 ) {
      mx[i:j] <- paste0(mx[i:j], substring(sx[i:j], 1, 1))
      sx[i:j] <- substring(sx[i:j], lcp+1)
      mxs <- rbind(mxs, sx)
    }

    if ( i <= 1 ) {
      i <- 2+n-j
      j <- n
    } else {
      i <- i - 1
      j <- j - 1
    }
  }

  for ( i in 1:n ) {
    if ( nchar(sx[i]) > 0 ) {
      mx[i] <- paste0(mx[i], substring(sx[i], 1, 1))
      sx[i] <- substring(sx[i], 2)
    }
  }

  result <- mx
  result[xo] <- mx

  if ( name.result )
    names(result) <- orig.x

  return (result)
}


ndc <- function(sqns, y, stop){
  cTable = arg_check(sqns, 'KZsqns', y)
  temp1 = table(cTable[,2])
  temp2 = names(temp1[temp1==1])
  bin = numeric()
  if(length(temp2)!=0){
    bin = sapply(temp2,function(x){which(cTable[,2]==x)})
  }
  if(!stop){
    bin = c(bin, which(cTable[,2]=='*'))
  }
  if(length(bin)!=0){
    x = table(sqns)[-bin]
    sqns = unlist(sapply(1:length(x), function(i){rep(names(x[i]), x[i])}))
    attr(sqns, 'class') <- 'KZsqns'
  }
  return(sqns)
}

scu <- function(tx, cTable, stop = FALSE){

  if(method[1] == "sharp"){
    tx[tx==0] <- 0.5
  }
  w = tx[cTable[,1]]
  names(w) <- cTable[,1]
  absentAA = which(is.na(w))
  if(length(absentAA)!=0){
    w[absentAA] = 0
  }

  temp = table(cTable[,2])
  degv = numeric(0)
  for(j in names(temp)){
    dx = which(cTable[,2]==j)
    if(sum(w[dx])==0){
      degv[dx] = NA
      cat('An animo acid is missing, and NAs will be produced for this animo acid\n')
    } else {
      degv[dx] = w[dx]/max(w[dx])
    }
  }
  names(degv) = cTable[,1]
  if(!stop) degv[which(cTable[,2]=='*')] <- NA
  if(method[1]=="bulmer"){
    degv[degv==0] <- 0.01
  }
  return(degv)
}

rscu_ <- function(x, y, stop, supplementory.info){
  cTable = arg_check(x, 'KZsqns', y)

  w = table(x)[cTable[,1]]
  names(w) <- cTable[,1]
  absentAA = which(is.na(w))
  if(length(absentAA)!=0){
    w[absentAA] = 0
  }

  temp = table(cTable[,2])
  degv = numeric(0)
  for(j in names(temp)){
    dx = which(cTable[,2]==j)
    if(sum(w[dx])==0){
      degv[dx] = NA
      cat('An animo acid is missing, and NAs will be produced for this animo acid\n')
    } else {
      degv[dx] = w[dx]/sum(w[dx])*temp[j]
    }
  }
  names(degv) = cTable[,1]
  if(!stop) degv[which(cTable[,2]=='*')] <- NA
  if (supplementory.info){
    return(list(data=degv, top5 = names(degv[order(degv, decreasing = TRUE)[1:5]]), bottom5 = names(degv[order(degv)[1:5]])))
  } else {
    return(degv)
  }
}

nc_fuglsang4m <- function(tx, cTable){
  w = tx[cTable[,1]]
  names(w) <- cTable[,1]
  absentAA = which(is.na(w))
  if(length(absentAA)!=0){
    w[absentAA] = 0
  }

  temp = table(cTable[,2])
  degv = numeric(0)
  for(j in names(temp[-1])){
    xd = which(cTable[,2]==j)
    if(sum(w[xd])==0){
      degv[j] = NA
    } else {
      degv[j] = (sum(w[xd])*sum((w[xd]/sum(w[xd]))^2)-1)/(sum(w[xd])-1)
    }
  }
  du = mean((1/degv)/(temp[-1]), na.rm=T)
  for(j in which(is.na(degv))){
    degv[j] = du*(temp[names(degv[j])] - 1) + 1
  }

  und = names(table((temp[-1])))
  slots = rep(0, length(und))
  dx = 1
  for(j in und){
    if(j==1){
      slots[dx] = 1
    } else {
      slots[dx] = mean(degv[which(names(degv) %in% names(which(temp==j)))])
    }
    dx=dx+1
  }
  return(sum(table(temp[-1])/slots))
}

nc_wright <- function(tx, cTable){
  w = tx[cTable[,1]]
  names(w) <- cTable[,1]
  absentAA = which(is.na(w))
  if(length(absentAA)!=0){
    w[absentAA] = 0
  }

  temp = table(cTable[,2])
  degv = numeric(0)
  for(j in names(temp[-1])){
    xd = which(cTable[,2]==j)
    if(sum(w[xd])==0){
      degv[j] = NA
    } else {
      degv[j] = (sum(w[xd])*sum((w[xd]/sum(w[xd]))^2)-1)/(sum(w[xd])-1)
    }
  }
  und = names(table((temp[-1])))
  slots = rep(0, length(und))
  dx = 1
  for(j in und){
    if(j==1){
      slots[dx] = 1
    } else {
      slots[dx] = mean(degv[which(names(degv) %in% names(which(temp==j)))] ,na.rm=TRUE)
    }
    dx=dx+1
  }

  if(NaN %in% slots) cat("At least one degenerate class of AA is missing, NaN will be produced. Try Fuglsang's formula to get an estimate.\n")
  return(sum(table(temp[-1])/slots))
}

dna2aa_ <- function(dnaSequence, aaNoLetters, codonTable){
  cTable = arg_check(dnaSequence, 'KZsqns', codonTable)
  if(aaNoLetters==1){
    cTable = setNames(cTable[,2],cTable[,1])
  } else {
    cTable = setNames(cTable[,3],cTable[,1])
  }
  return(unname(cTable[dnaSequence]))
}

scuo_ = function(x, y){
  cTable = arg_check(x, 'KZsqns', y)

  temp = table(x)[cTable[,1]]
  exclude = which(cTable[,2]=='*')
  degv = table(cTable[,2])[-1]
  degv = degv[degv!=1]
  haa = numeric(length(degv))
  hmax = haa
  for(i in 1:length(degv)){
    tx = temp[cTable[,2] == names(degv[i])]
    haa[i] = - crossprod(tx/(sum(tx)), log(tx/(sum(tx))))
    hmax[i] = -log(1/length(tx))
  }
  haa[is.na(haa)] = 0
  scuo_aa = (hmax-haa)/hmax
  aa = table(dna2aa(x, 1, y))[names(degv)]
  aa[is.na(aa)] = 0
  return(crossprod(scuo_aa, aa)/sum(aa))
}


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

args <- commandArgs(trailingOnly=TRUE)
path_to_src <- args[1]
source(paste(path_to_src,"ols.r",sep=""))
source(paste(path_to_src,"bootstrap.r",sep=""))
source(paste(path_to_src,"crossvalidate.r",sep=""))
source(paste(path_to_src,"archive/paper/paperfigures.r",sep=""))
source(paste(path_to_src,"archive/paper/paperstats.r",sep=""))
source(paste(path_to_src,"archive/paper/papersimulation.r",sep=""))
caldata <- read.table(args[2],col.names=c("study","d","h","agb","rho"))
alpha <- 0.05
runs <- 10000
ncpus <- 4
####
plotFig0()
plotFig1(caldata)
plotFig2(caldata,alpha,runs,ncpus)
plotFig3(caldata,alpha,runs,ncpus)
plotFig4(caldata)
plotFig5(caldata,alpha,runs,ncpus)
###
#bivariateStats(caldata)
#covariateStats(caldata)
###
#crossvalidateStats(caldata)
#simulate(caldata,runs)


# take input from the user
# num = as.integer(readline(prompt="Enter a number: "))

args = commandArgs(trailingOnly=TRUE)
#print(R.Version())
print(R.version.string)
num = args[1]
factorial = 1
# check is the number is negative, positive or zero
if(num < 0) {
  print("Sorry, factorial does not exist for negative numbers")
  } else if(num == 0) {
    print("The factorial of 0 is 1")
    } else {
      for(i in 1:num) {
        factorial = factorial * i
      }
      print(paste("The factorial of", num ,"is",factorial))
    }


#' Plot a barbell plot of the observed (blue) and simulated (red) groundwater elevations as listed
#' in the pest .res file. This function requires that both a .res file and targpest.dat file are
#' located in the PATH directory.
#'
#' @param PATH This is the full file path to the .res and targpest.dat files. They need to be located in the same directory.
#' @param MAIN This is text to be printed as the main figure title
#' @param colour_obs the colour of the observed groundwater elevation
#' @param colour_sim the colour of the simulated groundwater elevation
#' @param colour the colour of the bar
#' @param size_obs the size of the observed groundwater elevation
#' @param size_sim the size of the simulated groundwater elevation
#' @param size the size of the bar
#' @param alpha the level of transparency of the ends
#' @export

pltpstbarbell <- function(PATH = NA,
                          MAIN = NA,
                          colour = "#a3c4dc",
                          colour_obs = "blue",
                          colour_sim = "red",
                          size_obs = 3,
                          size_sim = 3,
                          alpha = 0.6,
                          size = 1,
                          xlab = "",
                          ylab = ""){
    if(is.na(PATH)){
        PATH <- getwd()
    }

    res  <- MFtools::readpstres(PATH) %>%
            dplyr::mutate(SQUARE_RES = `Weight*Residual`^2)

    max_val <- round(max(max(res$Measured, na.rm = TRUE), max(res$Modelled, na.rm = TRUE), na.rm = TRUE) / 10, 0) * 10
    min_val <- round(min(min(res$Measured, na.rm = TRUE), min(res$Modelled, na.rm = TRUE), na.rm = TRUE) / 10, 0) * 10
    range_val <- max_val - min_val
    if(range_val > 100){
        maj_div <- 20
        min_div <- 5
    }else if(range_val > 25 & range_val <= 100){
        maj_div <- 10
        min_div <- 1
    }else if(range_val > 5 & range_val <= 25){
        maj_div <- 1
        min_div <- 0.1
    }else if(range_val <= 5){
        maj_div <- 0.1
        min_div <- 0.01
    }

    STATS <- res %>% dplyr::summarise(SSQ = sum(SQUARE_RES),
                                      MEAN_RES = mean(`Weight*Residual`, na.rm = TRUE),
                                      MEAN_ABS_RES = mean(abs(`Weight*Residual`), na.rm = TRUE),
                                      ST_DEV = sd(`Weight*Residual`, na.rm = TRUE),
                                      SCALED_ST_DEV = ST_DEV / (max(Measured, na.rm = TRUE) - min(Measured, na.rm = TRUE)))

    p <- res %>% ggplot2::ggplot(aes(y = reorder(TARG_ID, -Measured), x = Measured, xend = Modelled)) +
                 ggalt::geom_dumbbell(size = size,
                                      colour = colour,
                                      alpha = alpha,
                                      size_x = size_obs,
                                      size_xend = size_sim,
                                      colour_x = colour_obs,
                                      colour_xend = colour_sim) +
                 ggplot2::ylab(xlab) +
                 ggplot2::scale_x_continuous(limits = c(min_val, max_val),
                                             breaks = seq(min_val, max_val, maj_div),
                                             minor_breaks = seq(min_val, max_val, min_div),
                                             expand = c(0, 0),
                                             name = ylab) +
                 ggplot2::coord_flip() +
                 ggplot2::geom_label(x = max_val, y = nrow(res),
                                     label = paste0("Sum of Squared Residuals: ", round(STATS$SSQ[[1]], 1), "\n",
                                                   "Mean Residual: ", round(STATS$MEAN_RES[[1]], 1), "\n",
                                                   "Mean Absolute Residual: ", round(STATS$MEAN_ABS_RES[[1]], 1), "\n",
                                                   "Standard Deviation: ", round(STATS$ST_DEV[[1]], 1), "\n",
                                                   "Scaled Standard Deviation: ", round(STATS$SCALED_ST_DEV[[1]], 3)),
                           family = "sans",
                           fontface = "plain",
                           hjust = 1,
                           vjust = 1) +
                 ggplot2::labs(title = MAIN) +
                 ggplot2::theme_bw() +
                 ggplot2::theme(axis.text.x = element_text(angle = 90),
                                legend.position = "bottom")
    return(p)
}


library(data.table)
library(rstan)
library(lognorm)
library(dplyr)
library(covid19AgeModel)

args = list(
  seed = 42,
  chain = 1,
  outdir= "~/Box\ Sync/2020/R0t/results/ifr_by_age_prior",
  indir = "~/git/R0t",
  cmdstan = 1,
  #stanModelFile = 'base_age_prior_ifr_200820a7_cmdstanv',
  stanModelFile = 'base_age_prior_ifr_200820b5_cmdstanv',
  job_tag= 'new_data_spain_England',
  job_id='41286'
)

pkg.dir <- system.file(package = "covid19AgeModel" )

args$job_dir <- file.path(args$outdir,paste0(args$stanModelFile,'-',args$job_tag,'-',args$job_id))

outfile.base <- paste0(args$job_dir, "/",  args$stanModelFile , "-", args$job_tag)

# Outputs of the log normal fit from 28/08/2020
load(file.path(args$job_dir, paste0(basename(args$job_dir), '_stanout.RData')) )
load(file.path(args$job_dir, paste0(basename(args$job_dir), '_stanin.RData')) )

fit = rstan:::sflist2stanfit(list(fit))

age_predict <- c(0, seq(2.5, 97.5, 5))

#	plot IFR and log IFR
difrp <- rstan::extract(fit)[['p_predict']]
difrp <- as.data.table(reshape2::melt(difrp))
difrp <- setnames(difrp, 1:3, c('it','age.idx','ifr'))
difrp <- merge(difrp, data.table(age.idx=seq_along(age_predict), age=age_predict), by='age.idx')
difrp[, log.ifr:= log(ifr)]
difrp[, logit.ifr:= log(ifr/(1-ifr))]
difrp <- melt(difrp, measure.vars=c('ifr','log.ifr','logit.ifr'))
difrp <- difrp[, list(qs=quantile(value, p=c(0.025, 0.25, 0.5, 0.75, 0.975)), ql=c('CL','IL','M','IU','CU')), by=c('variable','age.idx','age')]
difrp <- dcast.data.table(difrp, variable+age.idx+age~ql, value.var='qs')
ggplot( subset(difrp, variable=='log.ifr'), aes(x=age)) +
  geom_ribbon(aes(ymin=CL, ymax=CU)) +
  geom_line(aes(y=M)) +
  geom_point(data=difr, aes(x=Median_Age, y=log_IFR), colour='blue') +
  theme_bw()
ggplot( subset(difrp, variable=='logit.ifr'), aes(x=age)) +
  geom_ribbon(aes(ymin=CL, ymax=CU)) +
  geom_line(aes(y=M)) +
  geom_point(data=difr, aes(x=Median_Age, y=logit_IFR), colour='blue') +
  theme_bw()
ggplot( subset(difrp, variable=='ifr')) +
  geom_ribbon(aes(x=age, ymin=CL, ymax=CU)) +
  geom_line(aes(x=age, y=M)) +
  geom_point(data=difr, aes(x=Median_Age, y=IFR), colour='blue') +
  theme_bw()

#	posterior predictive checks
difrx <- rstan::extract(fit)[['pred_deaths']]
difrx <- as.data.table(reshape2::melt(difrx))
difrx <- setnames(difrx, 1:3, c('it','age.idx','pred_deaths'))
set(difrx, NULL, 'pred_deaths', difrx$pred_deaths/1e7)
set(difrx, NULL, 'logit_pred_deaths', difrx[, log(pred_deaths/(1-pred_deaths))])
set(difrx, NULL, 'log_pred_deaths', difrx[, log(pred_deaths)])
difrx <- melt(difrx, measure.vars=c('logit_pred_deaths','log_pred_deaths'))
difrx <- difrx[is.finite(value), list(qs=quantile(value, p=c(0.025, 0.25, 0.5, 0.75, 0.975)), ql=c('CL','IL','M','IU','CU')), by=c('variable','age.idx')]
difrx <- dcast.data.table(difrx, variable+age.idx~ql, value.var='qs')
difrx[, age:= age.idx-1]
difrx[, age:= 5*(age.idx-1)]
ggplot( subset(difrx, variable=='logit_pred_deaths')) +
  geom_ribbon(aes(x=age, ymin=CL, ymax=CU)) +
  geom_line(aes(x=age, y=M)) +
  geom_point(data=difr, aes(x=Median_Age, y=logit_IFR), colour='blue') +
  theme_bw()
ggplot( subset(difrx, variable=='log_pred_deaths')) +
  geom_ribbon(aes(x=age, ymin=CL, ymax=CU), alpha = 0.5, fill = "gray60") +
  geom_line(aes(x=age, y=M)) +
  geom_point(data=difr, aes(x=Median_Age, y=log_IFR, col = Study)) +
  theme_bw() +
  labs(y = "Infection Fatality Rate (log scale)") +
  theme(legend.position = "bottom") +
  guides(fill=guide_legend(nrow=2,byrow=TRUE))
ggsave(filename = paste0(outfile.base, "-ifrbyage_fit.png"), w = 6, h = 6)

#
# comparison to Levin's prior
# IFR estimates extracted from https://www.medrxiv.org/content/10.1101/2020.07.23.20160895v4.supplementary-material
ifr_lognormal = as.data.table(read.csv(file.path(pkg.dir, "data", "ifr-by-age-prior_Levin_raw_200904.csv")))
tmp1 = select(ifr_lognormal, c("Age", "IFR", "Lower.Bound", "Upper.Bound"))
tmp1 = subset(tmp1, !Age %in% c("0-34", "95+"))
tmp1[, Model := "Meta-analysis from Levin et al." ]
tmp1[, M := log(IFR/100) ]
tmp1[, CL := log(Lower.Bound/100) ]
tmp1[, CU := log(Upper.Bound/100) ]
tmp1[, Age := as.numeric(Age)]
setnames(tmp1, "Age", "age")
tmp1 = select(tmp1, -c("IFR", "Lower.Bound", "Upper.Bound"))
tmp = subset(difrx, variable=='log_pred_deaths', select = c("age", "CL", "CU", "M"))
tmp[, Model := "BetaBinomial with logit link"]
tmp = rbind(tmp1, tmp)
ggplot(tmp) +
  geom_ribbon(aes(x=age, ymin=CL, ymax=CU, fill = Model), alpha = 0.5) +
  geom_line(aes(x=age, y=M, col = Model), alpha = 1.1) +
  theme_bw() +
  labs(y = "Infection Fatality Rate (log scale)") +
  theme(legend.position = "bottom") +
  scale_color_manual(values = c("black", "red"))+
  scale_fill_manual(values = c("gray60", "#F1A340")) +
  guides(fill=guide_legend(nrow=2,byrow=TRUE), color=guide_legend(nrow=2,byrow=TRUE))
ggsave(file = paste0(outfile.base, "-comparison_ifr_prediction_betabinom_lognormal.png"), w = 6, h = 6)

# #
# # # comparison to Verity's prior
# ifr_verity = read.csv(args$file_age_ifr_verity)
# ifr_lognormal = as.data.table(read.csv(args$file_age_ifr_lognormal))
#
# ggplot( subset(difrx, variable=='log_pred_deaths')) +
#   geom_ribbon(aes(x=age, ymin=CL, ymax=CU), alpha = 0.5) +
#   geom_errorbar(data = ifr_verity, aes(x = age, ymin = log(ifr_cl), ymax = log(ifr_cu)), col = "red") +
#   geom_point(data = ifr_verity, aes(x = age, y = log(ifr_mean)), col = "red") +
#   geom_line(aes(x=age, y=M)) +
#   theme_bw() +
#   labs(title = "Comparison with Verity")
#
#


#' Plot one-way ANOVA
#'
#' @description
#' \code{plot.oneway} creates group comparisons for a one-way ANOVA and gives the user an option to choose among several types of graphs.
#'
#' @param x an object of class \code{oneway}
#' @param plot a character string representing the type of plot. Default is boxplot. Other types of plot: violin and density ridges.
#' @param ... additional arguments passed to the chosen plot function.
#'
#' @export
#'
#' @return NULL
#'
#' @import ggplot2 ggridges
#'
#' @examples
#' fit <- oneway(mpg ~ cyl, mtcars)
#' plot(fit, plot = "boxplot")
#' plot(fit, plot = "violin")
#' plot(fit, plot = "density_ridges")

plot.oneway <- function(x, plot = "boxplot", ...){
  if(!inherits(x, "oneway"))
    stop("Must be class 'oneway")

  g <- as.character(x$anova$terms[[3]]) # "cyl"
  y <- as.character(x$anova$terms[[2]]) # "mpg"

  # box plot
  if(plot=="boxplot"){
    ggplot(x$anova$model, aes(x = factor(.data[[g]]), y= .data[[y]])) +
      geom_boxplot(fill = "lightblue",...) + geom_dotplot(binaxis='y', stackdir='center', dotsize = .5, fill="pink") + labs(x=g) +
      theme(legend.position="none") + ggtitle("Box plot")

  # violin plot
  } else if(plot=="violin"){
    ggplot(x$anova$model, aes(x = factor(.data[[g]]), y= .data[[y]]), ...) + labs(x=g) +
      theme(legend.position="none") + ggtitle("Violin plot") + geom_violin(fill = "lightblue",...) + geom_dotplot(binaxis='y', stackdir='center', dotsize = .5, fill="pink")

  # density ridges plot
  } else if(plot=="density_ridges"){
    ggplot(x$anova$model, aes(.data[[y]], .data[[g]],group=.data[[g]],fill=.data[[g]])) +
      geom_density_ridges(...) + theme_ridges() + labs(x=g) + ggtitle("Density ridges plot")
  }
}


#Show which groups fit very poorly at the site levelbut fit well in sample.
rm(list=ls())
source('paths.r')

#set output path.----
output.path <- 'Supp._Fig._3._bad_out.of.sample_fits.png'

#load data.----
#grab prior fits.
prior <- readRDS(ted_ITS_prior_all.groups_JAGSfits.path) #all phylo and functional groups.
#grab forecasts and observations of functional and phylogenetic groups.----
fcast <- readRDS(NEON_site_fcast_all_groups_1k_rare.path)
neon.truth <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path)

#get prior rsq values.----
prior.out <- list()
for(i in 1:length(prior)){
  lev <- prior[[i]]
  lev.out <- list()
  for(k in 1:ncol(lev$observed)){
    fit <- lm(lev$observed[,k] ~ lev$predicted[,k])
    rsq <- summary(fit)$r.squared
    lev.out[[k]] <- rsq
  }
  tax <- colnames(lev$predicted)
  lev.out <- unlist(lev.out)
  return <- data.frame(tax,lev.out)
  colnames(return) <- c('tax','rsq')
  return <- return[return$tax != 'other',]
  prior.out[[i]] <- return
}
prior.out <- do.call(rbind, prior.out)

#Get out of sample rsq values.----
fcast.out <- list()
for(i in 1:length(fcast)){
  pred <- fcast[[i]]$site.fit$mean
   obs <- neon.truth[[i]]$site.fit$mean
   lev.out <- list()
   for(k in 1:ncol(pred)){
     fit <- lm(obs[,k] ~ pred[,k])
     rsq <- summary(fit)$r.squared
     lev.out[[k]] <- rsq
   }
   tax <- colnames(pred)
   lev.out <- unlist(lev.out)
   return <- data.frame(tax,lev.out)
   colnames(return) <- c('tax','rsq')
   return <- return[return$tax != 'other',]
   fcast.out[[i]] <- return
}
fcast.out <- do.call(rbind, fcast.out)
out <- merge(prior.out, fcast.out, by = 'tax')

#Find taxa with highest in sample and lowest out of sample rsq.----
out <- out[order(out$rsq.x, decreasing = T),]

#great candidates are:
#1. Inocybe
#2. Hypocreales.
#3. Helotiales.

#grab predicted vs. observed for groups of interest----
namey <- c('Inocybe','Hypocreales','Helotiales')
level <- c('genus','order','order')
namey <- c('Inocybe','Thelephoraceae','Umbelopsis')
level <- c('genus','family','genus')

prior.plot <- list()
fcast.plot <- list()
for(i in 1:length(namey)){
  #prior pred vs. obs.
  pred <- prior[[which(names(prior) == level[i])]]$predicted
  pred <- pred[,colnames(pred) == namey[i]]
   obs <- prior[[which(names(prior) == level[i])]]$observed
   obs <-  obs[,colnames( obs) == namey[i]]
   prior.plot[[i]] <- data.frame(obs, pred)
  #fcst pred vs. obs.
  pred <- fcast[[which(names(fcast) == level[i])]]$site.fit$mean
  pred <- pred[,colnames(pred) == namey[i]]
   obs <- neon.truth[[which(names(fcast) == level[i])]]$site.fit$mean
   obs <-  obs[,colnames(obs) == namey[i]]
   fcast.plot[[i]] <- data.frame(obs, pred)
}
names(prior.plot) <- namey
names(fcast.plot) <- namey

#save line.----
png(output.path, height = 8, width = 6, units = 'in', res = 300)

#Plot fits.----
par(mfrow = c(3,2),
    mar = c(1,1,1,1),
    oma = c(4,4,3,1))
trans = 0.4
for(i in 1:length(namey)){
  #grab observations, set x and y limits
   obs1 <- prior.plot[[i]][,1]
  pred1 <- prior.plot[[i]][,2]
   obs2 <- fcast.plot[[i]][,1]
  pred2 <- fcast.plot[[i]][,2]
   lab <- namey[i]
   limx <- c(min(pred1,pred2), max(pred1,pred2))
   limy <- c(min(obs1 ,obs2 ), max(obs1 , obs2))
   #prior plot panel.
   mod <- lm((obs1) ~ (pred1))
   rsq <- round(summary(mod)$r.squared, 2)
   plot((obs1) ~ (pred1), pch = 16, bty = 'l', ylab = NA, xlab = NA, xlim = limx, ylim = limy)
   abline(0,1,lwd = 2)
   abline(mod, lwd = 2, lty = 2, col= adjustcolor('purple', trans))
   mtext(lab, side = 3, adj = 0.05, line = -2.0)
   mtext(bquote(R^2 == .(rsq)), side = 3, adj = 0.05, line = -3.75)

  #fcast plot panel.
   mod <- lm((obs2) ~ (pred2))
   rsq <- round(summary(mod)$r.squared, 2)
   plot((obs2) ~ (pred2), pch = 16, bty = 'l', ylab = NA, xlab = NA, xlim = limx, ylim = limy)
   abline(0,1,lwd = 2)
   abline(mod, lwd = 2, lty = 2, col= adjustcolor('purple', trans))
   mtext(bquote(R^2 == .(rsq)), side = 3, adj = 0.05, line = -8)

}
#outer labels.
mtext('predicted', side = 1, cex = 1.5, outer = T, line = 2.5)
mtext('observed' , side = 2, cex = 1.5, outer = T, line = 2.0)
mtext('in-sample'    , side = 3, cex = 1.5, outer = T, line = -0.5, adj = 0.20)
mtext('out-of-sample', side = 3, cex = 1.5, outer = T, line = -0.5, adj = 0.875)

#end plot.----
dev.off()


# tidy_tables.R
# written by Tim Riley, 2020-06-08
packages <- c(
  "tidyverse",
  "sf",
  "here"
)

invisible(lapply(packages, library, character.only = TRUE))

data <- read_csv(here("data","2020-04-16_2020-05-16.csv")) %>%
  mutate(Date = as.Date(Date, "%d/%m/%y")) %>%
  pivot_longer(
    cols = -Date,
    names_to = c("loc_name", "type", "direction"),
    names_sep = "_",
    values_to = "count"
  )

summary <- data %>%
  filter(type == "total") %>%
  select(loc_name, count) %>%
  group_by(loc_name) %>%
  summarize(monthAvgTot = round(sum(count) / 31)) %>%
  left_join(data %>%
           filter(type == "ped") %>%
           select(loc_name, count) %>%
           group_by(loc_name) %>%
           summarize(monthAvgPed = round(sum(count) / 31))
  ) %>%
  left_join(data %>%
              filter(type == "cyc") %>%
              select(loc_name, count) %>%
              group_by(loc_name) %>%
              summarize(monthAvgCyc = round(sum(count) / 31))
  )

write_csv(summary, paste(here("data"), "summary.csv", sep = "/"))


source('2021-06-02-jsa-type-v2-china/init.r')

#########################################################
# N species per year

# By country
rfile <- paste0(v2_dir_china, "01-map/lat-lon.csv")
df <- fread(rfile)

df_latlon <- df[!(is.na(lat) | is.na(lon))]

n_species <- df_latlon[china=="CHN" & status =="Valid species", .N, by="date"]
n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(date)]
n_species$N <- cumsum(n_species$N)

p <- ggplot(n_species, aes(date, N)) + theme_minimal() +
    geom_path(color='black', size=1) +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    # geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks100, minor_breaks=ybreaks50) +
    xlab("\nYear") + ylab("Number of valid species \n")

ggsave(paste0(v2_dir_china, '03-time-series-01a.png'), p, units="cm", width=15, height=8, dpi=300)

# By pri div
n_species <- df_latlon[china=="CHN" & status =="Valid species", ]
x <- n_species[,.N, by=pri][N>10]
n_species <- n_species[pri %in% x$pri,.N, by=c("date", "pri")]

n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(pri, date)]

template <- expand.grid(date=seq(min(n_species$date), max(n_species$date)), pri=x$pri)
n_species <- merge(template, n_species, by=c("pri", "date"), all.x=T, all.y=F)
n_species <- data.table(n_species)
n_species[is.na(N)]$N <- 0
n_species[, N := cumsum(N), by="pri"]

n_species$pri <- as.character(n_species$pri)
n_species$pri <- factor(n_species$pri, levels=sort(unique(n_species$pri)))

p <- ggplot(n_species, aes(date, N)) + theme_minimal() +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    geom_path(color='black', size=1) +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks20, limits=c(0, 100)) +
    # scale_y_continuous(breaks=ybreaks100, minor_breaks=ybreaks50) +
    facet_wrap(. ~ pri, ncol=3) +
    xlab("\nYear") + ylab("Number of valid species \n")

ggsave(paste0(v2_dir_china, '03-time-series-01c.png'), p, units="cm", width=15, height=18, dpi=300)

# Using Ascher's fields

# CH, HK, MC

# Valid species
n_species <- df[type.country_n %in% c("CH", "HK", "MC"), .N, by=c("date", "status")]
n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(status, date)]
n_species[, N := cumsum(N), by="status"]
unique(n_species$status)

p <- ggplot(n_species, aes(date, N, color=status)) + theme_minimal() +
    geom_path(size=1) +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    # geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks100, minor_breaks=ybreaks50) +
    xlab("\nYear") + ylab("Number of species \n") +
    labs(color="")

ggsave(paste0(v2_dir_china, '03-time-series-01a-new.png'), p, units="cm", width=15, height=8, dpi=300)

# Species accumulation curve

n_species <- df[status =="Valid species"]
n_species$mapper_cty<- lapply(n_species$global.mapper_n, function(x) strsplit(x, "; ")[[1]])
n_species <- data.table(n_species %>% unnest(mapper_cty))
n_species <- n_species[mapper_cty %in% c("CH", "HK", "MC")]
n_species$mapper_cty <- NULL
n_species <- unique(n_species)

n_species <- n_species[, .N, by=c("date")]
n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(date)]
n_species[, N := cumsum(N), ]
unique(n_species$status)

p <- ggplot(n_species, aes(date, N)) + theme_minimal() +
    geom_path(color="black", size=1) +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    # geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks200, minor_breaks=ybreaks100) +
    xlab("\nYear") + ylab("Number of valid species \n") +
    labs(color="")

ggsave(paste0(v2_dir_china, '03-time-series-01b-new.png'), p, units="cm", width=15, height=8, dpi=300)

# CH, HK, MC + PG, TW, IN:AR

# Valid species
n_species <- df[
    type.country_n %in% c("CH", "HK", "MC", "PG", "TW") |
    (type.country_n == "IN" & type.state == "AR"), .N, by=c("date", "status")
]

n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(status, date)]
n_species[, N := cumsum(N), by="status"]
unique(n_species$status)

p <- ggplot(n_species, aes(date, N, color=status)) + theme_minimal() +
    geom_path(size=1) +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    # geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks100) +
    xlab("\nYear") + ylab("Number of species \n") +
    labs(color="")

ggsave(paste0(v2_dir_china, '03-time-series-01a-max.png'), p, units="cm", width=15, height=8, dpi=300)

# Species accumulation curve

n_species <- df[status =="Valid species"]

india <- n_species[grepl("IN:AR", global.mapper) | grepl("IN:AR", merged.global.mapper)]

n_species$mapper_cty <- lapply(n_species$global.mapper_n, function(x) strsplit(x, "; ")[[1]])
n_species <- data.table(n_species %>% unnest(mapper_cty))
n_species <- n_species[mapper_cty %in% c("CH", "HK", "MC", "PG", "TW")]
n_species$mapper_cty <- NULL
n_species <- unique(n_species)

n_species <- unique(rbind(n_species, india))

n_species <- n_species[, .N, by=c("date")]
n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(date)]
n_species[, N := cumsum(N), ]
unique(n_species$status)

p <- ggplot(n_species, aes(date, N)) + theme_minimal() +
    geom_path(color="black", size=1) +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    # geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks200) +
    xlab("\nYear") + ylab("Number of valid species \n") +
    labs(color="")

ggsave(paste0(v2_dir_china, '03-time-series-01b-max.png'), p, units="cm", width=15, height=8, dpi=300)

# By pri div
dir_geo_chn <- "data/geo_processed/gadm/china/gadm36_CHN_shp/"
v_chn_pri <- st_read(paste0(dir_geo_chn, "gadm36_CHN_1.shp"))
lp_chn_pri <- data.table(v_chn_pri)[, c("HASC_1", "NAME_1")]
lp_chn_pri$lp_pri <- unlist(lapply(lp_chn_pri$HASC_1, function(x) strsplit(x, "\\.")[[1]][[2]]))
lp_chn_pri$HASC_1 <- NULL

n_species <- df[type.country_n=="CH",]
n_species[grepl("SN", type.state)]$type.state <- "SA"
n_species[grepl(";", type.state)]$type.state <- unlist(lapply(n_species[grepl(";", type.state)]$type.state, function(x) strsplit(x, ";")[[1]][[1]]))
n_species <- merge(n_species, lp_chn_pri, by.x="type.state", by.y="lp_pri", all.x=T, all.y=F)

n_species[is.na(NAME_1), .N]
n_species <- n_species[!is.na(NAME_1)]
# 18 species without state excluded

x <- n_species[,.N, by=c("NAME_1")][N>10]
n_species <- n_species[NAME_1 %in% x$NAME_1,.N, by=c("date", "NAME_1", "status")]
n_species$date <- as.integer(n_species$date)
n_species <- n_species[order(status, NAME_1, date)]

template <- expand.grid(date=seq(min(n_species$date), max(n_species$date)), NAME_1=x$NAME_1, status=unique(df$status))
n_species <- merge(template, n_species, by=c("NAME_1", "status", "date"), all.x=T, all.y=F)
n_species <- data.table(n_species)
n_species[is.na(N)]$N <- 0
n_species[, N := cumsum(N), by=c("status", "NAME_1")]

n_species$NAME_1 <- as.character(n_species$NAME_1)
n_species$NAME_1 <- factor(n_species$NAME_1, levels=sort(unique(n_species$NAME_1)))

p <- ggplot(n_species, aes(date, N, color=status)) + theme_minimal() +
    # geom_smooth(fill=NA, color='black', size=1) +
    # geom_point(size=1, color='grey') +
    geom_path(size=1) +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    scale_y_continuous(breaks=ybreaks20, limits=c(0, 80)) +
    # scale_y_continuous(breaks=ybreaks100, minor_breaks=ybreaks50) +
    facet_wrap(. ~ NAME_1, ncol=3) +
    xlab("\nYear") + ylab("Number of valid species \n") +
    labs(color="")

ggsave(paste0(v2_dir_china, '03-time-series-01c-new.png'), p, units="cm", width=18, height=18, dpi=300)

#########################################################
# N active authors per year

file <- paste0(v2_dir_data_raw, v2_basefile, "-describer_2.csv")
df_des <- read_escaped_data_v2(file)

# Part 1: all valid species
des <- df_des[!is.na(max_corrected) & residence.country.describer.first_long == "China",
    c(
        "full.name.of.describer", "min", "max_corrected",
        "ns_species_per_year_active"
    )
]

df_des[grepl("Orr", full.name.of.describer)]

# Expand dataset by min and max years
seq <- mapply(
    function(a, b) seq(a, b),
    a = des$min, b = des$max_corrected
)

des$years <- seq
des <- data.table(des %>% unnest(years))
des$years <- as.integer(des$years)

# Calculate number of describers, and weighted number of describers
des$ns_species_per_year_active <- as.numeric(des$ns_species_per_year_active)

taxonomic_effort1 <- des[, list(
    N_describers = length(unique(full.name.of.describer)),
    N_weighted_describers = sum(ns_species_per_year_active)
    ),
by = years][order(years)]

p <- ggplot(taxonomic_effort1, aes(years, N_describers)) + theme_minimal() +
    geom_smooth(fill=NA, color='black', size=1) +
    geom_point(size=1, color='grey') +
    geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    xlab("\nYear") + ylab("Number of active describers\n")

ggsave(paste0(v2_dir_china, '03-time-series-02.png'), p, units="cm", width=15, height=8, dpi=300)

p <- ggplot(taxonomic_effort1, aes(years, N_weighted_describers)) + theme_minimal() +
    geom_smooth(fill=NA, color='black', size=1) +
    geom_point(size=1, color='grey') +
    geom_line(size=.5, color='grey', linetype='dashed') +
    scale_x_continuous(breaks=ybreaks50, minor_breaks=ybreaks10) +
    xlab("\nYear") + ylab("Number of active describers\n")

ggsave(
    paste0(v2_dir_china, '03-time-series-03.png'), p,
    units="cm", width=15, height=8, dpi=300
)

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


context("impute s3 methods")
library(simpute)
library(testthat)

test_that("numeric median imputation works", {
  expect_equal(impute(c(1,NA,2,3,NA)), c(1,2,2,3,2))
})

test_that("character mode imputation works", {
  expect_equal(impute(c('a', 'a', NA, 'b')), c('a', 'a', 'a', 'b'))

  expect_warning(val <- impute(c(NA, NA, NA, NA)))

  expect_equal(val, c(NA, NA, NA, NA))
})

test_that("factor mode imputation works", {
  fac = as.factor(c('b', 'b', NA, 'a'))
  fac2 = as.factor(c('b', 'b', 'b', 'a'))
  expect_equal(impute.factor(fac), fac2 )
  expect_equal(impute.factor(factor(fac, ordered = TRUE)), factor(fac2, ordered = TRUE) )
})

test_that("logical mode imputation works", {
  expect_equal(impute(c(TRUE, TRUE, FALSE, NA, NA)), c(TRUE, TRUE, FALSE, TRUE, TRUE) )
})

test_that("data frame imputation works", {
  test_data = dplyr::tibble(num = c(1,NA,2,3,NA),
                         char = c('a', 'a', NA, 'b', NA),
                         fac = as.factor(c('b', 'b', NA, 'a', NA)),
                         logical = c(TRUE, TRUE, FALSE, NA, NA))
  test_data_complete = dplyr::tibble(num = c(1,2,2,3,2),
                         char = c('a', 'a', 'a', 'b', 'a'),
                         fac = as.factor(c('b', 'b', 'b', 'a', 'b')),
                         logical = c(TRUE, TRUE, FALSE, TRUE, TRUE))
  expect_equal(impute.data.frame(test_data), test_data_complete )
})


library(data.table)

file <- "gadm36_0_Ecoregions2017_realm.csv"
df <- fread(file, encoding = "UTF-8", stringsAsFactors = FALSE)

df2 <- df[, list(
    area = sum(area)
), by=c("GID_0", "REALM")]

df3 <- dcast(df2, GID_0 ~ REALM, value.var = "area", fun.aggregate = sum)
df3 <- df3[trimws(GID_0) != ""]

df4 <- cbind(id = df3[, 1], df3[, -1]/rowSums(df3[, -1]))
largest <- colnames(df4)[-1][apply(df4[, -1], 1, which.max)]
df4$largest_prop <- apply(df4[,-1], 1, max, na.rm=TRUE)
df4$largest <- largest

fwrite(df4, "prop-area.csv")


rm(list=ls())

myfilters <- matrix(data=c("CSV file (*.csv)", "*.csv", "All files (*.*)", "*.*"), nrow=2, ncol=2,
                    byrow=TRUE)

msb_filename <- choose.files(default="SWB_daily_mass_balance_report.csv",
                             caption="Choose the daily mass balance report file you wish to plot",
                             multi=FALSE,
                             filters=myfilters,
                             index=1)

setwd( dirname(msb_filename) )

titleTxt <- winDialogString(message="Enter the title you wish to use in the plots",
                            default="Mass Balance Plot")
cex.main=1.0

mb_in<-read.csv(msb_filename, header=TRUE, as.is=TRUE, row.names=NULL)

# appears to be an error in read.csv regarding row names...kludge to get around this
colnames(mb_in)<-colnames(mb_in)[-1]
mb_in<-mb_in[-ncol(mb_in)]

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

pdf(file = "SWB_mass_balance_plot.pdf",width = 11, height = 8.5)
layout(matrix(c(1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6), nrow=16 , ncol=1, byrow = TRUE))

mb <- mb_in

par(mar = c(0,0,2,0))
plot(1,1,type = "n",frame.plot = FALSE,axes = FALSE)
u <- par("usr")
text(1,u[4],labels = titleTxt,col = "blue",pos = 1, cex=2)

y<-as.vector(c(mb$Mean.Max.Temp,rev(mb$Mean.Min.Temp)))
x<-as.vector(c(mb$Date,rev(mb$Date)))

ylim.min <- min(mb$Mean.Min.Temp)
ylim.max <- max(mb$Mean.Max.Temp)
ylim.max <- ylim.max + 0.025 * (ylim.max - ylim.min)
ylim.min <- ylim.min - 0.025 * (ylim.max - ylim.min)

par(mar=c(3,6,3,3))
plot(Mean.Min.Temp ~ Date, data=mb,xlab="",ylab="TEMPERATURE, \nIN DEGREES FAHRENHEIT",
    col="navyblue",type="n", ylim=c(ylim.min,ylim.max),cex.main=cex.main,
    font.lab=2, tcl=0.3)
polygon(x,y,col="grey80", border=NA)
axis.Date(mb$Date,side=3,labels=F, tcl=0.3)
axis(side=4,at=axTicks(side=2),labels=F,tcl=0.3)
abline(h=32.0,col="black")
box(lwd=1.5)

# now plot INPUTS
par(mar=c(3,6,1,3))
y0 <- mb$Gross.Precip
y1 <- mb$Net.Rainfall
y2 <- mb$Snowmelt + y1
#y3 <- mb$Irrigation + y2
y3 <- 0 + y2

x<-as.vector(c(mb$Date,rev(mb$Date)))
ylim.min<-0.
ylim.max<-max(c(y0,y1,y2,y3))
ylim.max<-ylim.max + 0.025 * (ylim.max - ylim.min)
ylim.min<-ylim.min - 0.025 * (ylim.max - ylim.min)

plot(Mean.Min.Temp ~ Date, data=mb,xlab="",ylab="INPUTS, \nIN ACRE-FEET",
    col="navyblue",type="n", ylim=c(ylim.min,ylim.max),cex.main=cex.main,
    font.lab=2, tcl=0.3)
polygon(x,c(y0,rep(0,length(y0))),col="green", border=NA)
polygon(x,c(y1,rep(0,length(y1))),col="lightgreen", border=NA)
polygon(x,c(y2,rev(y1)),col="dodgerblue", border=NA)
polygon(x,c(y3,rev(y2)),col="mediumpurple", border=NA)
axis.Date(mb$Date,side=3,labels=F, tcl=0.3)
axis(side=4,at=axTicks(side=2),labels=F,tcl=0.3)
legend("topright",legend=c("GROSS PRECIP","NET RAINFALL","SNOWMELT","IRRIGATION"),
  fill=c("green","lightgreen","dodgerblue","mediumpurple"),inset=c(0.02,0.05),cex=0.8,lty=NULL)

abline(h=0)
box(lwd=1.5)

# now plot storage
par(mar=c(3,6,1,3))
y1<-mb$TOTAL.Soil.Moisture.Storage
y2<-mb$TOTAL.Surface.Storage..snow. + y1
x<-as.vector(c(mb$Date,rev(mb$Date)))
ylim.min<-min(c(y1,y2))
ylim.max<-max(c(y1,y2))
ylim.max<-ylim.max + 0.025 * (ylim.max - ylim.min)
ylim.min<-ylim.min - 0.025 * (ylim.max - ylim.min)

plot(Mean.Min.Temp ~ Date, data=mb,xlab="",ylab="STORAGE, \nIN ACRE-FEET",
    col="navyblue",type="n", ylim=c(ylim.min,ylim.max),cex.main=cex.main,
    font.lab=2, tcl=0.3)
polygon(x,c(y1,rep(0,length(y1))),col="wheat3", border=NA)
polygon(x,c(y2,rev(y1)),col="dodgerblue", border=NA)
axis.Date(mb$Date,side=3,labels=F, tcl=0.3)
axis(side=4,at=axTicks(side=2),labels=F,tcl=0.3)
legend("top",legend=c("SOIL MOISTURE","SNOW"),
  fill=c("wheat3","dodgerblue"),inset=c(0.02,0.05),cex=0.8,lty=NULL)

box(lwd=1.5)

# now plot AET
par(mar=c(3,6,1,3))
y1<-mb$Actual.Evapotranspiration
x<-as.vector(c(mb$Date,rev(mb$Date)))
ylim.min<-min(y1)
ylim.max<-max(y1)
ylim.max<-ylim.max + 0.025 * (ylim.max - ylim.min)
ylim.min<-ylim.min - 0.025 * (ylim.max - ylim.min)

plot(Mean.Min.Temp ~ Date, data=mb,xlab="",ylab="ACTUAL ET, \nIN ACRE-FEET",
    col="navyblue",type="n", ylim=c(ylim.max,ylim.min),cex.main=cex.main,
    font.lab=2, tcl=0.3)
polygon(x,c(y1,rep(0,length(y1))),col="yellow2", border=NA)
axis.Date(mb$Date,side=3,labels=F, tcl=0.3)
axis(side=4,at=axTicks(side=2),labels=F,tcl=0.3)
abline(h=0)
box(lwd=1.5)

par(mar=c(4,6,1,3))
y1<-mb$Recharge
y2<-mb$Rejected.Recharge + y1
y3<-mb$Surface.Flow.Out.of.Grid + y2
x<-as.vector(c(mb$Date,rev(mb$Date)))
ylim.min<-min(c(y1,y2,y3))
ylim.max<-max(c(y1,y2,y3))
ylim.max<-ylim.max + 0.025 * (ylim.max - ylim.min)
ylim.min<-ylim.min - 0.025 * (ylim.max - ylim.min)

plot(Mean.Min.Temp ~ Date, data=mb,xlab="",ylab="FLOW OUT, \nIN ACRE-FEET",
    col="navyblue",type="n", ylim=c(ylim.max,ylim.min),cex.main=cex.main,
    font.lab=2, tcl=0.3)
polygon(x,c(y1,rep(0,length(y1))),col="green", border=NA)
polygon(x,c(y2,rev(y1)),col="red", border=NA)
polygon(x,c(y3,rev(y2)),col="navy", border=NA)
axis.Date(mb$Date,side=3,labels=F, tcl=0.3)
axis(side=4,at=axTicks(side=2),labels=F,tcl=0.3)
abline(h=0)
legend("bottomright",legend=c("RECHARGE","REJECTED RECHARGE","SURFACE FLOW OUT OF GRID"),
  fill=c("green","red","navy"),inset=c(0.02,0.05),cex=0.8,lty=NULL)
box(lwd=1.5)

dev.off()


#!/usr/bin/env Rscript
#
#  otu_summary_stats.sh - summarize OTUs per taxon
#
#  Version 1.1.0 (June 16, 2015)
#
#  Copyright (c) 2014-2015 Andrew Krohn
#
#  This software is provided 'as-is', without any express or implied
#  warranty. In no event will the authors be held liable for any damages
#  arising from the use of this software.
#
#  Permission is granted to anyone to use this software for any purpose,
#  including commercial applications, and to alter it and redistribute it
#  freely, subject to the following restrictions:
#
#  1. The origin of this software must not be misrepresented; you must not
#     claim that you wrote the original software. If you use this software
#     in a product, an acknowledgment in the product documentation would be
#     appreciated but is not required.
#  2. Altered source versions must be plainly marked as such, and must not be
#     misrepresented as being the original software.
#  3. This notice may not be removed or altered from any source distribution.
#

## Recieve input file from bash
args <- commandArgs(TRUE)
d <- read.table(args[1], sep="\t")

## extract counts and produce summary stats

titles <- c("mean", "median", "min", "max")
otu_counts <- d[,2]
stats <- c(mean(otu_counts), median(otu_counts), min(otu_counts), max(otu_counts))

result = data.frame(stat = (titles), value = (stats))

## write result to output file

write.table(result, file = "otus_per_taxon_summary.txt", quote = FALSE, col.names = TRUE, sep = "\t", row.names = FALSE)


  xtab.2way = function( xval, factors ) {
    k = median( xval, na.rm=TRUE ) # rescale for floating point math
    v =  as.matrix( xtabs( as.integer( xval * k ) ~ factors[,1] + factors[,2] ) /k )
    rn = rownames(v)
    cn = colnames(v)
    attr(v, "dimnames") = NULL
    attr(v, "class") = NULL
    attr(v, "call") = NULL
    w = as.data.frame(v)
    rownames(w) = rn
    colnames(w) = cn
    return (w)
  }


#import arules library
library(arules)

#set working directory
setwd("/root/Desktop/mercy520/arules")

#import csv database
RuleDB <- read.transactions(file="2016_Racial_Profiling_Dataset_Arrests.csv", sep=",")

print("###list.files() function output###")
list.files()

print("###dim() function output###")
dim(RuleDB)

print("###class() function output###")
str(RuleDB)
class(RuleDB)

print("###inspect() function output###")
aprRuleDB <- apriori(RuleDB)
inspect(aprRuleDB)