## Library loading
library(reshape2);
library(vegan);
library(dplyr)
library(ade4);
library(plotly)
library(compositions);
library(pracma);
library(DESeq2);
library(fpc);
library(tidyverse)
library(purrr)
library(cluster)
library(RColorBrewer)
library(ape)

# Migrate to location of repository and downloaded test data:
# setwd($PATH/analyzing_microbiome_timeseries/module1_clustering/)
load("TESTDATA_DIEL18S.RData",verbose=T)

# To address ecological questions, you may need to perform some quality
# control on your OTU data. (1) Below, first global singletons are removed.
# This is unwanted noise in the form of OTUs which only have one sequence
# in the entired dataset.
# (2) Then, any OTUs assigned a Metazoan taxonomic identity are removed. This
# is because the methods used to generate this 18S data are not suitable
# to capture the metazoan community.
# (3) Finally, while we are mainly working with OTU.IDs throughout this tutorial
# we want to eventually add back in the taxonomic identities. So we make a taxonomy
# key dataframe ('tax_key')
#
# (1) Remove global singletons (where a single OTU appears with only 1 sequence in the entire dataset)
rowsum<-apply(test_data[2:20],1,sum) # sum numerics in OTU table by row
counts.no1 = test_data[ rowsum>1, ]  # remove rows that sum to 1 or less
dim(test_data)[1] - dim(counts.no1)[1] # report total number of singletons removed
#
# (2) Filter out OTUs which belong to the metazoa:
counts.filtered<-counts.no1[-(which(counts.no1$Level3 %in% "Metazoa")),] # Remove from counts
dim(counts.no1);dim(counts.filtered) # Test data should be left with 1984 total OTUs
#
# (3) Create taxonomy key:
names(counts.filtered)
seq_counts<-counts.filtered[1:20]
tax_key<-counts.filtered[c(1,21:31)]; head(tax_key[1:2,])
# Modify seq_counts data frame so row.names = OTU.ID and all values are numeric
row.names(seq_counts)<-seq_counts$OTU.ID
seq_counts$OTU.ID<-NULL; head(seq_counts[1:2,])

# Because these data are compositional, they are on a simplex.
# The data being on a simplex means, if we know the abundances of all of the OTUs except for one, we still have the
# same amount of information as if we knew all of the OTUs.
# Evidence:
# Estimate covariance matrix for OTUs
covariance_matrix<-as.matrix(seq_counts)%*%t(seq_counts)
# Evaluate determinant of covariance matrix
cov_determinant<-det(covariance_matrix)
cov_determinant #0
# The determinant of the covariance matrix (what we just calculated) is equivalent to the product of the
# proportion of variance explained by every PCA axis. If the determinant is 0, that means there is an axis which
# explains 0 variance that we can't separate from the other axes. The data need to be transformed to be suitable
# for PCA.

## Another approach to PCA ordination w/Compositional Data: Log-Ratio Transformations
# Log-ratio
log_rats<-data.frame(compositions::ilr(t(seq_counts)))
# These are complicated to interpret however because you move from D simplex to D-1 euclidean
# But using these we can see we are now in invertible covariance regime

## Checking the difference the log-ratio made on the data characteristics
new_covdet<-det(as.matrix(log_rats)%*%t(log_rats))
cov_determinant #Original Count Data
new_covdet # After doing a log ratio, you see that none of the axes are equal to 0

# AND change command so its the same.
lograt_pca<-prcomp(log_rats)
# Look at this
lograt_variances<-lograt_pca$sdev^2/sum(lograt_pca$sdev^2)
barplot(lograt_variances,
        main='Log-Ratio PCA Screeplot',
        xlab='PC Axis',
        ylab='% Variance',
       col=c(rep('black',1),rep('grey',18)),
       cex.names=1.5,cex.axis=1.5,cex.lab=1.5,cex.main=1.5)
legend('topright',fill=c('black','grey'),c('Should Present','??? Judgment Call'))

## We conclude a more faithful representation is to plot this ordination in 2D because the 3rd and 4th axes appear
## very similar, and we can't construct a 4D plot
pca_lograt_frame<-data.frame(lograt_pca$x,
                          time_of_day=gsub('^.*_','',rownames(lograt_pca$x)))
ggplot(pca_lograt_frame)+
    geom_point(aes(x=PC1,y=PC2,col=time_of_day))+
    ylab(paste0('PC2 ',round(lograt_variances[2]*100,2),'%'))+
    xlab(paste0('PC1 ',round(lograt_variances[1]*100,2),'%'))+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    ggtitle('Log-Ratio PCA Ordination')+
    coord_fixed(ratio=lograt_variances[2]/lograt_variances[1])+
    theme_bw()

# So let's start by looking at PCoA. PCoA is doing a PCA on a distance matrix constructed from the data.
# We then need a distance matrix.
# Different distance metrics emphasize separate attributes/factors in microbial community comparison
# For instance, if we want to prioritize differences in presence/absence between samples
jac_dmat<-vegdist(t(seq_counts),method="jaccard") # p/a example
pcoa_jac<-ape::pcoa(jac_dmat) #perform PCoA
# Now we need to inspect how the PCoA turned out. We look at a Screeplot for this.
# The screeplot shows the amount of variance explained by each axis
samp_no<-dim(seq_counts)[2]
jac_variances<-pcoa_jac$values$Relative_eig
par(mar=c(5,6,4,1)+.1)
barplot(jac_variances,
        xlab='Principal Coordinate Axis',
        ylab='% Variance',
       col=c(rep('black',2),'darkgrey',rep('lightgrey',16)),
       cex.names=2,cex.axis=2,cex.lab=2,cex.main=1,
       names.arg=as.character(1:18))
legend('topright',fill=c('black','darkgrey','lightgrey'),c('Should Present','Judgment Call','Unnecessary to Present'),cex=2)
# How to read this plot: Before we plot the actual ordination, we need to decide which axes to present.
# We need to select as few axes as possible (so we can visualize) which capture large amounts of variance.
# In this example, we see the first axis captures most of the variance, so we definitely will show that one.
# Then the next two axes show less, but a similar amount, and the remaining all show way less in comparison.
# Therefore, we can exclude everything after the 3rd axis. Because axes 2 and 3 capture similar amounts of variance,
# if we show one, we need to show the other one to be faithful to the data.

# Performing the log-ratio transformation makes the data all occupy a similar dynamic range, so we can use
# magnitude-sensitive distances like euclidean distance

euc_dmat<-dist(log_rats)

## Conduct ordination w/distance matrix
pcoa_euc<-ape::pcoa(euc_dmat)
#euc_variances<-pcoa_euc$sdev^2/sum(pcoa_euc$sdev^2)
euc_variances<-pcoa_euc$values$Relative_eig
par(mar=c(5,6,4,1)+.1)
barplot(euc_variances,
        xlab='Principal Coordinate Axis',
        ylab='% Variance',
       col=c(rep('black',2),rep('darkgrey',2),rep('lightgrey',17)),
       cex.names=2,cex.axis=2,cex.lab=2,cex.main=1,
       names.arg=as.character(1:18))
legend('topright',fill=c('black','darkgrey','lightgrey'),c('Should Present','Judgment Call','Unnecessary'),cex=2)
#
# By trying 2 different metrics, we see a differences in ordination output.
# For Jaccard distance, we see we need 3 axes to present the ordination. Using euclidean distance,
# because of the complex covariance structure of the relative compositions, the data do not easily
# ordinate into 2 or 3 dimensions.

# How dissimilar are my samples with respect to diversity?
## P/A is recommended when asking questions about the ENTIRE community
# Does the active microbial community change depending on time of day?
# To emphasize changes in presence/absence, we elect to use Jaccard distance for ordination.
# Our ordination indicates the data are most suitably summarized
# with 3 dimensions.
#pcoa_jac_frame<-data.frame(pcoa_jac$x,
#                           time_of_day=gsub('^.*_','',rownames(pcoa_jac$x)))
pcoa_jac_frame<-data.frame(pcoa_jac$vectors,time_of_day=gsub('^.*_','',rownames(pcoa_jac$vectors)))
eigenvalues<-round(jac_variances,4)*100
plot_ly(pcoa_jac_frame,type='scatter3d',mode='markers',
        x=~Axis.2,y=~Axis.3,z=~Axis.1,colors=~brewer.pal(6,'Set1'),color=~time_of_day)%>%
  layout(font=list(size=18),
         #title='PCoA Jaccard Distance',
         scene=list(xaxis=list(title=paste0('Co 2 ',eigenvalues[2],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         yaxis=list(title=paste0('Co 3 ',eigenvalues[3],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         zaxis=list(title=paste0('Co 1 ',eigenvalues[1],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
        aspectratio = list(x=3*eigenvalues[2]/eigenvalues[1])), y=3*eigenvalues[3]/eigenvalues[1], z=3)

## To compare with the euclidean distance ordination representing differences in relative composition
#pcoa_euc_frame<-data.frame(pcoa_euc$x,
#                          time_of_day=gsub('^.*_','',rownames(pcoa_euc$x)))
pcoa_euc_frame<-data.frame(pcoa_euc$vectors,time_of_day=gsub('^.*_','',rownames(pcoa_euc$vectors)))
euc_eigenvalues<-round(euc_variances,4)*100
plot_ly(pcoa_euc_frame,type='scatter3d',mode='markers',
        x=~Axis.3,y=~Axis.2,z=~Axis.1,colors=~brewer.pal(6,'Set1'),color=~time_of_day)%>%
  layout(font=list(size=18),
         #title='PCoA Euclidean Distance',
         scene=list(xaxis=list(title=paste0('Co 3 ',euc_eigenvalues[3],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         yaxis=list(title=paste0('Co 2 ',euc_eigenvalues[2],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
         zaxis=list(title=paste0('Co 1 ',euc_eigenvalues[1],'%'),
                    showticklabels=FALSE,zerolinecolor='black'),
                   aspectratio = list(x=3*euc_eigenvalues[3]/euc_eigenvalues[1],
                                      y=3*euc_eigenvalues[2]/euc_eigenvalues[1],
                                      z=3)))
## Further note: If your ordination has data which align in a 'T' or '+' shape perpendicular to the axes
## this is often diagnostic of covariance attributed to the higher dimensions which are not plotted

# To corroborate the 3-D plot, use a simple average
## hierarchical clustering and plot the dendrogram.
## Some of the same pattern emerge, but it is not as
## clear as the 3-D representation.
cluster_ex<-hclust(vegdist(t(seq_counts),method='jaccard'),method="complete") #Using Jaccard distance so apples to apples
plot(cluster_ex,main='Jaccard Hierarchical Agglomerative Clustering',xlab='',sub='')

# Although our statistical ordinations appear to require at least 3 dimensions to communicate the data.
# However, we don't always have the budget for a 3D plot. So we may want to impose the condition on an ordination
# technique that the answer MUST go in 2D. We turn to NMDS here.
#
set.seed(071510) # setting random seed to assure NMDS comes out the same every time
## So we can compare the relative composition based distance metric to the presence/absence based distance metric
euc_nmds<-metaMDS(euc_dmat,k=2,autotransform=FALSE)
jac_nmds<-metaMDS(jac_dmat,k=2,autotransform=FALSE)

# Take a look at stress - overall this value is not extremely informative, but know that the
# closer stress is to 1 the less representative of your actual data the NMDS is
euc_nmds$stress #Stress ~0.075
jac_nmds$stress #Stress ~0.073 So the Jaccard NMDS is a ***slightly*** more parsimonious ordination.

# Additionally, the axes for NMDS are totally arbitrary, so axis scaling does not matter
# and data can be rotated/reflected about axes and the NMDS is still the same
euc_frame<-data.frame(euc_nmds$points,
                         time_of_day=gsub('^.*_','',rownames(log_rats)))
jac_frame<-data.frame(jac_nmds$points,
                     time_of_day=gsub('^.*_','',rownames(log_rats)))
## Plotting euclidean distance NMDS
ggplot(euc_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=2)+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+ggtitle('Euclidean Distance NMDS')
## Plotting Jaccard distance NMDS
ggplot(jac_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=2)+
        scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+ggtitle('Jaccard Distance NMDS')
## For paper figures
euc_fig<-ggplot(euc_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=10)+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+theme(legend.position='none',text=element_text(size=24))+
xlab('NMDS 1')+ylab('NMDS 2')
jac_fig<-ggplot(jac_frame,aes(x=MDS1,y=MDS2,col=time_of_day))+
    geom_point(size=10)+
    scale_color_brewer(palette='Set1',name='Time of Day')+
    theme_bw()+theme(legend.position='none',text=element_text(size=24))+
xlab('NMDS1')+ylab('NMDS2')
euc_fig
jac_fig

## Before we can cluster temporal dynamics, we must make sure species are intercomparable.
## We need to perform normalization steps to ensure intercomparability between species.
## Put another way, the count data are heteroskedastic --
## the mean is correlated with the variance.
within_seq_means<-apply(t(seq_counts),2,mean)
within_seq_vars<-apply(t(seq_counts),2,var)
plot(within_seq_means,within_seq_vars,log='xy',
    main='Heteroskedastic Data',
    xlab='Mean # Counts',
    ylab='Var # Counts')
# Variance (in the amount of times an OTU shows up) is correlated to average count.
# This attribute (common to count data) violates the assumption of constant variance in errors
# which is necessary for standard linear modeling. To use z-scores for comparisons and to detrend our timeseries
#(a kind of linear model), we have to deal with this.

## We stabilize the variances so that they are no longer correlated to the species abundances.
transformed_counts<-DESeq2::varianceStabilizingTransformation(as.matrix(seq_counts))

## Check to see how the transformation did
within_trans_means<-apply(transformed_counts,1,mean)
within_trans_vars<-apply(transformed_counts,1,var)
# Plot:
plot(within_trans_means,within_trans_vars)
# See how now most of the variances are the same between otus?
# This means the data are more intercomparable using a z-score transformation + detrending

# Since the goal is to identify repeating day/night patterns, we need to remove trends we are not considering,
# i.e., linear trends
#?pracma::detrend() for more information
transformed_detrended<-apply(transformed_counts,1,pracma::detrend)
# Now we rescale so numbers are again intercomparable and now overdispersion has been
# dealt with
trans_dt_scaled<-apply(transformed_detrended,2,scale)
## We lost rownames so tack those back on
rownames(trans_dt_scaled)<-colnames(transformed_counts)
#
## Comparing the distribution of the data along every step of the pipeline -- notice how by the time we get to the
## z-scores we're looking more like a standard normal
hist(transformed_counts,
    main='VST Sequence Count Observations',
    xlab='# Total Observations',
    ylab='Frequency')
hist(transformed_detrended,
    main='VST+Detrended Data',
    xlab='Total Observations Accounting for Linear Trends',
    ylab='Frequency')
hist(trans_dt_scaled,
    main='VST+Detrended+Scaled Data (Z-scores)',
    xlab='Expression Level Relative to per-OTU Avg',
    ylab='Frequency')

# Now we're ready to generate a distance matrix for clustering
# Recall what we previously learned about different distance metrics.
# We use euclidean distance below:
temporal_dmat<-dist(t(trans_dt_scaled))
n_clusts<-2:20 # This sets the range of # clusters we divide the data into
# First, the classic hierarchical agglomerative clustering
hc_full_cluster<-hclust(temporal_dmat)
hc_clusts<-lapply(n_clusts,function(x) cutree(hc_full_cluster,x))
## Now we try k-medoids, also a very popular clustering method
## This particular implementation is not optimized for speed, so this may take a minute or so
kmed_clusts<-lapply(n_clusts, function(x) cluster::pam(temporal_dmat,k=x))

## Comparing cluster outcomes
hc_stats<-lapply(hc_clusts,function(x) fpc::cluster.stats(temporal_dmat,
                                                          clustering=x))
kmed_stats<-lapply(kmed_clusts, function(x) fpc::cluster.stats(temporal_dmat,
                                                             clustering=x$clustering))

## We write a helper function to be less redundant
ripping_stats<-function(list,func){
  ## Essentially all this function does is implements a function (func) on a list
  ## and coerces the output to a column vector (this will be handy when we want to make a data frame)
  output<-do.call(rbind,lapply(list,func))
  return(output)
}
func_list<-rep(list(function(x) x$cluster.number,
                function(x) x$within.cluster.ss,
                function(x) x$avg.silwidth,
                function(x) x$ch),2)
stats_list<-rep(list(hc_stats,kmed_stats),each=4)
collected_stats<-purrr::map2(stats_list,func_list,ripping_stats)
nclusts<-rep(n_clusts,length(collected_stats))
method<-rep(c('hc_agg','kmed'),each=length(n_clusts)*length(collected_stats)/2)
ind_name<-rep(c('n','ss','sil','ch'),each=length(n_clusts)) %>%
  rep(2)

## Collecting outputs for plotting
index_frame<-data.frame(index=do.call(rbind,collected_stats),
                        nc=nclusts,
                        Method=method,
                        ind=ind_name)
index_frame %>%
  filter(ind=='ss') %>%
  ggplot(aes(x=nc,y=index,col=Method)) +
  geom_point() +
  geom_line(aes(group=Method)) +
  ylab('Within Cluster Sum Square Error') +
  xlab('Number Clusters')+
  theme_bw()
## Interpretation of plots:
# As we add more clusters (yaxis), we want the sum square error to decrease
# As we allow for more clusters, we are able to describe more of the variability in the data
# so the sum square error decreases.
## trade-off - it will always decrease when you add clusters, but we want to
## add as fewer clusters as possible, hence in this example kmed > hc
# for any given amount of clusters, kmed has less error. So we will continue using kmed approach.

## Plotting out the calinski-harabasz indices for each clustering
## We want this number to be high
index_frame %>%
  filter(ind=='ch') %>%
  ggplot(aes(x=nc,y=index,col=Method)) +
  geom_point() +
  geom_line(aes(group=Method)) +
  ylab('C-H Stat') +
  xlab('Number Clusters')+
theme_bw()

## Silhouette profile: Looking at species variability w/in our 8 clusters
## Extract silhouette profile for the clustering we select
silhouette_profile_kmed8<-cluster::silhouette(kmed_clusts[[7]])
## Reformat for easier plotting
silhouette_frame<-data.frame(cluster=silhouette_profile_kmed8[,1],
                             neighbor=silhouette_profile_kmed8[,2],
                             dist=silhouette_profile_kmed8[,3],
                             otu_id=rownames(silhouette_profile_kmed8))

## Sorting by cluster and ranking by silhouette width
new_silframe<-silhouette_frame %>%
  arrange(dist) %>%
  group_by(cluster) %>%
  mutate(idno=1:n(),
         tot_num=n())

## Plotting silhouette profile of OTUs for each cluster
ggplot(new_silframe,aes(x=idno,y=dist))+
  geom_bar(stat='identity') +
  coord_flip() +
  ggtitle('Silhouette Profiles for Individual Clusters') +
  facet_wrap(~cluster)

## In order to interpret the silhouette profiles, we can compare the width (x-axis) and height (y-axis) of each
## profile. For instance, comparing cluster #3 vs #8: Cluster 3 is much taller (has more species in it) compared to
# cluster 8, but also is much broader (there are more species with intermediate values on the x-axis). This means
# on the whole cluster 3 is less coherent than cluster 8.
## Also keep an eye out for species w/negative silhouette distances -- this means that they have a nearby neighbor
## who belongs in a different cluster and therefore may be only marginally similar to their cluster on the whole

# What is the taxonomic composition of each of the 8 clusters?
## To make ecological sense of the temporal clusters,
## we can pull out a representative species and use their signal over time
## to summarize the temporal trends across the whole cluster
medoid_otus<-kmed_clusts[[7]]$medoids
## Extracting those time series
medoid_dynamics<-trans_dt_scaled[,medoid_otus]

# Using the output from:
head(silhouette_frame)
# We can re-build what the taxonomic composition of each
## of these clusters is.
range(silhouette_frame$cluster) # n=8 clusters with test data

# Join cluster information with taxonomic information
colnames(tax_key)[1]<-"otu_id"
tax_bycluster<-left_join(silhouette_frame, tax_key, by="otu_id") # Recall the taxonomy key we made from above?
head(tax_bycluster[1:2,])

# Summarize taxa with cluster information
tax_bycluster_sum<-tax_bycluster %>%
    group_by(cluster, Taxa) %>%
    summarise(richness =  n()) %>% #Get richness information
    group_by(Taxa) %>%
    mutate(n_per_tax=sum(richness)) %>% #Figure out total number of OTUs assigned to each taxon
    as.data.frame
tax_bycluster_sum$Taxa[which(tax_bycluster_sum$Taxa=='Opisthokonts')]<-'Opisthokont' # Cleaning this up
head(tax_bycluster_sum)

# Plot cluster-to-cluster taxonomic differences
## Values are equal to the total number of OTUs
## belonging to each taxonomic group
#
tax_color<-c("#67000d","#e31a1c","#dd3497","#fcbba1","#fed976","#fc8d59","#a63603","#addd8e","#7f2704","#238b45","#a1d99b","#081d58","#1f78b4","#a6cee3","#8c6bb1","#9e9ac8","#984ea3","#081d58","#662506","#ffffff","#969696","#525252","#000000")
#
ggplot(tax_bycluster_sum, aes(x=cluster, y=richness, fill=Taxa))+
    geom_bar(color="black", stat="identity")+
    coord_flip()+
    scale_fill_brewer(palette='Set3')+
    theme_minimal()+
    scale_x_continuous(breaks=1:8,labels=as.character(1:8),name='Cluster #')+
    scale_y_continuous(name='# Species')+
theme(legend.position='bottom',text=element_text(size=18))+ ## Make the cluster #s happen
guides(fill=guide_legend(nrow=3,byrow=TRUE))

## Demonstrating medoid dynamics for each cluster
medoid_dyn_long<-as.data.frame(t(medoid_dynamics)) %>%
mutate(otu_id=colnames(medoid_dynamics),
      clust_num=1:8) %>%
gather(timepoint,z_score,'1_6PM':'19_6PM') %>%
mutate(time_numeric=as.numeric(gsub('_.*$','',timepoint)),
      plotting_timepoint=paste('Day',ceiling(time_numeric/6),gsub('^.*_','',timepoint)))
#
## We're plotting the y axis as z-scores so that transcripts with different baseline levels are
# more readily intercomparable. Read a z-score y-axis this like this:
# 0 is the average transcript level
# negative numbers are below-average numbers of transcripts
# positive numbers are above-average levels of transcripts
# 1 unit is 1 standard deviation away from the mean (So a value of 1 corresponds to mean+1sd, -1 is mean-1sd)

ggplot()+
geom_point(size=4,
           shape=21,
           color="white",
           aes(fill=factor(clust_num),
              x=time_numeric,
              y=z_score),
          data=medoid_dyn_long)+
geom_line(data=medoid_dyn_long,
          aes(x=time_numeric,
              y=z_score,
              group=otu_id,
              col=factor(clust_num)),size=1.25,linetype=5)+
facet_wrap(~clust_num,ncol=2)+
scale_color_brewer(palette='Set2',name='Cluster #')+
scale_fill_brewer(palette='Set2',guide=FALSE)+
scale_x_continuous(breaks=seq(1,19,by=6),labels=unique(medoid_dyn_long$plotting_timepoint)[c(1,7,13,19)])+
scale_y_continuous(name='Z-score Expression',limits=c(-2,4.5))+
theme(axis.text.x=element_text(angle=90,hjust=0.5,size=18),
      panel.background=element_rect(fill='white'),
     panel.grid.major=element_line(color='gray'),
     axis.title.x=element_blank(),
     text=element_text(size=18))+
geom_rect(data=data.frame(ymin=rep(-2,4),
          ymax=rep(4.5,4),
          xmin=seq(1,19,by=6),
         xmax=c(seq(4,19,by=6),19)),
          aes(xmin=xmin,ymin=ymin,xmax=xmax,ymax=ymax),
          col='gray',
          alpha=0.25)


#install.packages("nlrwr")
#install.packages("minpack.lm")
#install.packages("leaps")
#install.packages("mgcv")

library("minpack.lm")
require("foreign")
require("data.table")
require("MASS")

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Fitting a logistic function similar to that of Preston (1976)  a/(1+exp(B+exp(lnC*GDP))
# output: alpha, beta & C [model: alpha/(1+exp(beta + exp(ln(C)*dgp))) ], BIC and AIC
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
logfnS<-function(gdp.pc,alpha,beta,C){
  alpha / (1 + exp( beta + exp(log(C) * gdp.pc )))
 }

 # Logistic fitting
log.fnS<-function(data){
  datos<-na.omit(data)
 # estimating starting values for the parameters. Assume alpha=1, then estimate logit(yvar)=beta+gamma^GDP
   yvar <- datos$yvar/(1.05 * max(datos$yvar)) # scale to within unit height
   datos$z <- log(yvar/(1 - yvar))             # logit transformation
	 pars<- nls(z ~ beta+exp(log(C)*gdp.pc),
      data=datos,
      start=list(beta=1,C=1))
   nlsFormula <- "yvar ~ logfnS(gdp.pc,alpha,beta,C)"
   nlsInitial <- c(alpha=max(datos$yvar),coef(pars)[1],coef(pars)[2])
   mod1<-nlsLM(formula = nlsFormula,
     data=datos,
     start=nlsInitial,
     control=nls.lm.control(maxiter=1000))
     #,lower=c(30,-1000,-1000),upper=c(90,1000,1000))
     MSE.p <- mean(residuals(mod1)^2)
   return(data.frame(
     alpha=coef(mod1)[1],
     beta=coef(mod1)[2],
     C=coef(mod1)[3],
     alpha.se=summary(mod1)$coefficients[1,2],
     beta.se=summary(mod1)$coefficients[2,2],
     C.se=summary(mod1)$coefficients[3,2],
     MSE=MSE.p))
}
# foo<-datos[,c("gdp.pc","year","median")];setnames(foo,colnames(foo),c("gdp.pc","year","yvar"))
# foo<-subset(foo,year>1950)
#example: log.fnS(data=foo)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Predicting values from a logistic function
# pars: alpha,gamma,beta [model: alpha/(1+exp((dgp-gamma)*beta)) ]
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
pred.log.fnS<-function(pars,newX){
	alpha<-pars[1]
	beta<-pars[2]
	C<-pars[3]
	out<-unlist(apply(rbind(newX),2,FUN=function(x) alpha/(1 + exp(beta+exp(log(C)*x)))))
  return(out)
}
#example:
# pred.log.fnS(pars=log.fnS(data=dat2),newX=quantile(dat2$gdp.pc,probs=seq(0,1,0.25),na.rm=T))

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Fitting a logistic function
# output: alpha, gamma & beta [model: alpha/(1+exp((dgp-gamma)*beta)) ], BIC and AIC
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
logfn<-function(gdp.pc,alpha,gamma,beta){
  alpha/(1 + exp((gdp.pc-gamma)*beta))
 }
 # Logistic fitting
log.fn<-function(data){
 datos<-na.omit(data)
 nlsFormula <- "yvar ~ logfn(gdp.pc,alpha,gamma,beta)"
 nlsInitial <- c(alpha=max(datos$yvar),gamma=mean(datos$gdp.pc),beta=1/mean(datos$year))
 mod1<-nlsLM(formula = nlsFormula, data=datos,start=nlsInitial,control=nls.lm.control(maxiter=1000))
 MSE.p <- mean(residuals(mod1)^2)
 return(data.frame(alpha=coef(mod1)[1],gamma=coef(mod1)[2],beta=coef(mod1)[3],
 	                 alpha.se=summary(mod1)$coefficients[1,2],gamma.se=summary(mod1)$coefficients[2,2],beta.se=summary(mod1)$coefficients[3,2],
 	                 MSE=MSE.p))
}
# foo<-datos[,c("gdp.pc","year","median")];setnames(foo,colnames(foo),c("gdp.pc","year","yvar"))
# foo<-subset(foo,year>1950)
#example: log.fn(data=foo)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Predicting values from a logistic function
# pars: alpha,gamma,beta [model: alpha/(1+exp((dgp-gamma)*beta)) ]
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
pred.log.fn<-function(pars,newX){
	alpha<-pars[1]
	gamma<-pars[2]
	beta<-pars[3]
	out<-unlist(apply(rbind(newX),2,FUN=function(x) alpha/(1 + exp((x-gamma)*beta))))
  return(out)
}
#example:
# pred.log.fn(pars=log.fn(datos=dat2),newX=quantile(dat2$gdp.pc,probs=seq(0,1,0.25),na.rm=T))

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Fitting a Box-Cox function
# output: lambda (for Box-Cox), alpha & beta [model: Box-Cox(Y) = alpha+beta*log(dgp)], BIC and AIC
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
# Box-Cox with free lambda, lambda -> (0,3), if lambda=0 --> log(yvar)= alpha + beta*log(gdp)
free.bx.fn<-function(datos){
foo<-boxcox(yvar~log(gdp.pc),data=datos,plotit=F,lambda=seq(0,3,0.01))
 lambda1<-foo$x[foo$y==max(foo$y)]
 if(lambda1==0) datos$yvar2<-log(datos$yvar)
 if(lambda1>0) datos$yvar2<-(datos$yvar^lambda1 -1)/lambda1
  mod1<-lm(yvar2~log(gdp.pc),data=datos)
	pred<-pred.free.bx.fn(pars=data.frame(lambda=lambda1,alpha=coef(mod1)[1],beta=coef(mod1)[2]),newX=datos$gdp.pc)
	MSE.p<-sum((datos$yvar-pred)^2,na.rm=T)/dim(datos)[1]
return(data.frame(lambda=lambda1,alpha=coef(mod1)[1],beta=coef(mod1)[2],alpha.se=summary(mod1)$coefficients[1,2],beta.se=summary(mod1)$coefficients[2,2],
       MSE=MSE.p))
}
#example: free.bx.fn(datos=foo)

# Box-Cox with lambda=0 so the model is log(yvar)= alpha + beta*log(gdp)
bx.fn<-function(datos){
  mod1<-lm(log(yvar)~log(gdp.pc),data=datos)
	pred<-pred.bx.fn(pars=data.frame(alpha=coef(mod1)[1],beta=coef(mod1)[2]),newX=datos$gdp.pc)
	MSE.p<-sum((datos$yvar-pred)^2,na.rm=T)/dim(datos)[1]
 return(data.frame(alpha=coef(mod1)[1],beta=coef(mod1)[2],alpha.se=summary(mod1)$coefficients[1,2],beta.se=summary(mod1)$coefficients[2,2],
	    MSE=MSE.p))
}
#example: bx.fn(datos=foo)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Predicting values from a linear model using Box-Cox transformation
# pars: lambda [Box-Cox], alpha,beta [model: alpha+beta*log(dgp) ]
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
# Box-Cox with free lambda, if lambda=0 --> log(yvar)= alpha + beta*log(gdp)
pred.free.bx.fn<-function(pars,newX){#pars=coeff1,newX=q1
	lambda<-pars[1]
	alpha<-pars[2]
	beta<-pars[3]
	bxcx.y<-unlist(tapply(as.vector(newX),1:length(newX),FUN=function(x) alpha+beta*log(x)))
	if(lambda==0) out<-unlist(tapply(as.vector(bxcx.y),1:length(bxcx.y),FUN=function(x) exp(x)))
	if(lambda>0)  out<-unlist(tapply(as.vector(bxcx.y),1:length(bxcx.y),FUN=function(x) (x*lambda + 1)^(1/lambda)))
  return(out)
}

# Box-Cox with lambda=0
pred.bx.fn<-function(pars,newX){
	alpha<-pars[1]
	beta<-pars[2]
	bxcx.y<-unlist(tapply(as.vector(newX),1:length(newX),FUN=function(x) alpha+beta*log(x)))
	out<-unlist(tapply(as.vector(bxcx.y),1:length(bxcx.y),FUN=function(x) exp(x)))
  return(out)
}
#example:
# pred.bx.fn(pars=bx.fn(datos=dat1),newX=quantile(dat1$gdp.pc,probs=seq(0,1,0.25),na.rm=T))

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes predicts life exp between the lowest and highest quartile of income
# with respect to the median. It uses a logistic or free Box-Cox fitting
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
ex.pred<-function(data,fitting,indices){
	tmp<-data
	tmp<-tmp[indices,]
	q1<-quantile(tmp$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
  if(fitting=="logistic") {
 	coeff1<-log.fn(data=tmp)#;print(coeff1)
 	p1<-pred.log.fn(pars=coeff1,newX=q1)
  diff1<-p1[2]-p1[1]
  diff2<-p1[3]-p1[2]
  out<-c(diff1,diff2); names(out)<-c("median.minus.q1","q3.minus.median")
 }
  if(fitting=="free-boxcox") {
 	coeff1<-free.bx.fn(datos=tmp)#;print(coeff1)
 	p1<-pred.free.bx.fn(pars=coeff1,newX=q1)
  diff1<-p1[2]-p1[1]
  diff2<-p1[3]-p1[2]
  out<-c(diff1,diff2); names(out)<-c("median.minus.q1","q3.minus.median")
 }
 return(out)
}
#example: tmp<-datos[,c("year","gdp.pc","median")]
#nms<-colnames(tmp);nms[nms=="median"]<-"yvar";colnames(tmp)<-nms
#ex.pred(data=subset(tmp,year>=1950),fitting="free-boxcox")
#tmp<-boot(data=subset(tmp,year<1950),fitting="free-boxcox",statistic=ex.pred,R=5)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes a dataset and estimates a logistic or Box-Cox, it then selects the best model as min(MSE)
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
best.fit<-function(data){
 bx1<-free.bx.fn(datos=data);bxn<-c("lambda","alpha","beta","MSE") #BX:   lambda, alpha, beta
 log1<-log.fn(data=data)   ;lon<-c("alpha","gamma","beta","MSE")  #log:  alpha, gamma, beta
 log1S<-log.fnS(data=data) ;lsn<-c("alpha","beta","C","MSE")     #logS: alpha, beta, C
 coef<-rep(NA,length(bxn)+length(lon)+length(lsn)); names(coef)<-c(paste("FB",bxn,sep="."),paste("Lg",lon,sep="."),paste("LS",lsn,sep="."))
 min1<-min(bx1$MSE,log1$MSE,log1S$MSE)
  if(bx1$MSE==min1)   { coef[1:4]<-bx1[bxn] }
	if(log1$MSE==min1)  { coef[5:8]<-log1[lon] }
  if(log1S$MSE==min1) { coef[9:12]<-log1S[lsn] }
 return(unlist(coef))
}
#example: best.fit(data=dat1)

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes the two datasets and estimates \Delta(i) using a logistic or Box-Cox fitting
# fitting: logistic, Sam.logistic, free-boxcox, constraint-boxcox
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
Delta.fn<-function(datos1,datos2,yvar,fitting){
	dat1<-datos1
	dat2<-datos2
  nms<-colnames(dat1);nms[nms==yvar]<-"yvar";setnames(dat1,colnames(dat1),nms)
  nms<-colnames(dat2);nms[nms==yvar]<-"yvar";setnames(dat2,colnames(dat2),nms)
  q1<-quantile(dat1$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
  q2<-quantile(dat2$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
 if(fitting=="logistic") {
 	coeff1<-log.fn(data=dat1)#;print(coeff1)
 	coeff2<-log.fn(data=dat2)#;print(coeff2)
 	p1<-pred.log.fn(pars=coeff1,newX=q1)
  p2<-pred.log.fn(pars=coeff2,newX=q2)
	pi1<-pred.log.fn(pars=coeff2,newX=q1)
	pi2<-pred.log.fn(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
	setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
 if(fitting=="Sam.logistic") {
 	coeff1<-log.fnS(data=dat1)#;print(coeff1)
 	coeff2<-log.fnS(data=dat2)#;print(coeff2)
 	p1<-pred.log.fnS(pars=coeff1,newX=q1)
  p2<-pred.log.fnS(pars=coeff2,newX=q2)
	pi1<-pred.log.fnS(pars=coeff2,newX=q1)
	pi2<-pred.log.fnS(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
	setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
 if(fitting=="constraint-boxcox") {
 	coeff1<-bx.fn(datos=dat1)
 	coeff2<-bx.fn(datos=dat2)
 	p1<-pred.bx.fn(pars=coeff1,newX=q1)
  p2<-pred.bx.fn(pars=coeff2,newX=q2)
	pi1<-pred.bx.fn(pars=coeff2,newX=q1)
	pi2<-pred.bx.fn(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
  setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
 if(fitting=="free-boxcox") {
  coeff1<-free.bx.fn(datos=dat1)
 	coeff2<-free.bx.fn(datos=dat2)
 	p1<-pred.free.bx.fn(pars=coeff1,newX=q1)
  p2<-pred.free.bx.fn(pars=coeff2,newX=q2)
	pi1<-pred.free.bx.fn(pars=coeff2,newX=q1)
	pi2<-pred.free.bx.fn(pars=coeff1,newX=q2)
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2))
  setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep=".")) #adding label 1 for parameters estimated <1950
  setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep=".")) #adding label 2 for parameters estimated >=1950
	out<-data.frame(Delta=Delta,coeff1,coeff2)
 }
return(out)
}

#/\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\./\.
#
# Function that takes the best fitting model in terms of lowest MSE in each period, <1950, 1950+ and then
# estimates \Delta(i) using the best model in each period
# fitting: logistic or boxcox
#
#\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.\/.
Delta.best.fn<-function(coef1,coef2,p1,p2,pi1,pi2,q1){
	delta1<- (pi1-p1)/(p2-p1)
	delta2<- (p2-pi2)/(p2-p1)
	Delta<-(1/(2*length(q1)))*(sum(delta1)+sum(delta2)); names(Delta)<-"Delta"
	return(unlist(c(Delta,as.vector(coef1),as.vector(coef2))))
}

#DeltaK.fn<-function(dattos,indices){	#
DeltaK.fn<-function(dattos){	#
	tmp<-na.omit(dattos)
#	tmp<-tmp[indices,]#these indices are used for the bootstrap
  dat1<-tmp[tmp$year<1950,]; dat2<-tmp[tmp$year>=1950,]

	q1<-quantile(dat1$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)
  q2<-quantile(dat2$gdp.pc,probs=seq(0.25,0.75,0.25),na.rm=T)

  log1<-log.fn(data=dat1); log1S<-log.fnS(data=dat1); bx12<-free.bx.fn(datos=dat1); bx1<-bx.fn(datos=dat1)
  log2<-log.fn(data=dat2); log2S<-log.fnS(data=dat2); bx22<-free.bx.fn(datos=dat2); bx2<-bx.fn(datos=dat2)
  if(log1$MSE>100) log1$MSE<-100;if(log1S$MSE>100) log1S$MSE<-100;if(bx1$MSE>100) bx1$MSE<-100;if(bx12$MSE>100) bx12$MSE<-100
  if(log2$MSE>100) log2$MSE<-100;if(log2S$MSE>100) log2S$MSE<-100;if(bx2$MSE>100) bx2$MSE<-100;if(bx22$MSE>100) bx22$MSE<-100

  min1<-min(log1$MSE,log1S$MSE,bx1$MSE,bx12$MSE)#
  min2<-min(log2$MSE,log2S$MSE,bx2$MSE,bx22$MSE)#

	bxn<-c("lambda","alpha","beta","MSE");lon<-c("alpha","gamma","beta","MSE");lsn<-c("alpha","beta","C","MSE"); cont.bx<-c("alpha","beta","MSE")
	coef1<-rep(NA,length(bxn)+length(lon)+length(lsn));coef2<-rep(NA,length(bxn)+length(lon)+length(lsn))
	names(coef1)<-names(coef2)<-c(paste("FB",bxn,sep="."),paste("Lg",lon,sep="."),paste("LS",lsn,sep="."))

  if(log1$MSE==min1)  { coeff1<-log1; coef1[5:8]<-coeff1[lon];  p1<-pred.log.fn(pars=coeff1,newX=q1);    pi2<-pred.log.fn(pars=coeff1,newX=q2) }
  if(log1S$MSE==min1) { coeff1<-log1S;coef1[9:12]<-coeff1[lsn]; p1<-pred.log.fnS(pars=coeff1,newX=q1);   pi2<-pred.log.fnS(pars=coeff1,newX=q2) }
	if(bx12$MSE==min1)  { coeff1<-bx12; coef1[1:4]<-coeff1[bxn]; p1<-pred.free.bx.fn(pars=coeff1,newX=q1);pi2<-pred.free.bx.fn(pars=coeff1,newX=q2) }
  if(bx1$MSE==min1)   { coeff1<-bx1;  coef1[1:4]<-c(0,coeff1[cont.bx]);  p1<-pred.bx.fn(pars=coeff1,newX=q1);     pi2<-pred.bx.fn(pars=coeff1,newX=q2) }

	if(log2$MSE==min2)  { coeff2<-log2; coef2[5:8]<-coeff2[lon];  p2<-pred.log.fn(pars=coeff2,newX=q2);    pi1<-pred.log.fn(pars=coeff2,newX=q1) }
  if(log2S$MSE==min2) { coeff2<-log2S;coef2[9:12]<-coeff2[lsn]; p2<-pred.log.fnS(pars=coeff2,newX=q2);   pi1<-pred.log.fnS(pars=coeff2,newX=q1) }
  if(bx22$MSE==min1)  { coeff2<-bx12; coef2[1:4]<-coeff2[bxn];  p2<-pred.free.bx.fn(pars=coeff2,newX=q2);pi1<-pred.free.bx.fn(pars=coeff2,newX=q1) }
  if(bx2$MSE==min2)   { coeff2<-bx2;  coef2[1:4]<-c(0,coeff2[cont.bx]);   p2<-pred.bx.fn(pars=coeff2,newX=q2);     pi1<-pred.bx.fn(pars=coeff2,newX=q1) }

  #setnames(coeff1,colnames(coeff1),paste(colnames(coeff1),1,sep="."));setnames(coeff2,colnames(coeff2),paste(colnames(coeff2),2,sep="."))
	names(coef1)<-paste(names(coef1),1,sep=".")
  names(coef2)<-paste(names(coef2),2,sep=".")
	return(Delta.best.fn(coef1=coef1,coef2=coef2,p1=p1,p2=p2,pi1=pi1,pi2=pi2,q1=q1))
}
# example:
#foo<-na.omit(data.frame(yvar=N.samples[[1]],gdp.pc=datos$gdp.pc,year=datos$year))
# DeltaK.fn(dattos=foo)


tanimoto_traits <- function(resource_x, resource_y, trait_x, trait_y, trait_weight) {
    # The Tanimoto similarity with traits measures the similarity between vectors of traits as well as similarity between vectors of resources
    # tanimotot(x; y;wt) = wttanimoto(xt; yt) + (1 􀀀 wt)tanimoto(xi; yi);
    # If trait_weight == 1, only traits are used for similarity measurement
    # If trait_weight == 0, only shared resources measures the similarity between species

    # !!! Does it make sense to measure taxonomic proximity linearly like this? I need to look into taxonomic proximity measurements in packages like rphylo !!!

    return(trait_weight * tanimoto(trait_x, trait_y) + (1 - trait_weight) * tanimoto(resource_x, resource_y))
}


allele.imbalance<- function(rna, dna, rna.err, dna.err){

   #Step1
   # estimate sequencing error, dispersion DNA counts and dispersion RNA counts
   # optimization function 1
   mtmp <- function(par, dna.x, dna.n, rna.x, rna.n, ge, rna.err, dna.err){

      # define parameters
      # seq.err  <- par[1]
      disp.dna <- par[1]
      disp.rna <- par[2]

      # likelihood given genotype err (not actually het)
      term1<- 0.5 * dbetabinom(dna.x, dna.n, m= dna.err/3, s= disp.dna) * dbetabinom(rna.x, rna.n, m= rna.err/3, s= disp.rna)
      term2<- 0.5 * dbetabinom(dna.n-dna.x, dna.n, m= dna.err/3, s= disp.dna) * dbetabinom(rna.n-rna.x, rna.n, m= rna.err/3, s= disp.rna)
      err.like <- (ge)*(term1 + term2)

      # likelihood given het sites (actually het)
      het.like = (1-ge)*(dbetabinom(dna.x, dna.n, m= 0.5, s= disp.dna)) *  dbetabinom(rna.x, rna.n, m= 0.5, s= disp.rna)

      # log likelihood
      ll<- -sum(log(err.like + het.like))

      return(ll)
   }

   # optimize
   m0<- optim(par= c(1, 1), mtmp,
              dna.x=dna$ref.matches, dna.n= dna$N,
              rna.x= rna$ref.matches, rna.n = rna$N,
              ge= dna$genotype.error,dna.err= dna.err, rna.err= rna.err,
              method="L-BFGS-B",lower = c(1e-5, 1e-5),
              upper = c(100, 100))

   # get parameter
   disp.dna = m0$par[1]
   disp.rna = m0$par[2]

   # get genes
   genes= as.character(unique(rna$gene))

   # allelic.imbalance  is how far proportion is away from 0.5
   # first site : L( x | allelic.imbalance)=het.like* P( x | 0.5 + allelic.imbalance) + err.like
   # subsequent sites : L( x | allelic.imbalance) = het.like(0.5 * Pr(x | 0.5 - d) + 0.5 * Pr( x | 0.5 + d))) + err.like
   # chi-square test against null hypothesis of allelic.imbalance = 0

   myfunc<- function(i){
      #Step 1 subset by gene
      # rna
      rna= rna[rna$gene %in% genes[i],]
      rna= rna[order(rna$start),]

      # dna
      dna= dna[(dna$rsID %in% rna$rsID) & (dna$gene %in% genes[i]),]
      dna= dna[order(dna$start),]

      # step 2 likelihood estimate
      # likelihood function estimate for ase
      ll<- function(allelic.imbalance,  dna.x, dna.n, rna.x, rna.n, ge, dna.err, rna.err, disp.dna, disp.rna){

         # for 1st site
         # likelihood of allelic imbalance (d1)
         d1= dbetabinom(rna.x[1], rna.n[1], m= 0.5+ allelic.imbalance, s= disp.rna)

         # likelihood given genotype err (not actually het)
         term1<- 0.5 * dbetabinom(dna.x[1], dna.n[1], m= dna.err/3, s= disp.dna) * dbetabinom(rna.x[1], rna.n[1], m= rna.err/3, s= disp.rna)
         term2<- 0.5 * dbetabinom(dna.n[1]-dna.x[1], dna.n[1], m= dna.err/3, s= disp.dna) * dbetabinom(rna.n[1]-rna.x[1], rna.n[1], m= rna.err/3, s= disp.rna)
         err.like <- (ge[1])*(term1 + term2)

         # likelihood given het sites (actually het)
         het.like= (1-ge[1])*(dbetabinom(dna.x[1], dna.n[1], m= 0.5, s= disp.dna))

         # likelihood of 1st sites
         p1= het.like*d1+ err.like

         # for subsequent sites
         len= nrow(rna)

         if(len >1){

            # likelihood of allelic imbalance of n+1, n+2....n+k sites
            d2= 0.5 * dbetabinom(rna.x[2:len], rna.n[2:len], 0.5+ allelic.imbalance, disp.rna)
            d3= 0.5 * dbetabinom(rna.x[2:len], rna.n[2:len], 0.5- allelic.imbalance, disp.rna)

            # likelihood given genotype err (not actually het)
            term1<- 0.5 * dbetabinom(dna.x[2:len], dna.n[2:len], m= dna.err/3, s= disp.dna) *
               dbetabinom(rna.x[2:len], rna.n[2:len], m= rna.err/3, s= disp.rna)

            term2<- 0.5 * dbetabinom(dna.n[2:len]-dna.x[2:len], dna.n[2:len], m= dna.err, s= disp.dna) *
               dbetabinom(rna.n[2:len]-rna.x[2:len], rna.n[2:len], m= rna.err, s= disp.rna)

            err.like <- (ge[2:len])*(term1 + term2)

            # likelihood given het sites (actually het)
            het.like= (1-ge[2:len])*(dbetabinom(dna.x[2:len], dna.n[2:len], m= 0.5, s= disp.dna))

            p2= het.like*(d2 + d3) + err.like

            return(-sum(log(c(p1,p2))))}else{
               return(-sum(log(p1)))
            }}

      # optimize allelic.imbalance
      m1= optimize(ll, c(-0.5, 0.5),
                   rna.x= rna$ref.matches, rna.n= rna$N,
                   dna.x= dna$ref.matches, dna.n= dna$N, ge= dna$genotype.error,
                   dna.err= dna.err, rna.err= rna.err, disp.dna= disp.dna, disp.rna= disp.rna)

      # estimates of allelic.imbalance
      alt.ll <- m1$objective
      estimate <- m1$minimum

      # NULL hypothesis
      null.ll= ll(allelic.imbalance = 0,
                  rna.x= rna$ref.matches, rna.n= rna$N,
                  dna.x= dna$ref.matches, dna.n= dna$N,
                  ge= dna$genotype.error, dna.err= dna.err, rna.err= rna.err,
                  disp.dna= disp.dna, disp.rna= disp.rna)

      # likelihood ratio test
      lrt.stat <- 2 * (null.ll - alt.ll)
      pval <- pchisq(lrt.stat, df=1, lower.tail=F)
      result= data.frame(gene= genes[i], pval =pval, d= estimate)
      return(result)
   }
   rlist= llply(1:length(genes), myfunc)
   res= do.call(rbind,rlist)
   res$fdr= p.adjust(res$pval, "fdr")
   return(res)
}


# CS422 Data Mining
# Vijay K. Gurbani, Ph.D.
# Illinois Institute of Technology
#
# Demonstration of k-means clustering.  Algorithm below is for demonstration
# purpose only; lot's of hard-coded stuff. Don't assume it will work for all
# sorts of data and clustering strategies!!

rm(list=ls())

# Main entry point.  To run, give the coordinates of the cluster centroids.
#
# > kmeans.demo.main(data.frame(x=c(9,10,11), y=c(2,3,4)))
# or
# > kmeans.demo.main(data.frame(x=c(1,6,10), y=c(10,6,8)))
#
# The following cluster centroid will result in only 2 clusters: red and black.
# (Some warnings are thrown as the code does not handle corner cases
# approriately.)
#
# > kmeans.demo.main(data.frame(x=c(1,2,3), y=c(10,10,10)))
#
# Other centroids: data.frame(x=c(1,12,6), y=c(1,10,6))

kmeans.demo.main <- function(centroids) {

  x <- c(4,7,4,6,3,2,5,10,12,11,9,12)
  y <- c(10,10,8,8,4,2,2,5,6,4,3,3)
  df <- data.frame(x,y)

  cluster.centroids <- centroids

  old.cluster.centroids <- cluster.centroids
  for (i in 1:100) {
    kmeans.demo.plot(df, cluster.centroids)
    readline(prompt="Press <enter> to continue")
    cluster.centroids <- kmeans.demo.training(df, cluster.centroids)
    readline(prompt="Press <enter> to continue")
    if (identical(cluster.centroids, old.cluster.centroids)) { break }
    old.cluster.centroids <- cluster.centroids
  }
  cat(paste("Iterations to converge: ", i, "\n"))
}

# Plot the data points and the centroids
kmeans.demo.plot <- function(df, cluster.centroids) {
  plot(df, xlim=c(0,13), ylim=c(0,11), cex=3)
  points(cluster.centroids[1,1], cluster.centroids[1,2], col="green", pch=8, cex=3)
  points(cluster.centroids[2,1], cluster.centroids[2,2], col="red", pch=8, cex=3)
  points(cluster.centroids[3,1], cluster.centroids[3,2], col="black", pch=8, cex=3)
}

# "Train" the dataset by seeing which points belong to which cluster
kmeans.demo.training <- function(df, cluster.centroids)  {
  green.df <- data.frame();
  red.df <- data.frame();
  black.df <- data.frame();
    for (i in 1:dim(df)[1])  {
     paint <- kmeans.demo.which.cluster(df[i,1], df[i,2], cluster.centroids)
     points(df[i,1], df[i,2], col=paint, pch=20, cex=4)
     if (paint == "green") { green.df <- rbind(green.df, df[i,])}
     if (paint == "red")   { red.df   <- rbind(red.df, df[i,])}
     if (paint == "black") { black.df <- rbind(black.df, df[i,])}
  }
  cluster.centroids <- kmeans.demo.update.centroids(green.df,
                                                    red.df,
                                                    black.df,
                                                    cluster.centroids)
  cluster.centroids
}

# Determine which point to paint with which color
kmeans.demo.which.cluster <- function(x, y, cluster.centroids)  {
  df <- data.frame(c(x, cluster.centroids[1,1]), c(y, cluster.centroids[1,2]))
  d1 <- dist(df) # green
  df <- data.frame(c(x, cluster.centroids[2,1]), c(y, cluster.centroids[2,2]))
  d2 <- dist(df) # red
  df <- data.frame(c(x, cluster.centroids[3,1]), c(y, cluster.centroids[3,2]))
  d3 <- dist(df) # black
  indx <- which.min(c(d1,d2,d3))
  if (indx == 1) {
    paint = "green"
  } else if (indx == 2){
    paint = "red"
  } else {
    paint = "black"
  }
  paint
}

# Update the centroids to their new location.
kmeans.demo.update.centroids <- function(green.df,
                                         red.df,
                                         black.df,
                                         cluster.centroids) {

  cluster.centroids <- data.frame(x = c(mean(green.df$x),
                                        mean(red.df$x),
                                        mean(black.df$x)),
                                  y = c(mean(green.df$y),
                                        mean(red.df$y),
                                        mean(black.df$y)))
  cluster.centroids
}


### Generate data base simulations
## Use: Generate data for four functional forms
## Author: Mark Verhagen

library(tidyverse)
library(randomForest)
library(xgboost)

set.seed(1704)

## Set n and X variable
n <- 100
X <- runif(n, -4, 4)

## Generate y outcome based on four functional forms
y0 <- -1 + .9 * X
y1 <- -2 * ifelse(X < -3, 1, 0) + 2.55 * ifelse(X > -2, 1, 0) -
    2 * ifelse(X > 0, 1, 0) + 4 * ifelse(X > 2, 1, 0) - 1 * ifelse(X > 3, 1, 0)
y2 <- 6 + 0.4 * X - 0.36 * X^2 + 0.005 * X^3
y3 <- 2.83 * sin(pi / 2 * X)

## Generate white noise such that overall variance is fixed
var0 <- 5 - var(y0)
var1 <- 5 - var(y1)
var2 <- 5 - var(y2)
var3 <- 5 - var(y3)

epsilon0 <- rnorm(n, 0, sqrt(var0))
epsilon1 <- rnorm(n, 0, sqrt(var1))
epsilon2 <- rnorm(n, 0, sqrt(var2))
epsilon3 <- rnorm(n, 0, sqrt(var3))

## Generate outcome plus noise and store in dataframe
df <- data.frame(
    X = X,
    y_0 = y0 + epsilon0,
    y_1 = y1 + epsilon1,
    y_2 = y2 + epsilon2,
    y_3 = y3 + epsilon3
)

return_oos_r2 <- function(actual, predict) {
    return(1 - sum((actual - predict)^2) / sum((actual - mean(actual))^2))
}

## Generate ids for every row
df_analysis <- df %>%
    mutate(id = 1:n())

train_set <- df_analysis

obs_vars <- c("y_0", "y_1", "y_2", "y_3")

## Obtian outcome value per functional form for trainset
train_ys <- lapply(obs_vars, FUN = function(x) {
    train_set[, x]
})

## Obtain train and test version of feature set
X_train <- train_set %>%
    select(X)

## Estimate true linear effects
true_vars <- list(y0, y1, y2, y3)
lms <- lapply(true_vars, FUN = function(x) {
    lm(y ~ 1 + X, data = df_analysis %>% mutate(y = x))
})

## Estimate random forest models on train set
rfs <- lapply(train_ys, FUN = function(x) {
    randomForest(x = X_train, y = x)
})

## Estimate gradient boosting models
gbs <- lapply(train_ys, FUN = function(x) {
    xgboost(data = as.matrix(X_train), label = x, nrounds = 200)
})

## Plotting
pred_df <- data.frame(X = seq(-4, 4, 8 / 100))

## True association
pred_df$lm_0 <- predict(lms[[1]], pred_df)
pred_df$lm_1 <- predict(lms[[2]], pred_df)
pred_df$lm_2 <- predict(lms[[3]], pred_df)
pred_df$lm_3 <- predict(lms[[4]], pred_df)

## Implied association
pred_df$rf_0 <- predict(gbs[[1]], as.matrix(pred_df$X))
pred_df$rf_1 <- predict(rfs[[2]], as.matrix(pred_df$X))
pred_df$rf_2 <- predict(rfs[[3]], as.matrix(pred_df$X))
pred_df$rf_3 <- predict(rfs[[4]], as.matrix(pred_df$X))

pred_df$gb_0 <- predict(gbs[[1]], as.matrix(pred_df$X))
pred_df$gb_1 <- predict(gbs[[2]], as.matrix(pred_df$X))
pred_df$gb_2 <- predict(gbs[[3]], as.matrix(pred_df$X))
pred_df$gb_3 <- predict(gbs[[4]], as.matrix(pred_df$X))

melt_pred_df <- reshape2::melt(pred_df, id.vars = c("X")) %>%
    mutate(model = ifelse(grepl("rf", variable), "RF",
        ifelse(grepl("gb", variable), "GB",
            ifelse(grepl("lm", variable), "LM", NA)
        )
    ), data = gsub("rf_|gb_|lm_", "", variable))

melt_observed <- df %>%
    reshape2::melt(id.vars = ("X")) %>%
    mutate(model = "Simulated", data = gsub("y_", "", variable))

df_true <- data.frame(
    X = X, y_0 = y0, y_1 = y1,
    y_2 = y2, y_3 = y3
)

melt_true <- df_true %>%
    reshape2::melt(id.vars = ("X")) %>%
    mutate(model = "True", data = gsub("y_", "", variable))

total_melt <- rbind(melt_pred_df, melt_observed, melt_true) %>%
    mutate(data = ifelse(data == "0", "Linear",
        ifelse(data == "1", "Step",
            ifelse(data == "2", "Quadratic",
                ifelse(data == "3", "Sine", NA)
            )
        )
    ))

ggplot(total_melt, aes(y = value, x = X)) +
    geom_point(data = total_melt %>% filter(!(model %in% c("True", "LM", "GB", "RF"))), alpha = 0.3, aes(color = model)) +
    geom_line(data = total_melt %>% filter(model == "True"), aes(linetype = model)) +
    geom_line(data = total_melt %>% filter(model == "LM"), aes(linetype = model)) +
    facet_wrap(~data) +
    xlab("X") +
    ylab("Y") +
    scale_color_manual(
        name = "", values = c(ggsci::pal_aaas("default")(3)[3:1], ggsci::pal_aaas("default")(10)[10]),
        labels = c("Simulated data")
    ) +
    scale_linetype_manual(name = "", values = c("dashed", "solid"), labels = c("Linear Model", "True effect")) +
    cowplot::theme_cowplot() +
    theme(
        # panel.grid.minor.y = element_line(size = 0.25, linetype = "dotted"),
        # panel.grid.major.y = element_line(size = 0.25, linetype = "dotted"),
        strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
        strip.background = element_rect(fill = NA, color = "black", size = 1.5),
        legend.position = "top",
        panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
        text = element_text(size = 20)
    ) +
    guides(color = guide_legend(override.aes = list(fill = NA)))

ggsave("../tex/figs/fig1_base.pdf", last_plot(), width = 10, height = 8)

ggplot(total_melt, aes(y = value, x = X)) +
    geom_point(data = total_melt %>% filter(!(model %in% c("True", "LM"))), alpha = 0.3, aes(color = model)) +
    geom_line(data = total_melt %>% filter(model == "True"), aes(linetype = model)) +
    facet_wrap(~data) +
    xlab("X") +
    ylab("Y") +
    scale_color_manual(
        name = "", values = c(ggsci::pal_aaas("default")(3)[1:3], ggsci::pal_aaas("default")(10)[10]),
        labels = c("Gradient Boosting", "Random Forest", "Simulated data")
    ) +
    scale_linetype_manual(name = "", values = c("solid"), labels = c("True effect")) +
    cowplot::theme_cowplot() +
    theme(
        # panel.grid.minor.y = element_line(size = 0.25, linetype = "dotted"),
        # panel.grid.major.y = element_line(size = 0.25, linetype = "dotted"),
        strip.text.y = element_text(face = "bold", hjust = 0.5, vjust = 0.5),
        strip.background = element_rect(fill = NA, color = "black", size = 1.5),
        legend.position = "top",
        panel.border = element_rect(color = "lightgrey", fill = NA, size = 0.5),
        text = element_text(size = 20)
    ) +
    guides(color = guide_legend(override.aes = list(fill = NA)))

ggsave("../tex/figs/fig1_base2.pdf", last_plot(), width = 10, height = 8)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(xts)
library(Quandl)
library(quantmod)

## Get risk-free rates
rf.tickers <- c("FRED/DGS3MO", "BOC/V39065", "BUNDESBANK/BBK01_WT3210",
                "SNB/RENDOBLID", "RBA/F17_0", "MOFJ/INTEREST_RATE_JAPAN")
rf.columns <- c(1,1,1,1,2,1)
rf.ids <- c("USD3M", "CAD3M","EUR6M","CHF1Y","AUD3M","JPY1Y","HKD3M")
## loop through tickers and columns
rf <- Quandl(rf.tickers[1], type="xts")[,rf.columns[1]]/100
for (i in 2:length(rf.tickers)) {
    rf.tmp <- Quandl(rf.tickers[i], type="xts")[,rf.columns[i]]/100
    rf <- cbind(rf, rf.tmp)
}

## Getting HKMA data is not straightforward, so...
## ...these are from the Hong Kong Monetary Authority
hkma.exfund.3M.rates <-
    c(0.09,0.10,0.10,0.11,0.26,0.62,0.27,0.18,0.24,0.25,0.30,0.28, # 2010
      0.16,0.19,0.20,0.11,0.13,0.06,0.07,0.10,0.11,0.10,0.17,0.22, # 2011
      0.18,0.11,0.10,0.12,0.10,0.08,0.15,0.17,0.23,0.09,0.07,0.05, # 2012
      0.11,0.08,0.06,0.08,0.09,0.15,0.16,0.15,0.17,0.13,0.12,0.11, # 2013
      0.14,0.14,0.14,0.10,0.07,0.09,0.07,0.04,0.09,0.03,0.03,0.04, # 2014
      0.03,0.01,0.02,0.01,0.01,0.00,0.01,-0.01,-0.01,0.00,-0.01,0.04, # 2015
      0.24,0.07,0.07,0.06,0.20,0.17,0.28,0.30,0.31,0.30,0.28,0.67, # 2016
      0.54,0.41,0.27,0.40,0.29,0.31,0.35,0.28,0.45,0.85,0.75,1.02, # 2017
      0.66,0.56) # 2018
rf.subset <- rf["201001/201802"]
hkma.3M <- xts(hkma.exfund.3M.rates,
               order.by = index(rf.subset[xts:::startof(rf.subset, "months")]))
rf <- cbind(rf, hkma.3M)
rf <- na.locf(rf)
colnames(rf) <- rf.ids

# Get indices and stock prices
adj.close <- 6  # 6th field is adjusted close
equity.tickers <- c("^GSPC","^GSPTSE","^STOXX50E","^SSMI","^AORD","^HSI","^N225",
                    "CTC-A.TO","F","HSBC","PFE","SVNDY","TM","EDF.PA","NOVN.VX",
                    "SIE.DE","VOW.DE","BRG.AX","MQG.AX","J36.SI","0019.HK")
equity.ids <- c("SPX","TSXCOMP","ESX50","SMI","AORD","HS","N225",
                "CATIRE","FORD","HSBC","PFIZER","SEVENANDI","TOY","EDF","NOVARTIS",
                "SIEMENS","VW","BREVILLE","MACQUARIE","JARDINES","SWIRE")
prices <- getSymbols(equity.tickers[1], source="yahoo", auto.assign=FALSE,
                         return.class="xts")[,adj.close]
for (i in 2:length(equity.tickers)) {
  prices.tmp <- getSymbols(equity.tickers[i], source="yahoo",
                         auto.assign=FALSE, return.class="xts")[,adj.close]
  prices <- cbind(prices, prices.tmp)
}
## We often get errors here since international stocks are not always
## traded on our home days, so there are some NAs.  No worries; fill
## forward and returns will be zero on non-trading days.  (Might be a
## minor bias on volatility estimates; we will probably survive.
prices <- na.locf(prices)
colnames(prices) <- equity.ids
returns <- diff(log(prices))

## Now we join all of the datasets together and trim to recent
alldata <- cbind(rf, returns)["2010/"]

## create excess returns
equity.names.xs <- paste(equity.names, ".xs", sep="")
## now in a for loop subtract off a daily risk-free rate, FOR EXAMPLE:
alldata$SPX.xs <- alldata$SPX - alldata$T3M/250
## Only oddity: use HKD rf for Jardines.

# If your ticker were DAL and you wanted to model returns
# (not excess returns) using ESTOX and SMI, you would do like so:
simple.wrong.model <- lm(DAL ~ ESTOX + SMI, data=alldata)
summary(simple.wrong.model)
# NOTE that this is not the model you are supposed to do


# If you use this code or parts of it, please cite the following paper
# Bruhin A., E. Fehr, D. Schunk (2018): "The Many Faces of Human Sociality: Uncovering the Distribution and Stability of Social Preferences",
# Journal of the European Economic Association, forthcoming.
# ===========================================================================================================================================

library(compiler)

# Log Likelihood
fdummy.ll <- function(v,y,self_x, other_x, self_y, other_y,indicators_x, indicators_y) {
	beta  <- v[1:(length(v)-1)]
	gamma <- exp(v[length(v)])

	lli    <- indicators_x%*%beta
	rli    <- indicators_y%*%beta
	uleft  <- gamma*((1-lli)*self_x+lli*other_x)
	uright <- gamma*((1-rli)*self_y+rli*other_y)

	probs  <- (exp(uleft)/(exp(uleft)+exp(uright)))^y * (exp(uright)/(exp(uleft)+exp(uright)))^(1-y)

	sum(log(probs))
}
f.ll <- cmpfun(fdummy.ll)

# Log Likelihood of a model without indicators
fdummy.ll.nopar <- function(v,y,self_x,self_y) {
	gamma <- exp(v)

	uleft  <- gamma*self_x
	uright <- gamma*self_y

	probs  <- (exp(uleft)/(exp(uleft)+exp(uright)))^y * (exp(uright)/(exp(uleft)+exp(uright)))^(1-y)

	sum(log(probs))
}
f.ll.nopar <- cmpfun(fdummy.ll.nopar)

# Gradient of Log Likelihood
fdummy.ll.gr <- function(v, y, self_x, other_x, self_y, other_y, indicators_x, indicators_y) {
	beta  <- v[1:(length(v)-1)]
	gamma <- exp(v[length(v)])

	lli <- indicators_x%*%beta
	rli <- indicators_y%*%beta
	utl <- gamma*((1-lli)*self_x+lli*other_x)
	utr <- gamma*((1-rli)*self_y+rli*other_y)
	probs  <- (exp(utl)/(exp(utl)+exp(utr)))^y * (exp(utr)/(exp(utl)+exp(utr)))^(1-y)
	probsm <- matrix(probs, nrow(indicators_x), ncol(indicators_x))

	u   <- matrix(exp(utl)            , nrow(indicators_x), ncol(indicators_x))
	w   <- matrix(exp(utl) + exp(utr) , nrow(indicators_x), ncol(indicators_x))
	up  <- gamma * indicators_x * matrix(other_x-self_x, nrow(indicators_x), ncol(indicators_x)) * u
	wp  <- up + gamma * indicators_y * matrix((other_y-self_y)*exp(utr), nrow(indicators_x), ncol(indicators_x))

	prebgrad <- (-1)^(1-y)*((up*w - u*wp)/w^2)/probsm
	bgrad    <- colSums(prebgrad)

	up2   <- utl * u[,1]
	wp2   <- up2 + utr * exp(utr)

	ggrad <- sum((-1)^(1-y) * (((up2*w[,1] - u[,1]*wp2)/w[,1]^2)/probs))

	c(bgrad, ggrad)
}
f.ll.gr <- cmpfun(fdummy.ll.gr)

# Gradient of Log Likelihood of a model without indicators
fdummy.ll.gr.nopar <- function(v, y, self_x,self_y) {
	gamma <- exp(v)

	utl <- gamma*self_x
	utr <- gamma*self_y
	probs  <- (exp(utl)/(exp(utl)+exp(utr)))^y * (exp(utr)/(exp(utl)+exp(utr)))^(1-y)

	u   <- exp(utl)
	w   <- exp(utl) + exp(utr)
	up2   <- utl * u
	wp2   <- up2 + utr * exp(utr)

	ggrad <- sum((-1)^(1-y) * (((up2*w - u*wp2)/w^2)/probs))
	ggrad
}
f.ll.gr.nopar <- cmpfun(fdummy.ll.gr.nopar)

# Function to compute cluster robust standard errors
f.clusterse <- function(estobj, dat, label_choice_x, label_self_x, label_other_x, label_self_y, label_other_y, label_indicators_x, label_indicators_y, clustervar) {
	y         <- as.vector(dat[,label_choice_x])
	self_x    <- as.matrix(dat[,label_self_x])
	other_x   <- as.matrix(dat[,label_other_x])
	self_y    <- as.matrix(dat[,label_self_y])
	other_y   <- as.matrix(dat[,label_other_y])
	indicators_x <- as.matrix(dat[,label_indicators_x])
	indicators_y <- as.matrix(dat[,label_indicators_y])
	clusters  <- as.vector(dat[,clustervar])

	ll1 <- f.ll(estobj$retobj$par, y, self_x, other_x, self_y, other_y, indicators_x, indicators_y)
	if (abs(ll1 - estobj$retobj$value)>0.001) stop(paste("Saved loglik", ll1, "and computed loglik", estobj$retobj$value, "differ"))

	sandwich <- f.sandwich(estobj$retobj$par, y, self_x, other_x, self_y, other_y,indicators_x, indicators_y, clusters) # sandwich part; see function below

	k <- length(estobj$retobj$par)

	vcm <- solve(-estobj$retobj$hessian)
	vcm <- sandwich$qc * (vcm %*% sandwich$sandwich %*% vcm)

	se <- sqrt(diag(vcm))
	se[k] <- sqrt( exp(estobj$retobj$par[k])^2 * se[k]^2 )

	pe <- estobj$retobj$par
	pe[k] <- exp(pe[k])
	out <- matrix(c(pe, se, pe/se, 2*(1-pnorm(abs(pe)/se))), k, 4, dimnames=list(c(paste(label_indicators_x,"label_idicators_y"),"choicesens"),c("point_estimates","se_cluster","z-stat_cluster","p-val_cluster")));

	cat("\nNumber of clusters", sandwich$j,"\n")
	print(round(out,3))

	list(out=out, vcm=vcm[1:(k-1), 1:(k-1)])
}

# Sandwitch part for calculating cluster robust standard errors
f.sandwich <- function(v, y, self_x, other_x, self_y, other_y,indicators_x, indicators_y, clusters) {

	#compute individual gradient contributions
	beta  <- v[1:(length(v)-1)]
	gamma <- exp(v[length(v)])

	lli <- indicators_x%*%beta;
	rli <- indicators_y%*%beta;
	utl <- gamma*((1-lli)*self_x+lli*other_x)
	utr <- gamma*((1-rli)*self_y+rli*other_y)
	probs  <- (exp(utl)/(exp(utl)+exp(utr)))^y * (exp(utr)/(exp(utl)+exp(utr)))^(1-y);
	probsm <- matrix(probs, nrow(indicators_x), ncol(indicators_x))

	u   <- matrix(exp(utl)            , nrow(indicators_x), ncol(indicators_x))
	w   <- matrix(exp(utl) + exp(utr) , nrow(indicators_x), ncol(indicators_x))
	up  <- gamma * indicators_x * matrix(other_x-self_x, nrow(indicators_x), ncol(indicators_x)) * u
	wp  <- up + gamma * indicators_y * matrix((other_y-self_y)*exp(utr), nrow(indicators_x), ncol(indicators_x))

	bgradi <- (-1)^(1-y)*((up*w - u*wp)/w^2)/probsm

	up2   <- utl * u[,1]
	wp2   <- up2 + utr * exp(utr)

	ggradi <- (-1)^(1-y) * (((up2*w[,1] - u[,1]*wp2)/w[,1]^2)/probs)

	gradi <- cbind(bgradi, ggradi)

	#Sandwich part of the sandwich VC estimator
	cl <- unique(clusters)
	j  <- length(cl)
	k  <- ncol(gradi)

	sandwich <- matrix(0, k, k)
	for (i in 1:j) {
		sel <- clusters == cl[i]
		gradsel <- colSums(gradi[sel, ])
		sandwich <- sandwich + (gradsel %o% gradsel)
	}

	qc <- (length(y)-1) / (length(y)-k) * j/(j-1) #df adjustment

	list(qc=qc, sandwich=sandwich, j=j)
}

# Estimation Function (to be called directly for aggregate estimations and by f.indivest for individual estimations)
fdummy.estim <- function(dat, label_choice_x, label_indicators_x, label_indicators_y, label_self_x, label_other_x, label_self_y, label_other_y, silent=F, comp.se=T, v0=NULL) {
	y         <- as.vector(dat[,label_choice_x])
	self_x    <- as.matrix(dat[,label_self_x])
	other_x   <- as.matrix(dat[,label_other_x])
	self_y    <- as.matrix(dat[,label_self_y])
	other_y   <- as.matrix(dat[,label_other_y])
	indicators_x <- as.matrix(dat[,label_indicators_x])
	indicators_y <- as.matrix(dat[,label_indicators_y])

	k <- length(label_indicators_x)+1

	if (is.null(v0)) {v0  <- c(rep(0,k-1), log(runif(1,.05,.8)/mean(c(mean(self_x),mean(other_x),mean(self_y),mean(other_y)))))} # Random start values if start values are not provided
	ret <- optim(v0, f.ll, f.ll.gr, method="BFGS", control=list(maxit=100000,trace=as.numeric(silent==F),REPORT=50, fnscale=-1), hessian=comp.se, y=y, self_x=self_x, other_x=other_x, self_y=self_y, other_y=other_y, indicators_x=indicators_x, indicators_y=indicators_y)

	rawpe <- ret$par
	pe    <- rawpe
	pe[k] <- exp(rawpe[k]) # Choice sensitivity > 0

	se <- rep(NA, k)
	overall.pval <- NA
	if(comp.se) {
		rawse <- sqrt(diag( solve(-ret$hessian) ))
		se    <- rawse
		se[k] <- sqrt( exp(rawpe[k])^2 * rawse[k]^2 ) #Delta method

		ret2 <- optim(log(0.5/1000), f.ll.nopar, f.ll.gr.nopar, method="BFGS", control=list(maxit=100000,trace=F,REPORT=50, fnscale=-1), hessian=F, y=y, self_x=self_x, self_y=self_y)
		overall.pval <- 1-pchisq(2*(ret$value-ret2$value),4)
	}

	out <- matrix(c(pe, se, pe/se, 2*(1-pnorm(abs(pe)/se))), k, 4, dimnames=list(c(paste(label_indicators_x,label_indicators_y),"choicesens"),c("point_estimates","se_noCluster","z-stat_noCluster","p-val_noCluster")))

	if (silent==F) {
		print(paste("LogLik:",ret$value), quote=F)
		print(round(out,4))
	}

	list(out=out, retobj=ret, overall.pval=overall.pval)
}
f.estim <- cmpfun(fdummy.estim)

# Function for running individual estimations
f.indivest <- function(dat){

	# Set up grid of start values (individual estimations are more fragile than pooled ones => test a lot of start values for each subject)
	v01   <- c(0,0,0,0)
	v02   <- c(.1,-.1,0,0)
	v03   <- c(.1,-.1,.01,-.01)
	v04   <- c(.1,-.1,-.01,.01)
	v05   <- c(-.1,.1,0,0)
	v06   <- c(-.1,.1,.01,-.01)
	v07   <- c(-.1,.1,-.01,.01)
	v00   <- matrix(c(v01,v02,v03,v04,v05,v06,v07),7,4,byrow=T)
	errv0 <- log(seq(0.0001, .001, length.out=20))
	irps  <- 7*20 #140 estimation per subject with varying start values

	ids <- sort(unique(dat$sid)) #Individual IDs
	j   <- length(ids)           #Number of individuals

	parset <- c("beta", "alpha", "gamma", "delta", "choicesens")
	parmatrix    <- matrix(NA, j,    length(parset)+2, dimnames=list(ids, c(parset, "loglik", "success"))) # Matrix for saving the final estimation results for every subject
	parsubmatrix <- matrix(NA, irps, length(parset)+2, dimnames=list(NULL,c(parset, "loglik", "success"))) # Matrix for saving the estimation results for every start value combination in the grid of start values

	# Run the individual Estimations including all irps subreplications
	for (i in 1:j) {
		idat <- dat[dat$sid == ids[i], ]
		cat("\nEstimating individual:", i,"/",j)

		# Cycle through all 140 start value combinations
		for (s in 1:irps) {
			verr <- errv0[((s-1) %% 20) + 1] #start values for the choice sensitivity
			v    <- v00[((s-1) %/% 20) +1,] #start values of the parameters

			#estimtion
			pe <- f.estim(idat, "choice_x", c("r_x","s_x","q","v"), c("r_y","s_y","q","v"), "self_x", "other_x", "self_y", "other_y", silent=T, comp.se=F, v0=c(v,verr))
			ipar <- pe$out[,1]
			ill  <- pe$retobj$value
			isuc <- as.numeric(pe$retobj$convergence == 0)
			parsubmatrix[s,] <- c(ipar, ill, isuc)
		}

		# Extract start values that led to the best estimation (i.e. the estimation with the highest log likelihood)
		v0 <- as.matrix(parsubmatrix[order(parsubmatrix[,"loglik"], decreasing=T),])[1,1:length(parset)]
		v0[length(v0)] <- log(v0[length(v0)]) # Choice sensitivty (last parameter in v0) is > 0

		# Redo best estimation
		pe <- f.estim(idat, "choice_x", c("r_x","s_x","q","v"), c("r_y","s_y","q","v"), "self_x", "other_x", "self_y", "other_y", silent=T, comp.se=F, v0=v0)

		parmatrix[i, 1:length(parset)] <- pe$out[,1] # save point estimates
		parmatrix[i, length(parset)+1] <- pe$retobj$value # save log likelihood
		parmatrix[i, length(parset)+2] <- as.numeric(pe$retobj$convergence == 0) # save success indicator
	}

	parmatrix
}

# Funtion that identifies subjects that behaved erraticly and exhibit individual parameter estimates outside the identifiable range
f.droperratic <- function(par1, par2) {

	range <- c(-3,1) # Identifiable parameter range

	drop <- matrix(NA, nrow(par1), 4, dimnames=list(rownames(par1),c()))
	for (i in 1:4) {
		drop[,i] <- (par1[,i] < range[1]) | (par1[,i] > range[2]) | (par2[,i] < range[1]) | (par2[,i] > range[2])
	}

	rowSums(drop)
}


# Pull PWT into dataframe
data("pwt9.1")

p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$lnpop <- round(log(p$pop),digits=2) # create log population
p$ky <- round(p$rnna/p$rgdpna,digits=2) # create K/Y ratio
p$phil <- round(p$labsh*p$rgdpna/(p$labsh*p$rgdpna+.05*p$rnna),digits=2) # create kludge cost share of labor
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.lngdppc = dplyr::lag(lngdppc, n = 10, default = NA))
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.lnpop = dplyr::lag(lnpop, n = 10, default = NA))
p$g10.lngdppc <- (p$lngdppc - p$lag10.lngdppc)/10
p$g10.lnpop <- (p$lnpop - p$lag10.lnpop)/10
p$lagyear <- p$year-10
p$csh_trade <- p$csh_x - p$csh_m
p$csh_mabs <- -1*p$csh_m

# subset PWT into stable and catchup groups
stable <- p[which(p$isocode %in% c("USA", "CAN", "MEX", "GBR", "AUS")),]
catchup <- p[which(p$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]
test <- p[which(p$isocode %in% c("ETH", "ZAF","BWA")),]
usa <- p[which(p$isocode %in% c("USA")),]
all <- p[which(p$isocode %in% c("USA", "MEX", "DEU","JPN","KOR","CHN")),]

fig <- plot_ly(usa, x = ~lagyear, y = ~g10.lnpop, color = ~country, type = 'scatter', mode='lines+markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Population growth rate', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = '10-year population growth rate', range=c(0,.02)))
api_create(fig, filename = "pwt-usa-pop-growth")

fig <- plot_ly(all, x = ~csh_g, y = ~g10.lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Government and growth', x=0),
              xaxis = list(title = 'Gov. spending share of GDP'),
              yaxis = list (title = '10-year growth rate'))
api_create(fig, filename = "pwt-all-cshg-growth")

fig <- plot_ly(all, x = ~csh_g, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Government and level of GDP per capita', x=0),
              xaxis = list(title = 'Gov. spending share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-test-chsg-level")

us <- p[which(p$isocode %in% c("USA")),]
fig <- plot_ly(us, x = ~lagyear, y = ~g10.lngdppc, type = 'scatter', mode='lines+markers', colors = "Set1")
fig <- layout(fig, title = list(text = '10-year growth rate', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = '10-year growth rate', range=c(0,.04)))
api_create(fig, filename = "pwt-usa-growth-rate")

fig <- plot_ly(all, x = ~csh_trade, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Trade and level of GDP per capita', x=0),
              xaxis = list(title = '(Exports+Imports) as share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-all-trade-level")

fig <- plot_ly(all, x = ~csh_x, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Exports and level of GDP per capita', x=0),
              xaxis = list(title = 'Exports as share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-all-export-level")

fig <- plot_ly(all, x = ~csh_mabs, y = ~lngdppc, color = ~country, type = 'scatter', mode='markers', colors = "Set1")
fig <- layout(fig, title = list(text = 'Imports and level of GDP per capita', x=0),
              xaxis = list(title = 'Imports as share of GDP'),
              yaxis = list (title = 'Log GDP per capita'))
api_create(fig, filename = "pwt-all-imports-level")

############################
# Figures for log GDP per capita
############################
fig <- plot_ly(test, x = ~year, y = ~lngdppc, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-test-lngdppc")

fig <- plot_ly(stable, x = ~year, y = ~lngdppc, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita for stable growth countries', x=0),
               xaxis = list(title = 'Year'),
               yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
               hovermode="x unified")
api_create(fig, filename = "pwt-stable-lngdppc")

fig <- plot_ly(catchup, x = ~year, y = ~lngdppc, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita for catch-up growth countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-lngdppc")

############################
# Figures of labor share
############################

fig <- plot_ly(stable, x = ~year, y = ~labsh, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/GDP for stable growth countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Compensation share of GDP', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-labsh")

fig <- plot_ly(catchup, x = ~year, y = ~labsh, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/GDP for catch-up growth countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Compensation share of GDP', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-labsh")

############################
# Figures of labor cost share
############################

fig <- plot_ly(stable, x = ~year, y = ~phil, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/Total Costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'W/(W+RK)', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-phil")

fig <- plot_ly(catchup, x = ~year, y = ~phil, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Compensation/Total Costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'W/(W+RK)', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-phil")

############################
# Figures of convergence
############################
# get 10-year lagged value of log gdppc, by country
p <-
  p %>%
  group_by(isocode) %>%
  mutate(lag10.lngdppc = dplyr::lag(lngdppc, n = 10, default = NA))
p$g10.lngdppc <- (p$lngdppc - p$lag10.lngdppc)/10

# just need the catchup group
catchup <- p[ which(p$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]

pal <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00','#ffff33')
pal <- setNames(pal, c("CHN", "DEU", "JPN","KOR","NGA","USA"))
fig <- plot_ly(catchup, x = ~lag10.lngdppc, y = ~g10.lngdppc, text=~year,
               color = ~isocode,
               colors = pal,
               type = 'scatter',
               mode = 'markers',
               hovertemplate = paste("%{text}
",
                                     "%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
"),
               marker = list(size = 7)
               )
fig <- layout(fig, title=list(text = 'Convergence and non-convergence', x= 0),
              xaxis = list(title = 'Initial log GDP per capita',range=c(6,11)),
              yaxis = list (title = '10-year growth rate')
              )
api_create(fig, filename = "pwt-catchup-convergence")

############################
# Figures of K/Y ratio
############################
p1960 <- p[which(p$year >1959),] # drop 50-59 b/c of PWT initial ky guess
stable <- p1960[ which(p1960$isocode %in% c("USA", "CAN", "MEX", "GBR", "AUS")),]
catchup <- p1960[ which(p1960$isocode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]

fig <- plot_ly(stable, x = ~year, y = ~ky, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output ratio for stable countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio',range=c(0,7)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-ky")

fig <- plot_ly(catchup, x = ~year, y = ~ky, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output ratio for catch-up countries', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio',range=c(0,7)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-ky")


#  James Rekow

##  Contains several simple functions used in the DOC analysis.

overlapSet = function(x, y){
  xPresent = x > 0
  yPresent = y > 0
  return(xPresent & yPresent)
} #  end overlapSet

normalize = function(x){
  return(x / sum(x))
} #  end normalize

#  This function does not assume the data is normalized
overlap = function(x, y){

  x = normalize(x)
  y = normalize(y)

  bothPresent = overlapSet(x, y)
  return(0.5 * sum(x[bothPresent] + y[bothPresent]))

} #  end overlap

#  This function does not assume the data is normalized
DrJSD = function(x, y){

  bothPresent = overlapSet(x, y)
  x = normalize(x[bothPresent])
  y = normalize(y[bothPresent])
  m = 0.5 * (x + y)

  if(sum(m) == 0){
    return(0)
  }

  return(sqrt(0.5 * (sum(x * log(x / m) + y * log(y / m)))))

} #  end DrJSD


metrop_hastings<-function(x_0, iter=1, log_post_density,
                          proposal_dist = function(x, prop_sigma){
                            MASS::mvrnorm(1, mu = x, Sigma = prop_sigma )
                          },
                          lower=-Inf, upper=Inf, prop_sigma,
                          ... ){
  for(i in 1:iter){
    # draw from proposal distribution
    x_star <- proposal_dist(x_0, prop_sigma)

    # calculate ratio of conditional posterior densities
    r_num <- do.call(log_post_density, c(list(x_star), list(...)) )
    r_denom <- do.call(log_post_density, c(list(x_0), list(...)) )
    r <- exp(r_num - r_denom)
    rmin<-min(r,1)
    if(is.na(rmin)) browser()
    # accept / reject proposal
    if(rbinom(1,1,rmin)==1){
      x_0<-x_star
    }
  }

  res<-list(x_0 = x_0, accept_prob = rmin )
  return(res)
}


BBOD <- function(B,By,y,max_price, OD){
  if(OD == "o"){
    func = 0.2*B+By*y
  } else{
    func = max_price-0.3072734*B+0.5*By*y
    func[func>max_price] = max_price
  }
  return(func)
}

BBPlot <- function(input,output,values){
  bonds = seq(0,200,length.out = 100)
  to_plot = data.frame(bonds = bonds)

  eq_Pb = BBOD(values$eq$B,input$by,values$eq$y,input$max_price, "o")
  fig = plot_ly(to_plot, x = ~bonds)
  fig = fig %>% add_trace(y = BBOD(bonds,input$by,values$eq$y,input$max_price,"o"), type = "scatter", mode = "lines", name = "$$B^s(N)$$", line = list(color = "blue"),
                          hovertemplate = paste("Bs=%{x:.0f}","
Pb=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_trace(y = BBOD(bonds,input$by,values$eq$y,input$max_price,"d"), type = "scatter", mode = "lines", name = "$$B^d(N)$$", line = list(color = "red"),
                          hovertemplate = paste("Bd=%{x:.0f}","
Pb=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(0,eq_Pb,max(bonds),eq_Pb, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("B*=%{x:.0f}","
Pb*=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$B,0,values$eq$B,eq_Pb, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("B*=%{x:.0f}","
Pb*=%{y:.0f}","<extra></extra>"))

  eq_label = list(
    x = values$eq$B,
    y = eq_Pb,
    text = paste0("B*=",round(values$eq$B),", Pb*=",round(eq_Pb))
  )
  fig = fig %>% layout(annotations = eq_label)

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  empLevel <- list(
    title = "Nombre de titres en circulation, B",
    titlefont = f
  )
  salReels <- list(
    title = "Prix des titres, Pb (inverse de r)",
    titlefont = f,
    range = c(70,110)
  )
  fig = fig %>% layout(xaxis = empLevel, yaxis = salReels)
}

RPBPlot <- function(input,output,values){
  r = seq(0,20,length.out = 1000)
  to_plot = data.frame(interest = r)

  eq_Pb = BBOD(values$eq$B,input$by,values$eq$y,input$max_price, "o")
  eq_R = values$eq$r
  fig = plot_ly(to_plot, x = ~interest)
  fig = fig %>% add_trace(y = 100/(r/100+1), type = "scatter", mode = "lines", name = "$$\\frac{100}{r+1}$$", line = list(color = "gold"),
                          hovertemplate = paste("r=%{x:.1f}","
Pb=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(0,eq_Pb,eq_R,eq_Pb, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("B*=%{x:.0f}","
Pb*=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(eq_R,0,eq_R,eq_Pb, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("B*=%{x:.0f}","
Pb*=%{y:.0f}","<extra></extra>"))

  eq_label = list(
    x = eq_R,
    y = eq_Pb,
    text = paste0("r*=",round(eq_R,1),", Pb*=",round(eq_Pb))
  )
  fig = fig %>% layout(annotations = eq_label)

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  empLevel <- list(
    title = "Taux d'intérêt, r",
    titlefont = f
  )
  salReels <- list(
    title = "Prix des titres, Pb",
    titlefont = f
  )
  fig = fig %>% layout(xaxis = empLevel, yaxis = salReels)
}


png("pdqr.png",width = 1250,height = 500)
par(xpd = TRUE,mfrow = c(1,2), mar = c(4,2,0,3))
## Normal dist.
set.seed(1234)
x <- sort(rnorm(1000))
plot(x,dnorm(x),type = "l",axes = FALSE,xlab = "",ylab = "",lwd = 3)
n <- 200
p <- x[n]
## rnorm
col <- grey.colors(1,alpha = 0.1)
h <- hist(x,add = TRUE,freq = FALSE,border = col,cex = 2,col = col)
text(h$breaks[14],h$density[10],cex = 2,"rnorm")
arrows(h$breaks[13],h$density[10],h$breaks[11],h$density[10],col = 'lightgrey',lwd = 3)
## pnorm
polygon(c(x[x <= p],rev(x[x <= p])),c(rep(0,length(x[x<=p])),dnorm(rev(x[x<=p]))),col = "grey")
text(x[n/2],dnorm(x[n/2])/2,"pnorm",cex = 2)
## qnorm
arrows(p,0,p,dnorm(p),lwd = 3,lty = 2,code = 0)
text(p,0 - 0.025,"qnorm",cex = 2)
## dnorm
arrows(min(x),dnorm(p),p,dnorm(p),code = 0, lwd = 3,lty = 3)
text(min(x) - 0.5,dnorm(p),"dnorm",cex = 2,srt = 90)
## redo dnorm
lines(x,dnorm(x),lwd = 3)

## Poisson
set.seed(4321)
lam <- 2.5
x <- sort(rpois(1000,lam))
b <- barplot(dpois(unique(x),lam),axes = FALSE,col = col,border = col,
             ylim = c(-0.03,max(dpois(unique(x),lam))) + 0.02)
points(b[,1],dpois(unique(x),lam),cex = 3,pch = 20)
## rpois
text(b[8,1],dpois(unique(x)[5],lam),"rpois",cex = 2)
arrows(b[8,1],dpois(unique(x)[5],lam) - 0.01,
       b[6,1] + 0.5,dpois(unique(x)[7],lam) + 0.01,col = "lightgrey",lwd = 3)
## dpois
text(b[8,1],dpois(unique(x)[4],lam),"dpois",cex = 2)
arrows(b[7,1],dpois(unique(x)[4],lam),b[4,1],dpois(unique(x)[4],lam),code = 0,lwd = 3, lty = 3)
## qpois
text(b[4,1],-0.01,"qpois",cex = 2)
arrows(b[4,1],dpois(unique(x)[4],lam),b[4,1],0,code = 0,lwd = 3, lty = 2)
## ppois
barplot(dpois(unique(x)[1:2],lam),col = "grey",add = TRUE,border = "grey",axes = FALSE)
text(mean(b[1:2,1]),dpois(unique(x)[1],lam)/2,"ppois",cex = 2)
## redo dpois
points(b[,1],dpois(unique(x),lam),cex = 3,pch = 20)
dev.off()


#' Gradient function for negative binomial regression
#'
#' The following variables need to be available to the function in order to
#' be able to call `optim` using this as a gradient function:
#'
#' x - Regression coefficients matrix
#' beta - Regressors, such that beta * x = y
#' y - Observed count values
#'
#' @param par  numeric vector of coefficients in ’x’ and theta
#' @param .x  design matrix of dimension ‘n * p’
#' @param .y  vector of observations of length ‘n’
#' @param weights  vector of weights of length ‘n’
#' @param offset  vector of coefficient offsets of length ‘n’
#' @param verbose  print debug messages
#' @return  direction of steepest descent (the gradient)
gradient = function(par, .x, .y, weights=rep(1, nrow(.x)), offset=rep(0, nrow(.x)),
                    .verbose=FALSE) {
    beta = par[-length(par)]
    theta = exp(par[length(par)])
    mu = .x %*% beta + offset

    if (all(mu >= 0)) {
        grc = drop(.y - mu * (.y + theta)/(mu + theta))
        grt = digamma(.y + theta) - digamma(theta) +
            log(theta) + 1 - log(mu + theta) - (.y + theta)/(mu + theta)
        gr = -colSums(weights * cbind(grc * .x, grt * theta))
    } else {
        gr = c(-beta, 0) # trivial solution for mu=0
    }

    if (.verbose)
        message("gr: ", paste(sprintf("%.2f", gr), collapse=", "))
    gr
}


# Enter your code here. Read input from STDIN. Print output to STDOUT
girlprob <- 1 / 2.09
answer <- pbinom(3, size = 6, prob = girlprob)
write(round(answer, 3), stdout())


# R program - Linear Regression and Lasso Regression

# Read the datasets
data_train <- read.csv("/Project data analysis for business/train.csv")
data_test <- read.csv("/Project data analysis for business/test.csv")

# Split Train and Test using sample()
train <- sample(1:nrow(data_train), nrow(data_train)/2)
test <- (-train)

# Exploratory Data Analysis: verify correlation between the response SalePrice and every other predictor
pdf("my_plot.pdf")
par(mfrow = c(4,3))
for(i in 1:ncol(data_train)){
plot(data_train[,i], data_train$SalePrice, xlab=names(data_train[i]),
ylab="SalePrice", pch=20)
}
dev.off()

# Print how many NAs there are inside each predictor column
for (i in 1:ncol(data_train)){
    n <- sum(is.na(data_train[,i]))
    if (n > 100){
        cat("[", i, "]: ", n, "\n")
    }
}

# Remove predictors that shows a number of NAs > 500.
indexes_NA <- c() #boolean vector: TRUE means that
predictor i has NA values
for (i in 1:ncol(data_train)){
    n <- sum(is.na(data_train[,i]))
    if (n > 500){
        indexes_NA <- c(indexes_NA, TRUE)
    }
    else{ indexes_NA <- c(indexes_NA, FALSE) }
}
#remove:
data_train <- data_train[,!indexes_NA]

# Remove the predictor "Utilities", which contains only one level of factor.
data_train$Utilities <- NULL

# Solve other NAs issues
data_train$GarageFinish <- as.character(data_train$GarageFinish)
data_train$GarageFinish[is.na(data_train$GarageFinish)] <- "No"
data_train$GarageFinish <- as.factor(data_train$GarageFinish)
data_train$GarageQual <- as.character(data_train$GarageQual) > data_train$GarageQual[is.na(data_train$GarageQual)] <- "No"
data_train$GarageQual <- as.factor(data_train$GarageQual)
data_train$GarageYrBlt[is.na(data_train$GarageYrBlt)] <- 0
data_train$MasVnrArea[is.na(data_train$MasVnrArea)] <- mean(data_train$MasVnrArea, na.rm = TRUE) #substitute with mean
data_train$LotFrontage[is.na(data_train$LotFrontage)] <- mean(data_train$LotFrontage, na.rm = TRUE)
data_train$Electrical[is.na(data_train$Electrical)] <- "SBrkr"

# ++++++++++++++++++++++++++++++++++++++++++++++++
# ++++++++++++++++++++++++++++++++++++++++++++++++
# MODEL 1 - Fitting a Linear Regression

lm.fit <- lm(SalePrice~., data=data_train[train,])
summary(lm.fit)

# Compute "studentized residuals" to identify outliers
out <- abs(rstudent(lm.fit))
for(i in 1:length(out)){
    if(out[i] > 3){ print(out[i]) }
}

lm.fit <- lm(SalePrice ~ KitchenQual + X2ndFlrSF + X1stFlrSF + BsmtQual
+ MasVnrArea + OverallQual + OverallCond + LotArea + HouseStyle +
LotFrontage + YearBuilt +TotalBsmtSF, data = data_train[train,])

# Compute the Variance Inflaction Factor (VIF) to detect collinearity
library(car)
vif(lm.fit)

# ++++++++++++++++++++++++++++++++++++++++++++++++
# K-Fold Cross-Validation

mse.lm <- rep(0,10)
for(i in 1:10){
    set.seed(i)
    train <- sample(1:nrow(data_train), nrow(data_train)/2)
    test <- (-train)
    y <- data_train[test,]$SalePrice
    lm.fit <- lm(SalePrice ~ KitchenQual + X2ndFlrSF + X1stFlrSF +
BsmtQual + MasVnrArea + OverallQual + OverallCond + LotArea +
HouseStyle + LotFrontage + YearBuilt +TotalBsmtSF, data =
data_train[train,])
    pred <- predict(lm.fit, data_train[test,])
    mse.lm[i] <- mean((y - pred)^2)
}
print(sqrt(mean(mse.lm)))
# Average RMSE is 29,826.37

# ++++++++++++++++++++++++++++++++++++++++++++++++
# ++++++++++++++++++++++++++++++++++++++++++++++++
# MODEL 2 - Fitting the Lasso

install.packages("glmnet")
library(glmnet)

mse.lasso <- rep(0,10)
for (i in 1:10){
    x <- model.matrix(SalePrice~., data_train)[,-1] #Predictors
    y <- data_train$SalePrice #Response
    set.seed(i)
    train <- sample(1:nrow(x), nrow(x)/2) #split train and test
    test <- (-train)
    y.test = y[test]
    lasso.mod <- glmnet(x[train,], y[train], alpha=1) #fitting a lasso model
    cv.out <- cv.glmnet(x[train,], y[train], alpha=1) #find best lambda
    bestlam <- cv.out$lambda.min
    lasso.pred <- predict(lasso.mod, s=bestlam, newx=x[test,])
    mse.lasso[i] <- mean((y.test - lasso.pred)^2)
}
print(sqrt(mean(mse.lasso)))
# Average MSE is 26,409.52

# R-squared
rsq <- function(predicted, actual){
    mean <- mean(actual)
    tss <- 0
    rss <- 0
    for(i in 1:length(predicted)){
        tss <- tss + (actual[i] - mean)^2
        rss <- rss + (actual[i] - predicted[i])^2
}
    rs <- 1 - rss/tss
}

# Compute R-squared among 10 different dataset splits
rs.lasso <- rep(0,10)
for (i in 1:10){
    x <- model.matrix(SalePrice~., data_train)[,-1] #Predictors
    y <- data_train$SalePrice #Response
    set.seed(i)
    train <- sample(1:nrow(x), nrow(x)/2) #split train and test
    test <- (-train)
    y.test = y[test]
    lasso.mod <- glmnet(x[train,], y[train], alpha=1) #fitting a lasso model
    cv.out <- cv.glmnet(x[train,], y[train], alpha=1) #find best lambda
    bestlam <- cv.out$lambda.min
    lasso.pred <- predict(lasso.mod, s=bestlam, newx=x[test,])
    rs.lasso[i] <-rsq(lasso.pred, y.test)
}
print(sqrt(mean(rs.lasso)))
# R2 is 0.94


#Napoved ekoloških izdatkov Slovenije v prihodnjih letih =======================================
eko.potrosnja.slovenija <- eko.potrosnja %>%
  filter(Drzava == 'Slovenia') %>%
  transform(Izdatki.za.ekologijio = Izdatki.za.ekologijio / 1000)

napoved <- lm(data=eko.potrosnja.slovenija, eko.potrosnja.slovenija$Izdatki.za.ekologijio ~Leto)
dodatna.leta <- data.frame(Leto=seq(2017,2021,1))
napoved.potrosnje <- mutate(dodatna.leta, Izdatki.za.ekologijio=predict(napoved, dodatna.leta))

graf.napovedi.praga.slo <- ggplot(eko.potrosnja.slovenija, aes(x=Leto, y=Izdatki.za.ekologijio)) +
  geom_smooth(method=lm, fullrange=TRUE, color='yellow') +
  geom_point(data=napoved.potrosnje, inherit.aes=TRUE, colour="red") +
  geom_point() +
  scale_x_continuous('Leto', breaks=seq(2008, 2021, 1), limits=c(2008, 2021)) +
  ggtitle('Napoved izdatkov za ekologijo Slovenije v letih 2017-2021') +
  theme(plot.title=element_text(hjust=0.5, size=15, face="bold")) +
  theme_bw() +
  xlab("Leto") +
  ylab("Izdatki za ekologijo v milijardah €")

# plot(graf.napovedi.praga.slo)

##Napoved ekoloških izdatkov Nemčije v prihodnjih letih =======================================
eko.potrosnja.nemcija <- eko.potrosnja %>%
  filter(Drzava == 'Germany') %>%
  transform(Izdatki.za.ekologijio = Izdatki.za.ekologijio / 1000)

napoved <- lm(data=eko.potrosnja.nemcija, eko.potrosnja.nemcija$Izdatki.za.ekologijio ~Leto)
dodatna.leta <- data.frame(Leto=seq(2017,2021,1))
napoved.potrosnje <- mutate(dodatna.leta, Izdatki.za.ekologijio=predict(napoved, dodatna.leta))

graf.napovedi.praga.nem <- ggplot(eko.potrosnja.nemcija, aes(x=Leto, y=Izdatki.za.ekologijio)) +
  geom_smooth(method=lm, fullrange=TRUE, color="yellow") +
  geom_point(data=napoved.potrosnje, inherit.aes=TRUE, colour="red") +
  geom_point() +
  scale_x_continuous('Leto', breaks = seq(2008, 2021, 1), limits=c(2008, 2021)) +
  ggtitle('Napoved izdatkov za ekologijo Nemčije v letih 2016-2020') +
  theme(plot.title=element_text(hjust=0.5, size=15, face="bold")) +
  theme_bw() +
  xlab("Leto") +
  ylab("Izdatki za ekologijo v milijardah €")

# plot(graf.napovedi.praga.nem)