setwd("/Users/Chris/Desktop/PSU_Class_Documents/2014_Fall_Semester_Classes/STAT_557_Data_Mining/assignment_1")
library(ggplot2)
library(MASS)
library(ISLR)

full_data <- read.csv(file = "adult_afterProc_edited.csv", header=FALSE, sep = ",")
slim_data <- read.csv(file = "afterpca.csv", header=FALSE, sep = ",")
head(slim_data)
summary(slim_data$V1)

library(RColorBrewer)
gg <- ggplot(diamonds, aes(x=carat, y=price, colour=cut)) + geom_point(size=1.5)
gg + scale_fill_brewer(palette="Oranges")
plotto <- ggplot(slim_data, aes(x = V2, y = V3, colour = V1)) + geom_point(size = 1.5, pex=19)
plotto + ggtitle("Scatterplot by Class")

plotto + geom_point()
# Testing LDA in general #

fit1 <- lda(V1 ~ V2 + V3, data=slim_data,
            na.action="na.omit", CV=TRUE)
fit1
item <- table(slim_data$V1, fit1$class)
diag(prop.table(item, 1))
sum(diag(prop.table(item)))
# Using the R package for LDA gives us a success rate of 83.4%
# doing it from lab book
library(MASS)
lda.fit = lda(y~age+pre4,data=na.omit(train_thor))
lda.fit
plot(lda.fit)
lda.pred <- predict(lda.fit, test_thor)
names(lda.pred)
lda.class = lda.pred$class
table(lda.class, test_thor$y)
mean(lda.class==test_thor$y)
# Now to try with QDA
qda.fit <- qda(V1~V2+V3,data=na.omit(train))
qda.fit

qda.class <- predict(qda.fit, test)$class
table(qda.class, test$V1)
## QDA test 2
qda.fit2 <- qda(V1~V2+V3,data=na.omit(train), prior=c(0.5,0.5))
plot(qda2.class, test$V1)
# testing priors at 0.7 and 0.3
qda.fit3 <- qda(V1~V2+V3,data=na.omit(train), prior=c(0.55,0.45))
qda.class3 <- predict(qda.fit3, test)$class
table(qda.class3, test$V1)

# Testing covariance matrix using Bartlett's test #
bartlett.test(V2+V3~V1, slim_train)
length(train)
length(train$V1)

# Setting up a prediction just to try out scatting qda classifier
qda_predict <- data.frame(test, y = as.numeric(predict(qda.fit, test)$class))

plotto <- ggplot(train, aes(x = V2, y = V3, color = V1)) + geom_point()
plotto + stat_contour(aes(x = V2, y = V3, z = V1), data = qda_predict) + ggtitle("QDA Decision Boundaries")

qda2.class <- predict(qda.fit2, test)$class
table(qda2.class, test$V1)
summary(test$V1)
# trying to plot the results of the prediction.
library(adegenet)
data(test)
x <- test$V1
grp <- find.clusters(x, max.n.clust = 2)
clust1 <-
plotto <- ggplot(slim_data, aes(V1, V1), class=V1, colour=V1)
plotto + geom_point()

## Splitting UP the data frame ##

full_smp_size <- floor(0.75 * nrow(full_data))

## set the seed to make your partition reproductible
set.seed(123)
full_train_ind <- sample(seq_len(nrow(full_data)), size = full_smp_size)

full_train <- full_data[full_train_ind, ]
full_test <- full_data[-full_train_ind, ]

fitqda1 <- qda(V1 ~ V2 + V3, data=na.omit(slim_data), prior=c(1, 1)/2)
fitqda1

## Ok, did that, still not sure why I can't get a fitqda statistics thing.

# doing the stock logit to check it.

income1 <- glm(V1 ~ V2 + V3, data=na.omit(testdata), family=binomial(link="logit"))
summary(income1)

## QDA Function for STAT 557 ##
qda_byhand <- function(train, test){
  # Function for quadratic discriminant analysis
  # function receives dataframe as input, assumes y is in first column.
  #
  p = ncol(train)
  n = nrow(train)
  k = 2
  # In this function, I'm only writing it for K = 2, but it could be customized
  # to have K have more classes.
  data1 <- data.train[data.train$y==0,2:p]
  data2 <- data.train[data.train$y==1,2:p]
  n1 <- nrow(data1)
  n2 <- nrow(data2)
  pi1 <- n1/n
  pi2 <- n2/n
  ## Means of data sets
  means1 <- apply(data1,2,mean)
  means2 <- apply(data2,2,mean)
  ## Calculate sigma
  var1 <- apply(data1,2,function(x) (x-mean(x)))
  var1 <- (t(var1))%*%(var1)
  var2 <- apply(data2,2,function(x) (x-mean(x)))
  var2 <- (t(var2))%*%(var2)
  sigma <- (var1+var2)/(n-k)
  sigma.inv <- solve(sigma)
  a0 <- as.vector(-(log(pi2/pi1)) + t(.5*(means1+means2))%*%sigma.inv%*%(means2-means1))
  a <- sigma.inv%*%(means2-means1)
  y.test <- data.test[,1]
  xvals <- as.matrix(data.t2[,2:p])%*%a
  predictions <- ifelse(xvals> a0,1,0)
  confusion.matrix <- table(predictions,y.test)
  error.rate <- (sum(confusion.matrix[2,1] + confusion.matrix[1,2]))/(sum(confusion.matrix))
  sensitivity <- (sum(confusion.matrix[2,2]))/(sum(confusion.matrix[,2]))
  specificity <- (sum(confusion.matrix[1,1]))/(sum(confusion.matrix[,1]))
  performance <- list(error=error.rate, sens=sensitivity, spec=specificity)
  return(performance)
}

lda_out <- lda(V1~.,data=train)
qda_out <- qda(V1~.,data=train)
require(ggplot2)
lda_predict <- data.frame(test, y=as.numeric(predict(lda_out, test)$class))
qda_predict <- data.frame(test, y= as.numeric(predict(qda_out, test)$class))

p <-ggplot(train, aes(x=V2, y=V1, color=y)) + geom_point()
p + stat_contour(aes(x=V2, y=V1,z=y), data=lda_predict) + ggtitle("LDA Decision Boundaries")

p + stat_contour(aes(x=V2, y=V1, z=y),data=qda_predict) + ggtitle("QDA Decision Boundaries")

#####################################################
##### QDA with Full Data - 81 dimensions - 1 DV #####
#####################################################

# Now to try with QDA
qda.fit_full <- qda(V1~V2+V3+V4+V5+V6+V8+V9+V10+V11+V12+V13+V14+V15+V16+V18+V19+V20+V21+V22+V23+V24+V25+V26+V27+V28+V30+V32+V33+V34+V35+V36+V38+V39+V40+V41
                    ,data=na.omit(full_train))
qda.fit_full
# variables causing issues: V7, V17, V29, V31, V37, V42
qda.fit_full.class <- predict(qda.fit_full, full_test)$class
table(qda.fit_full.class, full_test$V1)
# V2+V3+V4+V5+V6+V7+V8+V9+V10+V11+V12

qda.class <- predict(qda.fit, test)$class
table(qda.class, test$V1)
## Calculating error, specificity, sensitivity.

dim(full_test)
full_model_QDA_ER <- ((225+4084)/11306)*100
full_model_QDA_ER # with test error - 38.1
# Make a table with the inter-training error
qda.fit_full_train.class <- predict(qda.fit_full, full_train)$class
table(qda.fit_full_train.class, full_train$V1)
dim(full_train) # 33916
# training error from qda in full.
((657+12163)/33916)*100
# training error 37.8
# says all arguments must have same length.
length(qda.fit_full.class) # says 11306
length(full_train$V1) # says 33916 - I get it.

####################################################
###### 10 fold cross-validation attempt for qda ####
####################################################

## Splitting UP the data frame ##

slim_smp_size <- floor(0.75 * nrow(slim_data))

## set the seed to make your partition reproductible
set.seed(123)
slim_train_ind <- sample(seq_len(nrow(slim_data)), size = slim_smp_size)

slim_train <- slim_data[slim_train_ind, ]
slim_test <- slim_data[-slim_train_ind, ]

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

qda.fit_slim <- qda(V1~V2+V3,data=na.omit(slim_train))
qda.fit_slim
## Getting error rate for slim_train

qda.fit_full_train.class <- predict(qda.fit_full, full_train)$class
table(qda.fit_full_train.class, full_train$V1)

qda.fit_slim_train.class <- predict(qda.fit_slim, slim_train)$class
table(qda.fit_slim_train.class, slim_train$V1)
##
qda.class_slim <- predict(qda.fit_slim, slim_test)$class
table(qda.class_slim, slim_test$V1)

set.seed(17)
cv.error.10=rep(0,10)
for (i in 1:10){
  qda.fit=qda(mpg~poly(horsepower,i),data=Auto)
  cv.error.10[i]=cv.glm(Auto,glm.fit,K=10)$delta[1]
}
cv.error.10

## attempt ##

qda1=qda(V1~V2+V3,data=slim_train,CV=TRUE)
tab1=table(qda1$class,slim_train$V1)
tab1
## Leave one out - just classified everything as 0 again ###

## 10 Fold CV Item ##
library(caret)
misclassification.rate=function(tab){
  num1=sum(diag(tab))
  denom1=sum(tab)
  signif(1-num1/denom1,3)
}
# testing the misclassification rate function #
misclassification.rate(tab1)
# Gives an error rate of 16.7

#Then each element of flds is a list of indexes for each dataset.
#If your dataset is called dat, then dat[flds$train,] gets
#you the training set, dat[ flds[[2]], ] gets you the
#second fold set, etc.
library(cvTools)
k <- 10 #the number of folds

folds <- cvFolds(NROW(slim_train), K=k)

for(i in 1:k){
  train <- slim_train[folds$subsets[folds$which != i], ] #Set the training set
  validation <- slim_train[folds$subsets[folds$which == i], ] #Set the validation set

  newqda <- qda(V1~V2+V3,data=train) #Get your new linear model (just fit on the train data)
  newpred <- predict(newqda, validation)$class #Get the predicitons for the validation set (from the model just fit on the train data)
  tab <- table(newpred, validation$V1)
  print(misclassification.rate(tab)) #Put the hold out prediction in the data set for later use
}

qda.fit_slim1 <- qda(V1~V2+V3,data=slim_data[flds$train,])
qda.fit_slim1
qda.fit_slim_train.class <- predict(qda.fit_slim, slim_train)$class
table(qda.fit_slim_train.class, slim_train$V1)


data_file = "winequality/winequality-red.csv"

wine <- read.csv( data_file, sep=';', header = TRUE )

# number of elements
numel = length( as.matrix( wine )) / length( wine )

# pca analysis
pcx <- prcomp( wine, scale = TRUE )
biplot( pcx, xlabs = rep( '.', numel ))

# another window
dev.new()

# principal components
bar_colors = c( 'red', 'red', rep( 'gray', 10 ))
plot( pcx, col = bar_colors )


# demo: regression
# author: Daniel Adler

rgl.demo.regression <- function(n=100,xa=3,za=8,xb=0.02,zb=0.01,xlim=c(0,100),zlim=c(0,100)) {

  rgl.clear("all")
  rgl.bg(sphere = TRUE, color = c("black", "green"), lit = FALSE, size=2, alpha=0.2, back = "lines")
  rgl.light()
  rgl.bbox()

  x  <- runif(n,min=xlim[1],max=xlim[2])
  z  <- runif(n,min=zlim[1],max=zlim[2])
  ex <- rnorm(n,sd=3)
  ez <- rnorm(n,sd=2)

  esty  <- (xa+xb*x) * (za+zb*z) + ex + ez

  rgl.spheres(x,esty,z,color="gray",radius=1.5,specular="green",
              texture=system.file("textures/bump_dust.png",package="rgl"),
              texmipmap=TRUE, texminfilter="linear.mipmap.linear")

  regx  <- seq(xlim[1],xlim[2],len=100)
  regz  <- seq(zlim[1],zlim[2],len=100)
  regy  <- (xa+regx*xb) %*% t(za+regz*zb)

  rgl.surface(regx,regz,regy,color="blue",alpha=0.5,shininess=128)

  lx <- c(xlim[1],xlim[2],xlim[2],xlim[1])
  lz <- c(zlim[1],zlim[1],zlim[2],zlim[2])
  f <- function(x,z) (xa+x*xb) * t(za+z*zb)
  ly <- f(lx,lz)

  rgl.quads(lx,ly,lz,color="red",size=5,front="lines",back="lines",lit=FALSE)
}

rgl.open()
rgl.demo.regression()


# Random Forest Regression

# Importar el dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[, 2:3]

# Dividir los datos en conjunto de entrenamiento y conjunto de test
# install.packages("caTools")
# library(caTools)
# set.seed(123)
# split = sample.split(dataset$Purchased, SplitRatio = 0.8)
# training_set = subset(dataset, split == TRUE)
# testing_set = subset(dataset, split == FALSE)

# Escalado de valores
# training_set[,2:3] = scale(training_set[,2:3])
# testing_set[,2:3] = scale(testing_set[,2:3])

# Ajustar Modelo de Random Forest con el Conjunto de Datos
# install.packages("randomForest")
library(randomForest)
set.seed(1234)
regression = randomForest(x = dataset[1], # DFM pide un data frame
                          y = dataset$Salary,
                          ntree = 500)

# Predicción de nuevos resultados con Regresión
y_pred = predict(regression, newdata = data.frame(Level = 6.5))

# Visualización del modelo de Random Forest
# install.packages("ggplot2")
library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.01)
ggplot() +
  geom_point(aes(x = dataset$Level , y = dataset$Salary),
             color = "red") +
  geom_line(aes(x = x_grid, y = predict(regression,
                                        newdata = data.frame(Level = x_grid))),
            color = "blue") +
  ggtitle("Predicción (Random Forest)") +
  xlab("Nivel del empleado") +
  ylab("Sueldo (en $)")

datasets/Part 2 - Regression/Section 9 - Random Forest Regression/random_forest_regression.r


# DLC 2019
# set of functions allowing to define Var[y]
# and plot Corr[y] for objects of class
# lmerModLmerTest or lmerMod

Omega.matrix = function(model) {
    if(class(model)[1]=="lmerModLmerTest"|class(model)[1]=="lmerMod"){
        sigma2.epsilon = sigma(model)^2
        Psi.star       = crossprod(getME(model,"Lambdat"))*sigma2.epsilon
        Z              = getME(model,"Z")
        Omega          = Z %*% Psi.star %*% t(Z) + sigma2.epsilon* Diagonal(nrow(Z))
        Omega
    }else{
        warning("Function only works on outcput of function lmer()\n")
    }
    }
    #Corr.fun = function(Sigma){
    #    D = sqrt(diag(diag(Sigma)))
    #    DInv = solve(D)
    #    DInv %*% Sigma %*% DInv
    #    }
Omega.plot = function(Omega,legend=TRUE,axes=TRUE){
    corw = cov2cor(Omega)
    if(any(corw<0)){
        colw=c(gray(1),rainbow(197)[197:100],gray(.9),rainbow(197)[99:1],gray(0))
        zlim=c(-1,1)
    }else{
        colw=c(gray(.9),rainbow(98)[98:1],gray(0))
        zlim=c(0,1)
    }
    image(z=as.matrix(corw[nrow(corw):1,]),zlim=zlim,axes=FALSE,col=colw)
    if(legend){
        valw = as.numeric(names(table(as.matrix(corw))))
        posw = round(valw*length(colw))
        posw[posw==0] = 1
        posw[posw>length(colw)] = length(colw)
        legend("topright",ncol=1,legend=format(round(valw,4)),
               col=colw[posw],pch=15,bg="light gray",
               title="Values",box.lwd=NA)
        }
    if(axes){
        axis(3,at=seq(0,1,length=nrow(Omega)),labels=FALSE)
        axis(2,at=seq(0,1,length=nrow(Omega)),labels=FALSE)
        axis(2,at=c(1,0),c(1,nrow(Omega)),las=2)
        axis(3,at=c(0,1),c(1,nrow(Omega)),las=1)
        }
    }


# Returns the number and size of Cloudfront log files generated per month
cfLogsGenerated <- function(events, edgeLocations){
	dataVolume <- sizeOfCfLogsGenerated(events)
	numOfFiles <- numOfCfLogs(events, edgeLocations)
	c(dataVolume, numOfFiles)
}

sizeOfCfLogsGenerated <- function(events){
	intercept <- 1692.2848
	gradient <- 148.0076
	toGiga(intercept + events * gradient)
}

numOfCfLogs <- function(events, edgeLocations){
	# Cloudfront log files are generated hourly - therefore we need to base our calculations on the number produced per month
	hoursPerMonth <- 24*365.25/12
	eventsPerHour <- events / hoursPerMonth

	# Model the number of log files generated each month in a single vector
	logFilesGeneratedByHour <- vector()
	for(i in 1:ceiling(hoursPerMonth)){
		logFilesGeneratedByHour <-
			append(logFilesGeneratedByHour, numOfCfLogsPerHour(eventsPerHour, edgeLocations))
	}

	# Return the sum of all the log files generated each hour
	sum(logFilesGeneratedByHour)
}

numOfCfLogsPerHour <- function(eventsPerHour, edgeLocations){
	# For each event, generate a random number between 1 and the number of edge locations
	# This is the Cloudfront Edge location that the event "hits"
	# Assume that one log file is generated for each edge location hit each hour
	# Then the number of log files generated in each hour is the length of the set of edge locations hit
	length(unique(sample(1:edgeLocations, eventsPerHour, replace=T)))
}


#: Content calculate the entropy (according to the information contained in the variable itself). A high entropy is preferred as more information is carried in the variable.

library(entropy)

#: for debug, use errorhanliding = "pass", verbose = TRUE, and .combine = list.
entropy_dbl <- foreach(col = joined_dt %>% select(.,
                                                  matches("cig|HOME_ADDR_STE_CD|MEMBR_AGE|GENDER_CD_M|x_lob|x_product"))
, .combine = c, .errorhandling='stop', .verbose = FALSE) %dopar% {

  message(class(col))

  if (inherits(col, c("factor", "character"))) {

    y <- table(col, useNA = "ifany")
    en <- entropy(y)

  } else {

    y <- discretize(col, numBins = 10, r=range(col, na.rm = TRUE)) %>% table(., useNA = "ifany")
    en <- entropy(y)

  }

  return(en)
}

#: render the names
names(entropy_dbl) <- colnames(joined_dt %>% select(., matches("cig|HOME_ADDR_STE_CD|MEMBR_AGE|GENDER_CD_M|x_lob|x_product")))

#: build the dt object, later convenient for subset.
entropy_dt <- entropy_dbl %>% as.data.table(., keep.rownames = TRUE )

setkey(entropy_dt, rn )

setnames(entropy_dt, c("rn", "entropy"))

entropy_dt


z.hist <- function(nn=1000) { # z.hist.r
 par(mfrow=c(1,2))
 hist(rnorm(1000))
 hist(rnorm(1000), freq=F)
 lines(x<-seq(-3,3, length=100), dnorm(x))
} # end function

z.hist()


#' @title Summary statistics for a quantitative variable
#' @description This function provides descriptive statistics for a quantitative
#' variable alone or seperately by groups. Any function that returns a single
#' numeric value can bue used.
#' @param data data frame
#' @param x numeric variable in data (unquoted)
#' @param statistics statistics to calculate (any function that produces a
#'  numeric value), Default: \code{c("n", "mean", "sd")}
#' @param na.rm if \code{TRUE}, delete cases with missing values on x and or grouping
#'  variables, Default: \code{TRUE}
#' @param digits number of decimal digits to print, Default: 2
#' @param ... list of grouping variables
#' @importFrom purrr map_dfc
#' @import dplyr
#' @importFrom purrr map_dfc
#' @import rlang
#' @import haven
#' @return a data frame, where columns are grouping variables (optional) and
#' statistics
#' @examples
#' # If no keyword arguments are provided, default values are used
#' qstats(mtcars, mpg, am, gear)
#'
#' # You can supply as many (or no) grouping variables as needed
#' qstats(mtcars, mpg)
#'
#' qstats(mtcars, mpg, am, cyl)
#'
#' # You can specify your own functions (e.g., median,
#' # median absolute deviation, minimum, maximum))
#' qstats(mtcars, mpg, am, gear,
#'        stats = c("median", "mad", "min", "max"))
#' @rdname qstats
#' @export
qstats <- function(data, x, ...){
  x <- enquo(x)
  dots <- enquos(...)
  if(!is.numeric(data %>% pull(!!x))){
    stop("data$x is not numeric")
  }

  ## stats
  median <- function(xs){
    ys <- sort(xs)
    m <- length(xs)/2
    if(length(xs) %% 2 == 0){
      mean(c(ys[m], ys[m+1]))
    } else {
      ys[floor(m) + 1]
    }
  }

  n <- function(xs){
    length(xs)
  }

  ## Auxiliary functions
  my_sum <- function(data, col, cus_sum) {
    col <- enquo(col)
    cus_sum_name <- cus_sum
    cus_sum <- rlang::as_function(cus_sum)

    data %>%
      summarise(!!cus_sum_name := cus_sum(!!col))
  }

  my_sums <- function(data, col, cus_sums) {
    col <- enquo(col)
    purrr::map_dfc(cus_sums, my_sum, data = data, col = !!col)
  }

  extract_list_unnamed_elems <- function(my_list){
    unnamed_idxs <- (1:length(my_list))[names(my_list)  == ""]
    my_list[unnamed_idxs]
  }

  stats <- if(is.null(dots$stats)) {
      c("n", "mean", "sd")
    } else {
      eval(rlang::quo_get_expr(dots$stats))
    }
  na.rm <- if(is.null(dots$na.rm)) TRUE else rlang::quo_get_expr(dots$na.rm)
  digits <- if(is.null(dots$digits)) 2 else rlang::quo_get_expr(dots$digits)
  grouping_vars <- extract_list_unnamed_elems(dots)

  data <- data %>% select(!!x, !!!grouping_vars)

  if(na.rm){
    data <- stats::na.omit(data)
  }

  data %>%
    mutate_at(vars(!!!grouping_vars), as_factor) %>%
    group_by(!!!grouping_vars) %>%
    group_modify(~my_sums(.x, col = !!x, cus_sums = stats)) %>%
    mutate_at(vars(-group_cols()), ~ round(as.double(.x), digits = digits)) %>%
    ungroup() %>% as.data.frame()
}


library(quantmod)

get_irx_ratio <- function(from ,to){
    IRX = getSymbols("^IRX", from = from, to=to,
            auto.assign=FALSE)
    IRX_Adj_Close = data.frame(IRX)$IRX.Adjust
    IRX_Annual_Return = (IRX_Adj_Close/100)[2:length(IRX_Adj_Close)]
    IRX_Annual_Log_Return = log(1+IRX_Annual_Return)
    IRX_Daily_Log_Return = IRX_Annual_Log_Return/252
    IRX_Daily_Log_Return
}

get_price <- function(s, to, from){
    INSTR = getSymbols(paste("^",s,sep=""), from = from, to=to,
            auto.assign=FALSE)
    cmd = sprintf("data.frame(INSTR)$%s.Adjusted", s)
    INSTR_Adj_Close=eval(parse(text=cmd))

    INSTR_Adj_Close
}

get_price2 <- function(s, to, from){
    INSTR = getSymbols(s, from = from, to=to,
            auto.assign=FALSE)
    cmd = sprintf("data.frame(INSTR)$%s.Adjusted", s)
    INSTR_Adj_Close=eval(parse(text=cmd))

    INSTR_Adj_Close
}


#' Calculate the dot product between all the possible combinations of foldchanges from diferent clusters.
#'
#' `foldchange_composition()` returns a dataframe containing the best top similarities between all possible pairs of single cell samples.
#'
#' This function will perform the dot product of each possible combination of foldchanges, by constructing two dataframes, one with the source cluster's foldchanges and
#' the other with the foldchange values of a target sample's cluster. The computation of all the possible combinations is the hadamard product of the matrix.
#'
#' @param root Dataframe. Foldchanges between a source cluster and all the other clusters found on a sample.
#' @param comparative Dataframe. Foldchanges between a cluster and all the other clusters found on a second sample to be compared with the (root) cluster foldchanges.
#'
#' @return A dataframe containing the hadamard product of all the possible combinations of foldchanges.
#'
#' @export
foldchange_composition <- function(root = NULL, comparative = NULL){
  # Avoiding 1 column matrix to vector conversion when subseting index
  root <- as.matrix(root)
  comparative <- as.matrix(comparative)
  tmp <- t(matrix(unlist(root),nrow = nrow(root), ncol = ncol(root)*ncol(comparative))) * matrix(rep(t(comparative),each=ncol(root)),ncol = nrow(root))
  colnames(tmp) <- rownames(root)
  return(tmp)
  }


library(bivpois) # load bivpois library
data(ex2.sim)    # load ex2.sim data from bivpois library
xtemp<-readline(prompt = "Press Enter to Continue")
#
ex2.m1<-lm.bp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim )		# Model  1: BivPois
ex2.m2<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=0)	# Model  2: Zero Inflated BivPois
ex2.m3<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=1)	# Model  3: Diagonal Inflated BivPois with DISCRETE(1) diagonal inflation distribution
ex2.m4<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=2)	# Model  4: Diagonal Inflated BivPois with DISCRETE(2) diagonal inflation distribution
ex2.m5<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=3)	# Model  5: Diagonal Inflated BivPois with DISCRETE(3) diagonal inflation distribution
ex2.m6<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=4)	# Model  6: Diagonal Inflated BivPois with DISCRETE(4) diagonal inflation distribution
ex2.m7<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=5)	# Model  7: Diagonal Inflated BivPois with DISCRETE(5) diagonal inflation distribution
ex2.m8<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , jmax=6)	# Model  8: Diagonal Inflated BivPois with DISCRETE(6) diagonal inflation distribution
ex2.m9<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , distribution='poisson')	# Model  9: Diagonal Inflated BivPois with POISSON diagonal inflation distribution
ex2.m10<-lm.dibp( x~z1 , y~z1+z5, l1l2=~z3, l3=~.-z5, data=ex2.sim , distribution='geometric')	# Model 10: Diagonal Inflated BivPois with GEOMETRIC diagonal inflation distribution
#
# printing parameters of model 7
ex2.m7$beta1
ex2.m7$beta2
ex2.m7$beta3
ex2.m7$p
ex2.m7$theta
#
# printing parameters of model 9
ex2.m9$beta1
ex2.m9$beta2
ex2.m9$beta3
ex2.m9$p
ex2.m9$theta


#' Balance test for sample size between treatments
#'
#' @description This function implements chi-squared test for
#'     the null hypothesis that sample size across treatments is equal.
#'
#' @param d a formula object whose right hand side is treatment variable (`~ d`)
#' @param data an object whose class is `data.frame`
#'
#' @return this function returns a matrix including
#'     sample size in each treatment and p-value of chi-squared test.
#'     This matrix has `RCT` and `nbalance` classes.
#'
#' @importFrom stats chisq.test
#'
#' @export
#+
chi2n <- function(d, data) {

  # extract treatment variable as strings
  dvar <- all.vars(d)

  # table of sample size
  sample <- table(data[, dvar])

  # count #.treatment status and extract label
  treat <- names(sample); tn <- length(names(sample))

  # Chi-squared test
  pval <- chisq.test(sample, p = rep(1 / tn, tn))$p.value

  # make matrix
  tab <- matrix(c(sample, pval), nrow = 1)
  colnames(tab) <- c(treat, "p-value")

  class(tab) <- append(c("RCT", "nbalance"), class(tab))
  return(tab)
}


# Written by Denise Verbakel
# I used RStudio to run this program and get the corresponding output file (relation_branch_number_and_round_cost.png)

#bbn = bit branch number
#noopb = number of operations per bit

# Assign the corresponding values to the vectors bbn and noopb
bbn <- c(6,5,2,2,2,4)
noopb <- c(3,2.25,0.75,0.75,0,2)

# Compute the averages and estimated values
bbn_bar = sum(bbn)/length(bbn)
noopb_bar = sum(noopb)/length(noopb)
beta_hat = sum((bbn-bbn_bar)*(noopb-noopb_bar))/sum((bbn-bbn_bar)^2)
alpha_hat = noopb_bar - beta_hat * bbn_bar

# Make a scatterplot of the data points and draw the estimated average with a red line
plot(bbn,noopb,
     xlab="Bit Branch Number",
     ylab="# Operations Per Bit",
     pch=16,
     cex.axis=1.5,
     cex.lab=1.5)
abline(alpha_hat,beta_hat,
       col='red',
       lwd=2)


####################################################################################
# multiregtable(varnames, varlabels, models, roundparam, addrows)
#
# Description
# -----------
# Take a list of fitted models and organize the results into a data frame
# with each model in a separate column.
#
# Arguments
# ---------
#       varnames        List of the variables to be included as rows
#       varlabels       Hash mapping variable names into labels for printing
#       models          List of fitted models
#       roundparam      Number of decimal places to round to
#       addrows         Any extra rows to insert in between the usual coef
#                       estimates and the N/R^2; for example, a row of Y/Ns
#                       indicating whether time FEs were included.
# Notes
# -----
# Calls helper functions multiregtable_addons(), multiregtable_sigsymbol().
#
####################################################################################

multiregtable <- function(varnames, varlabels, models, roundparam, addrows = NULL){

    rows <- NROW(varnames)
    cols <- NROW(models) + 1
    rettab <- as.data.frame(matrix(NA, nrow=rows*2, ncol=cols))

    # print row names
    for (v in 1:rows){
        rettab[v*2 - 1, 1] <- varlabels[varnames[v]]
        rettab[v*2, 1] <- c("")
    }

    # fill in numeric quantities
    for (m in 1:(cols-1)){
        for (v in 1:rows){
            if (varnames[v] %in% names(models[[m]]$coefficients)) {

                # find variance matrix -- named differently by ols(), tsls(), gmm()
                if(!is.null(models[[m]]$var)){
                    thevar <- models[[m]]$var
                } else if (!is.null(models[[m]]$V)){
                    thevar <- models[[m]]$V
                } else if (!is.null(models[[m]]$vcov)){
                    thevar <- models[[m]]$vcov
                }

                t.ratio <- models[[m]]$coefficients[varnames[v]]/sqrt(thevar[varnames[v],varnames[v]])
                rettab[v*2 - 1, m+1] <- paste(roundsig(models[[m]]$coefficients[varnames[v]], roundparam), "$^{", multiregtable_sigsymbol(t.ratio), "}$", sep="")
                rettab[v*2, m+1] <- paste("{\\scriptsize (", roundsig(sqrt(thevar[varnames[v],varnames[v]]), roundparam), ")}",  sep="")
            }
            else {
                rettab[v*2 - 1, m+1] <- c("")
                rettab[v*2, m+1] <- c("")
            }
        }
    }

    # tack on any extra rows handed to us
    if(!is.null(addrows)){
        startrow <- rows*2+1
        endrow <- rows*2+nrow(addrows)
        rettab[startrow:endrow,] <- addrows
        nadded <- nrow(addrows)
    } else {
        nadded <- 0
    }

    # add final summary stats
    startrow <- rows*2+nadded+1
    endrow <- rows*2+nadded+2
    rettab[startrow:endrow,] <- multiregtable_addons(models, roundparam)

    # return
    return(rettab)
}

multiregtable_sigsymbol <- function(t.ratio){

    if (pnorm(abs(t.ratio)) > 0.995){ return(c("***")) }
    else if (pnorm(abs(t.ratio)) > 0.975){ return(c("**")) }
    else if (pnorm(abs(t.ratio)) > 0.95){ return(c("*")) }
    else { return(c("")) }

}

multiregtable_addons <- function(models, roundparam){

    cols <- NROW(models) + 1
    rettab <- as.data.frame(matrix(NA, nrow=2, ncol=cols))
    rettab[1,1] <- c("N")
    rettab[2,1] <- c("$R^2$")

    for (m in 1:(cols-1)){
        if (models[[m]]$call[1] == "lm()"){
            rettab[1,m+1] <- NROW(models[[m]]$residuals)
            rettab[2,m+1] <- roundsig(summary.lm(models[[m]])$r.squared, roundparam)
        } else if (!is.null(models[[m]]$x)) {
            rettab[1,m+1] <- NROW(models[[m]]$x)
            rettab[2,m+1] <- roundsig(summary.lm(models[[m]])$r.squared, roundparam)
        } else if (!is.null(models[[m]]$n)) {
            rettab[1,m+1] <- models[[m]]$n
            rettab[2,m+1] <- c("-")
        } else {
            rettab[1,m+1] <- c("-")
            rettab[2,m+1] <- c("-")
        }
    }
    return(rettab)
}

roundsig <- function(vector, sigfigs){
    retvec <- rep("", NROW(vector))
    for (i in 1:NROW(vector)){

        number <- vector[i]
        prelim <- round(number, sigfigs)
        out <- prelim
        if ((sigfigs > 0) & (prelim %% 1 == 0)){out <- paste(out, ".", sep="")}
        addzeros <- ""
        az <- 1
        while ((az <= sigfigs) & ((prelim * 10^sigfigs) %% (10^az) == 0)){
            addzeros <- paste(addzeros, "0", sep="")
            az <- az + 1
        }
        retvec[i] <- paste(out, addzeros, sep="")
    }
    return(retvec)
}


# Bernoulli numbers. 12/8/16 aev
require(pracma)
bernoulli(60)


## Test center option for lrm
require(rms)
x <- rnorm(30)
y <- sample(0:4, 30, TRUE)
f <- lrm(y ~ pol(x, 2), scale=FALSE)
g <- lrm(y ~ pol(x, 2), scale=TRUE)
coef(f) - coef(g)
d <- vcov(f) - vcov(g)
d
max(abs(d))

f <- orm(y ~ pol(x, 2), scale=FALSE)
g <- orm(y ~ pol(x, 2), scale=TRUE)
coef(f)
coef(g)
f$var / g$var
vcov(f)/vcov(g)
vcov(f, regcoef.only=FALSE)/vcov(g, regcoef.only=FALSE)
vcov(f, intercepts='all') / vcov(g, intercepts='all')
vcov(f, intercepts=1)/vcov(g, intercepts=1)
vcov(f, intercepts=c(1,3))/vcov(g, intercepts=c(1,3))


#########################
# Role co-participation
#########################
m.thread_cluster <- merge(df.posts, df.users, by='user') %>%
  acast(thread~cluster) %>%
  apply(1, function(x) x/sum(x)) %>%
  t

role.cooccur <- t(m.thread_cluster)%*%m.thread_cluster
image(role.cooccur)

##############################
# User co-participations
##############################
# TODO: It might be interesting to do blockmodeling over the cooccur matrix
user_thread_matrix <- group_by(df.posts, user, thread)  %>%
  tally() %>%
  acast(user ~ thread, fun.aggregate = length)
user_thread_matrix <- ifelse(user_thread_matrix>0, 1,0)
cooccur <- user_thread_matrix%*%t(user_thread_matrix)
cooccur <- ifelse(cooccur>0, 1,0)
image(cooccur)
title(paste("density:", mean(cooccur)*100))

# Co-participations of active users
user_thread_matrix <- user_thread_matrix[df.users$cluster!=0,]
cooccur.active <- user_thread_matrix%*%t(user_thread_matrix)
cooccur.active <- ifelse(cooccur.active>0, 1,0)
image(cooccur.active)
title(paste("density:", mean(cooccur.active)*100))

heatmap(cooccur.active,
        Colv=NA, Rowv=NA, labRow=NA)

# Graph
#############################################################
par(mfrow=c(1,1))
g <- graph.adjacency(cooccur, mode = "undirected", diag = FALSE)
V(g)$cluster <- df.users$cluster # add clusters to colors users
g <- delete.vertices(g, "root") # remove root since this is an artificial user

# Remove micro-components (probably threads that have just started at the end of January)
memberships <- components(g)$membership
g <- induced_subgraph(g, memberships==1)
# remove non-active users (those that have no role)
g <- induced_subgraph(g, V(g)$cluster!=0)

# Save to file for Gephi
fname <- paste0('forum', '.edges')
write_graph(g, fname, format = c("edgelist"))

# Plot graph, only for active users
degrees <- degree(g)
q_degree <- quantile(degrees, 0.5)
V(g)$label <- V(g)$name
#V(g)$label[degree(g)<800] = ""
la <- layout_with_fr(g)
la <- layout_with_lgl(g)
memberships.eigen <- cluster_leading_eigen(g)$membership
table(memberships.eigen)

sizes <- ifelse(degree(g)>100, 1+0.5*tanh(degrees-q_degree), 0)
colors <- cluster.colors[V(g)$cluster]
plot(g,
     layout = la,
     vertex.color = memberships.eigen,
     #vertex.color = colors,
     vertex.size = 1,
     vertex.label.cex = 0.8,
     edge.width = 0.2,
     edge.arrow.size=0.02,
     asp=9/16,
     margin=-0.15)

# TODO: graph of who replied to who. That would be more conversation-based and more related to the current analysis
df.edges <- select(df.posts, postid, parent, date)
df.vertices <- select(df.posts, postid, user, date)
df.edges <- filter(df.edges, parent%in%df.vertices$postid) # only edges with known vertices

df.edges <- merge(df.edges, df.vertices, by='postid') %>%
  merge(df.vertices, by.x='parent', by.y='postid') %>%
  select(-parent, -postid, -date, -date.y)
names(df.edges) <- c('date', 'from', 'to')


library(zoo)
library("ggplot2")
library(gridExtra)
library(grid)
library(qdapTools)

setwd("C:/Code/climData/glaser2019")

spiFull <- read.csv("https://raw.githubusercontent.com/climdata/dwdSPI/master/csv/spi_de.csv", sep=",", na = "NA")
spiCal <- subset(spifull, spiFull$year>1880 & spiFull$year<1995)

hiFull <- read.csv("csv/spi_1500_2019.csv", sep=",", na = "NA")
hiFull <- subset(hiFull, hiFull$year>1499)

spiCal$di1 <- spiCal$spi1
spiCal$di2 <- spiCal$spi2
spiCal$di3 <- spiCal$spi3
spiCal$di4 <- spiCal$spi4
spiCal$di5 <- spiCal$spi5

spiCal$di <- spiCal$spi12

for(i in 1:nrow(spiCal)) {
  spiCal$di1[i] <- max(-1.0,min(spiCal$spi1[i], spiCal$spi2[i], 0.0, na.rm = TRUE))

  spiCal$di2[i] <- max(-1.5,min(spiCal$spi1[i], spiCal$spi2[i], 1.0, na.rm = TRUE))
  if (spiCal$di2[i]>-1.0) {spiCal$di2[i] = 0.0}

  spiCal$di3[i] <- max(-2.0,min(spiCal$spi2[i], spiCal$spi3[i], spiCal$spi4[i], 1.0, na.rm = TRUE))
  if (spiCal$di3[i]>-1.5) {spiCal$di3[i] = 0.0}

  spiCal$di4[i] <- max(-3.0,min(spiCal$spi4[i], spiCal$spi5[i], spiCal$spi6[i],spiCal$spi7[i], spiCal$spi8[i], spiCal$spi9[i],spiCal$spi10[i], 1.0, na.rm = TRUE))
  if (spiCal$di4[i]>-2.0) {spiCal$di4[i] = 0.0}

  spiCal$di5[i] <- max(-4.0,min(spiCal$spi10[i], spiCal$spi11[i], spiCal$spi12[i], 1.0, na.rm = TRUE))
  if (spiCal$di5[i]>-3.0) {spiCal$di5[i] = 0.0}

  spiCal$di[i] <- min(spiCal$di1[i],spiCal$di2[i],spiCal$di3[i],spiCal$di4[i],spiCal$di5[i], 0.0, na.rm = TRUE)
  }

## HDI

hiFull$di1 <- hiFull$spi1
hiFull$di2 <- hiFull$spi2
hiFull$di3 <- hiFull$spi3
hiFull$di4 <- hiFull$spi4
hiFull$di5 <- hiFull$spi5

hiFull$di <- hiFull$spi12

for(i in 1:nrow(hiFull)) {
  hiFull$di1[i] <- max(-1.0,min(hiFull$spi1[i], hiFull$spi2[i], 0.0, na.rm = TRUE))

  hiFull$di2[i] <- max(-1.5,min(hiFull$spi1[i], hiFull$spi2[i], 1.0, na.rm = TRUE))
  if (hiFull$di2[i]>-1.0) {hiFull$di2[i] = 0.0}

  hiFull$di3[i] <- max(-2.0,min(hiFull$spi2[i], hiFull$spi3[i], hiFull$spi4[i], 1.0, na.rm = TRUE))
  if (hiFull$di3[i]>-1.5) {hiFull$di3[i] = 0.0}

  hiFull$di4[i] <- max(-3.0,min(hiFull$spi4[i], hiFull$spi5[i], hiFull$spi6[i],hiFull$spi7[i], hiFull$spi8[i], hiFull$spi9[i],hiFull$spi10[i], 1.0, na.rm = TRUE))
  if (hiFull$di4[i]>-2.0) {hiFull$di4[i] = 0.0}

  hiFull$di5[i] <- max(-4.0,min(hiFull$spi10[i], hiFull$spi11[i], hiFull$spi12[i], 1.0, na.rm = TRUE))
  if (hiFull$di5[i]>-3.0) {hiFull$di5[i] = 0.0}

  hiFull$di[i] <- min(hiFull$di1[i],hiFull$di2[i],hiFull$di3[i],hiFull$di4[i],hiFull$di5[i], 0.0, na.rm = TRUE)
}

hiCal <-  subset(hiFull, hiFull$year>1880 & hiFull$year<1995)

df <- data.frame(y = hiCal[,di], x = spiCal[,di])
df <- subset(df, !is.na(df$x))
mx <- lm(y ~ x, df);
eq <- substitute(italic(r)^2~"="~r2,
                 list(r2 = format(summary(mx)$r.squared, digits = 3)))
eq <- as.character(as.expression(eq))

mp1 <- ggplot() +
  theme_classic(base_size=80) +
  #coord_cartesian(ylim=c(-4,4)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-4,4)) +
  labs(x="Year", y="DI", title="", subtitle="") +
  geom_hline(aes(yintercept=0)) +
  geom_line(aes(y=-spiCal$di, x=spiCal$time, color="MDI"), size=2) +
  geom_line(aes(y=hiCal$di, x=hiCal$time, color="HDI"), size=2) +
  annotate('text', x = 1990, y = 3.0, label = eq, parse = TRUE, size=20) +
  scale_color_manual(
    name = "",
    labels = c("MDI+", "HDI-"),
    breaks  = c("MDI", "HDI"),
    values = c("MDI"="#33ccff", "HDI"="#ff9933", "black"="#000000")
  ) +
  theme( legend.key.width = unit(2,"cm"))
mp1

## HWI

hiFull$wi1 <- hiFull$spi1
hiFull$wi2 <- hiFull$spi2
hiFull$wi3 <- hiFull$spi3
hiFull$wi4 <- hiFull$spi4
hiFull$wi5 <- hiFull$spi5

hiFull$wi <- hiFull$spi12
hiFull$hi <- hiFull$spi12  ## Humidity Index => Difference
hiFull$xi <- hiFull$spi12  ## Extreme Index  => Larger Amplitude

for(i in 1:nrow(hiFull)) {
  hiFull$wi1[i] <- min(1.0,max(hiFull$spi1[i], hiFull$spi2[i], 0.0, na.rm = TRUE))

  hiFull$wi2[i] <- min(1.5,max(hiFull$spi1[i], hiFull$spi2[i], -1.0, na.rm = TRUE))
  if (hiFull$wi2[i]<1.0) {hiFull$wi2[i] = 0.0}

  hiFull$wi3[i] <- min(2.0,max(hiFull$spi2[i], hiFull$spi3[i], hiFull$spi4[i], -1.0, na.rm = TRUE))
  if (hiFull$wi3[i]<1.5) {hiFull$wi3[i] = 0.0}

  hiFull$wi4[i] <- min(3.0,max(hiFull$spi4[i], hiFull$spi5[i], hiFull$spi6[i],hiFull$spi7[i], hiFull$spi8[i], hiFull$spi9[i],hiFull$spi10[i], -1.0, na.rm = TRUE))
  if (hiFull$wi4[i]<2.0) {hiFull$wi4[i] = 0.0}

  hiFull$wi5[i] <- min(4.0,max(hiFull$spi10[i], hiFull$spi11[i], hiFull$spi12[i], -1.0, na.rm = TRUE))
  if (hiFull$wi5[i]<3.0) {hiFull$wi5[i] = 0.0}

  hiFull$wi[i] <- max(hiFull$wi1[i],hiFull$wi2[i],hiFull$wi3[i],hiFull$wi4[i],hiFull$wi5[i], 0.0, na.rm = TRUE)
  hiFull$hi[i] <- hiFull$wi[i] + hiFull$di[i]
  if (hiFull$hi[i] < 0) {
    hiFull$xi[i] <- hiFull$di[i]
  } else {
    hiFull$xi[i] <- hiFull$wi[i]
  }

}

mp2 <- ggplot() +
  theme_classic(base_size=80) +
  #coord_cartesian(ylim=c(-4,4)) +
  scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3), limits=c(-4,4)) +
  labs(x="Year", y="HDI       HWI", title="", subtitle="") +
  geom_hline(aes(yintercept=0)) +
  geom_line(aes(y=hiFull$wi5, x=hiFull$time, color="a:HWI05"), size=1) +
  geom_line(aes(y=hiFull$wi4, x=hiFull$time, color="b:HWI04"), size=1.5) +
  geom_line(aes(y=hiFull$wi3, x=hiFull$time, color="c:HWI03"), size=2) +
  geom_line(aes(y=hiFull$wi2, x=hiFull$time, color="d:HWI02"), size=2.5) +
  geom_line(aes(y=hiFull$wi1, x=hiFull$time, color="e:HWI01"), size=3) +
  geom_line(aes(y=hiFull$di5, x=hiFull$time, color="j:HDI05"), size=1) +
  geom_line(aes(y=hiFull$di4, x=hiFull$time, color="i:HDI04"), size=1.5) +
  geom_line(aes(y=hiFull$di3, x=hiFull$time, color="h:HDI03"), size=2) +
  geom_line(aes(y=hiFull$di2, x=hiFull$time, color="g:HDI02"), size=2.5) +
  geom_line(aes(y=hiFull$di1, x=hiFull$time, color="f:HDI01"), size=3) +
  scale_color_manual(
    name = "",
    labels = c("HWI5", "HWI4", "HWI3", "HWI2", "HWI1",
               "HDI1", "HDI2", "HDI3", "HDI4", "HDI5"),
    breaks  = c("a:HWI05", "b:HWI04", "c:HWI03", "d:HWI02", "e:HWI01",
                "f:HDI01", "g:HDI02", "h:HDI03", "i:HDI04", "j:HDI05"),
    values = c("a:HWI05"="#005500",
               "b:HWI04"="#009933",
               "c:HWI03"="#00ff00",
               "d:HWI02"="#66ff99",
               "e:HWI01"="#99ff99",
               "f:HDI01"="#ffffcc",
               "g:HDI02"="#ffff11",
               "h:HDI03"="#ff9900",
               "i:HDI04"="#ff0000",
               "j:HDI05"="#990000"
               )
  ) +
  theme( legend.key.width = unit(2,"cm"))
mp2

custom.col <- c("#CC0000", "#FF0000", "#FF6600", "#FFFF00", "#FFEEBB",
                "#FFFFFF",
                "#CCFFCC", "#99EE99", "#00cc00", "#339933", "#004400")

custom.col2 <- c("#CC0000", "#FF0000", "#FF6600", "#FFFF00", "#FFEEBB", "#FFFFFF")

custom.col3 <- c("#FFFFFF", "#CCFFCC", "#99EE99", "#00cc00", "#339933", "#004400")

mp <- ggplot(hiFull, aes(year, month))

mp + geom_raster(aes(fill=hi))+
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_fill_gradientn(colours=custom.col) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="HHI", reverse = TRUE))

mp + geom_raster(aes(fill=xi))+
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_fill_gradientn(colours=custom.col) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="HHI", reverse = TRUE))

mp + geom_raster(aes(fill=di))+
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_fill_gradientn(colours=custom.col2) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="HDI", reverse = TRUE))

mp + geom_raster(aes(fill=wi))+
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_fill_gradientn(colours=custom.col3) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="HWI", reverse = TRUE))

hhi <- hiFull[,c('year','month','time', 'di', 'wi', 'hi', 'xi')]
names(hhi)[names(hhi) == 'di'] <- 'hdi'
hhi$hdi <- round(hhi$hdi, digits=6)
names(hhi)[names(hhi) == 'wi'] <- 'hwi'
hhi$hwi <- round(hhi$hwi, digits=6)
names(hhi)[names(hhi) == 'hi'] <- 'hhi'
hhi$hhi <- round(hhi$hhi, digits=6)
names(hhi)[names(hhi) == 'xi'] <- 'hxi'
hhi$hxi <- round(hhi$hxi, digits=6)

write.table(hhi, file = "csv/hhi_1500_2019.csv", append = FALSE, quote = TRUE, sep = ",",
            eol = "\n", na = "NA", dec = ".", row.names = FALSE,
            col.names = TRUE, qmethod = "escape", fileEncoding = "UTF-8")


library(zoo)

# Calculating the rolling average. Window is set to 3 here, corresponding to an average of the current row and the 2 preceding rows
window <- 10
padding <- rep(NA, window - 1)
df$rollingavg <- c(padding, rollmean(df$number_users, k = window))

periscope.table(df)


# http://factominer.free.fr/classical-methods/analyse-en-composantes-principales.html
library(readr)
library(FactoMineR)

nclusters = 80

csv = readr::read_csv('output.csv')

# long !
res.pca = PCA(csv[,-1], scale.unit = T, ncp = 5, graph = F)

k = kmeans(res.pca$ind$coord, nclusters, iter.max = 20)

features = colnames(csv)

is.nonzero = function(x) { x != 0 }

if(!dir.exists(paste("clusters", nclusters, sep="")))
{
  dir.create(paste("clusters", nclusters, sep=""))
}

for(cluster in 1:nclusters)
{
  sub = Filter(is.numeric, csv[k$cluster == cluster,])
  if(dim(sub)[1] > 1)
  {
    # Enlever cette ligne pour garder le nombre d'occurence d'origine
    sub = sapply(sub, is.nonzero)
    sub = colSums(sub)

    size = dim(csv[k$cluster == cluster,])[1]
    quality = max(sub) / size
  }
  else
  {
    size = 1
    quality = 1
  }

  # feature most representative
  name = features[which.max(sub) + 1] # +1 : décalage d'indice ?

  #file=paste("clusters", nclusters, "/", cluster, "_", quality, sep = "")
  file=paste("clusters", nclusters, "/", cluster, sep = "")
  header = data.frame(cluster, quality, size, name)

  write.table(header, file = file, row.names = F)
  write.table(csv[k$cluster == cluster, 1], file = file, col.names = F, row.names = F, quote = F, append = T)

  print(header)
}


BNP_DIR = "/Users/jtobin/projects/bnp"
SBP_SRC = paste(BNP_DIR, "stick-breaking-process/src/sbp.r", sep = "/")

require(gtools)
require(magrittr)
source(SBP_SRC)

mixing_model = function(n, a) {
  if (n <= 1) {
    stop("need > 1 observation.")
    } else {
    sbp(n - 1, a)
    }
  }

label_model     = function(n, p) drop(rmultinom(1, size = n, prob = p))
location_model  = function(k, l, r) rnorm(k, l, 1 / r)
precision_model = function(k, b, w) rgamma(k, b, 1 / w)

parameter_model = function(n, a) {
  p  = mixing_model(n, a)
  k  = length(p)
  c  = label_model(n, p)
  mu = location_model(k, 0, 0.1)
  s  = precision_model(k, 1, 1)
  list(c, mu, s)
  }

data_model = function(config) {
  sampler = function(y, m, s) rnorm(y, m, 1 / s)
  mapply(sampler, config[[1]], config[[2]], config[[3]])
  }

model = function(n, a) {
  clusters = parameter_model(n, a) %>% data_model
  nonempty = unlist(lapply(clusters, function(x) length(x) != 0))
  clusters[nonempty]
  }


source("calculate/norms.r")
source("calculate/distance.r")

# Return a data.frame suitable for rendering in a one-one distance comparison
distance_table_for_word_pairs <- function(left_words, right_words, distance_type) {
  # Validate
  if (length(left_words) != length(right_words)) { stop('Pairs not matched') }

  if (length(left_words) == 0) {
    return (NULL)
  }

  table_data <- data.frame(
    W1 = left_words,
    W2 = right_words
  )
  names(table_data) <- c("Word 1", "Word 2")

  matrix_left <- matrix_for_words(left_words)
  matrix_right <- matrix_for_words(right_words)

  distances = distance_matrix(matrix_left, matrix_right, distance_type)

  table_data[, distance_col_name(distance_type)] = diag(distances)

  return(table_data)
}

# Return a data.frame suitable for rendering in a one-many distance comparison
distance_table_for_one_many <- function(left_word, right_words, distance_type) {
  left_words <- rep(left_word, length(right_words))
  return(distance_table_for_word_pairs(left_words, right_words, distance_type))
}

# Return a data.frame suitable for rendering in a many-many distance comparison
# as a matrix
distance_matrix_for_word_pairs <- function(left_words, right_words, distance_type, max_words = Inf) {

  if (length(left_words)  == 0) { return (NULL) }
  if (length(right_words) == 0) { return (NULL) }
  if (length(left_words) > max_words) { left_words = left_words[1:max_words] }
  if (length(right_words) > max_words) { right_words = right_words[1:max_words] }

  matrix_left <- matrix_for_words(left_words)
  matrix_right <- matrix_for_words(right_words)

  distances = distance_matrix(matrix_left, matrix_right, distance_type)

  table_data = data.frame(distances, row.names=left_words)
  names(table_data) <- right_words

  return(table_data)
}

# Given a distance matrix with row/column names, returns a data.frame with
# columns `Word 1`, `Word 2`, `distance`
distance_list_from_matrix <- function(distance_matrix, distance_type) {
  # Convert row names to first column
  left_words = rownames(distance_matrix)
  rownames(distance_matrix) = NULL
  distance_matrix <- cbind(left_words, distance_matrix)
  list_table <- distance_matrix %>% pivot_longer(!left_words, names_to = "Word 2", values_to = "distance")
  names(list_table) <- c("Word 1", "Word 2", distance_col_name(distance_type))
  return(list_table)
}


#
# Here we test the functions in hrstuff_01.r
#

#install.packages("rgl")
#install.packages("pracma")

library(rgl)
library(pracma)

#C:\Users\lithomas\
source("hrstuff_01.r")

#
# TESTS
#
G1 = rbind(diag(1,3),-diag(1,3))
h1 = rbind(1,2,3,4,5,6);

X1 = cbind(c(0.5,0.5,0.5),c(0.7,0.7,0.7))
V1 = cbind(c(1,1,1),c(1,1,1.5))

xx1 <- intersectLineWithPlanes(G1,h1,X1,V1)

xx1[2]

hrx1 = hrstep_unif(G1,h1,X1)

hrx2 = hr_unif(G1,h1,X1,c(5))
hrx3 = hr_unif(G1,h1,X1,1:500)

hrx3_j = Reduce(cbind,hrx3)

plot3d(hrx3_j[1,],hrx3_j[2,],hrx3_j[3,])

#
# TEstS NOn-Unif:
#

G2 = rbind(diag(1,2),-diag(1,2))
h2 = rbind(1,2,3,4);

fa = function(x) { return( dnorm(x[1])*dnorm(x[2]) ) }

x2_a = hrstep_01( G2,h2,fa, cbind(c(0.1,0.1),c(0.2,0.2)) ,40)

hrgx_a = hr(G2,h2,fa,cbind(c(0.1,0.1),c(0.2,0.2)),200,40)


#------------------------------------------------------------------------------------------------------------------
#Step PRE: Some functions that is used later on in the mod.jointly.generate.binary.normal function algorithm
#and so on

#         Function1: closest element
#         returns whichever element of candidates vector is closest in abs value to x

closest = function(x, candidates) {
    return( candidates[ which.min( abs(candidates - x) ) ] )
}

#        Function2: binary-normal correlation bound ######
#        given parameters for 1 binary and 1 normal RV, return the maximum correlation

BN.rBound = function(p) {
    q = 1-p

    #compute upper bound
    hiBound = dnorm( qnorm(p) ) / sqrt(p*q)
    return( round(hiBound, 2) )
}

#       Function3: expand a matrix of slot_0 to the number of specified stages for time_invariant covariate setting
#       repeat each subject's entry in each row for obs number of times
expand_matrix = function(.matrix, .n.stage) {
    library(plyr)
    cat("Expanding a time invariant covariates to the number of specified stages\n")

    .n = nrow(.matrix)
    .expanded = matrix(c(NA), nrow = .n*.n.stage, ncol = ncol(.matrix) )

    adply(.matrix, 1, function(..subject, ..obs) {
        matrix(rep(..subject, ..obs), nrow = ..obs, byrow = TRUE)
    }, .n.stage)

}

#      FUNCTION4: UPPER TRI VEC:
#      turns matrix into vector of upper-triangular elements

upper_tri_vec = function(m) {
    v1 = as.vector( t(m) )
    keepElement = as.vector( t(upper.tri(m) ) ) #use transpose to avoid going by columns
    v2 = as.numeric( v1[keepElement] )
    return(v2)
}
#------------------------------------------------------------------------------------------------------------------
#Step 1: Creating the "Across" data

mod.generate.jointly.binary=function(no.rows,no.binary,prop.vec.binary,corr.vec.binary, adjust.corrs = TRUE){
    #Definition of the arguments are as follows:
    #no.rows=Number of subjects
    #no.bin=Number of binary variables (among these )
    #no.nor=Number of normally distributed variables
    #prop.vec.binary=Vector of marginal proportions for binary variables
    #mean.vec.nor=Vector of means for normal variables
    #var.nor=Vector of variances for normal variables
    #corr.vec.binary=Specified correlations among all variables
    #b=2*no.bin #b is double number of the total binary vars
    d=no.binary #d is the total dimension
    #adjust.corrs=T/F. If a correlation is out of bounds, should it
    # be adjusted to the closest feasible values?

    ############################################################
    #Important note 1: For convenience, binary variables are assumed
    #to come first, then normal variables follow
    #Important note 2: Correlations are specified in vector form,
    #rather than a matrix form. If the dimension is d, d*(d-1)/2
    #non-redundant correlation terms must be specified. The order
    #in which correlations are specified is based on the upper diagonal
    #elements. For example, if there are four variables (X1,X2,X3,X4),
    #corr.vec.binary is specified in the following form:
    #c(Corr(X1,X2),Corr(X1,X3),Corr(X1,X4),Corr(X2,X3),Corr(X2,X4),
    #Corr(X3,X4))
    #------------------------------------------------------------------------------------------------------------------
    #Step 1-1 Series of control statements to prevent obvious ARGUMENT
    #SPECIFICATION ERRORS:

    if ((no.rows<1)|(floor(no.rows)!=no.rows)){stop("Number of rows must be
                                                    an integer whose value is at least 1!\n")}
    if ((no.binary<1)|(floor(no.binary)!=no.binary)){stop("Number of binary variables
                                                 must be an integer whose value is at least 1!\n")}

    if ((min(prop.vec.binary)<=0)|(max(prop.vec.binary)>=1)){
        stop("Proportions for binary variables must be between 0 and 1!\n")}
    if (length(prop.vec.binary)!=no.binary){stop("Proportion vector
                                           is misspecified, dimension is wrong!\n")}

    if(length(corr.vec.binary)!=(d*(d-1)/2)){
        stop("Vector of correlations is misspecified, dimension is wrong!\n")}

    #------------------------------------------------------------------------------------------------------------------
    #Step 1-2:   Statements to check CORRELATION BOUND VIOLATIONS

    #Step 1-2-1: Form a correlation matrix from the specified correlation vector
    # this is equivalent to lower.tri.to.corr.mat function from BinNor package
    # that Converts a lower vector to a full correlation matrix
    sigma=diag(d)
    temp=1
    for(i in 1:(d-1)){
        for(j in (i+1):d){
            sigma[i,j]=sigma[j,i]=corr.vec.binary[temp]
            temp=temp+1
        }
    }
    #------------------------------------------------------------------------------------------------------------------

    #Step 1-2-1: Check if the specified correlation matrix is positive definite, if not
    #find the nearest positive definite matrix
    #This is equivalent to the function: compute.sigma.star from BinNor package that
    #Computes intermediate (tetrachoric) correlation matrix

    if(is.positive.definite(sigma)==FALSE)
    {sigma=make.positive.definite(sigma)
    print("Specified correlation matrix is not positive definite,")
    print("Algorithm will be using the closest positive definite matrix!")}

    diag(sigma)=1

    p=prop.vec.binary
    q=1-p
    #------------------------------------------------------------------------------------------------------------------

    #Step 1-2-2: Checks if the correlation terms are within the feasible range
    #This is equivalent to the function: validation.range from BinNor package that
    #Checks if the correlation terms among binary-binary, binary-normal
    #and normal-normal combinations.are within the feasible range

    #Check if the correlations for binary-binary combinations are
    #in the feasible range

    #Boundaries for BB =[max(-sqrt((pi*pj)/(qi*qj)),-sqrt((qi*qj)/(pi*pj))),
    #min(sqrt((pi*qj)/(qi*pj)),sqrt((qi*pj)/(pi*qj)))]
    L_BB=diag(no.binary)
    U_BB=diag(no.binary)

    for(i in 1:no.binary){
        for(j in 1:no.binary){
            if (i!=j) L_BB[i,j]=L_BB[j,i]=max(-sqrt((p[i]*p[j])/(q[i]*q[j])),
                                              -sqrt((q[i]*q[j])/(p[i]*p[j])))
            if (i!=j) U_BB[i,j]=U_BB[j,i]=min(sqrt((p[i]*q[j])/(q[i]*p[j])),
                                              sqrt((q[i]*p[j])/(p[i]*q[j])))
        }
    }

    for(i in 1:no.binary){
        for(j in 1:no.binary){
            if(sigma[i,j]<L_BB[i,j] | sigma[i,j]>U_BB[i,j]) {
                if (!adjust.corrs) {
                    # if user does not want to adjust correlations, give error
                    stop("BB corrrelation [", i,",",j,"] is out of range! Specify a feasible number!")
                } else {
                    #adjust correlation to the closest feasible value
                    cat( c("BB corrrelation [", i,",",j,"],", sigma[i,j], ", is out of range! Used closest feasible correlation instead\n"))
                    sigma[i,j] = sigma[j,i] = closest(sigma[i,j], c( L_BB[i,j], U_BB[i,j] ) )
                }
            }
        }
    }

    #Compute the biserial correlations for binary-normal combinations and
    #check if they are in the feasible range

    #temporary matrix
    #BN_temp=sigma

    # replace the BN values in BN_temp with the corresponding phi values correlation btw binary and normal
    #for(i in (no.binary+1):d){
        #for(j in 1:no.binary){
            #BN_temp[i,j]=BN_temp[i,j]/(dnorm(qnorm(p[j]))/sqrt(p[j]*q[j]))
        #}
    #}

    #for(i in (no.binary+1):d){
        #for(j in 1:no.binary){
            #if (BN_temp[i,j]< -1 | BN_temp[i,j]> 1) {

                #if (!adjust.corrs) {q
                    # if user does not want to adjust correlations, give error
                    #stop("BN correlation [", i,",",j,"] is out of range! Specify a feasible number!")
                #} else {
                    #adjust correlation to the closest feasible value
                    #BN_temp[i,j] = closest(BN_temp[i,j], c(-1, 1))

                #}
           # }
        #}
   # }

    #keep the BN part of BN_temp matrix
    #BN=BN_temp[(no.binary+1):d,1:no.binary]

    #Compute the tetrachoric correlations for binary-binary combinations

    # create sigmaBB matrix by converting BB part of sigma into polychoric correlations
    sigmaBB=diag(no.binary)
    for(i in 1:no.binary){
        for(j in 1:no.binary){
            if (i > j) {
                sigmaBB[i,j] = sigmaBB[j,i] = phi2poly( sigma[i,j] ,p[i],p[j])
                #force symmetry because phi2poly is an imperfect optimization process with rounding error
            }
            #########################################################################
            ###### NOTE: ABOVE ROUNDING OF SIGMA ENTRY IS A LITTLE SKETCH!!!!! ######
            #########################################################################

        }
    }

    #Biserial correlations for binary-normal combinations
    #sigmaBN=BN

    #Combine all three types (binary-binary, binary-normal, normal-normal)
    #of correlations to construct the overall correlation matrix
    #(Step 7 in the algorithm)
    sigma_new=sigma
    sigma_new[1:no.binary,1:no.binary]=sigmaBB
    #sigma_new[(no.binary+1):d,1:no.binary]=sigmaBN
    #sigma_new[1:no.binary,(no.binary+1):d]=t(sigmaBN)

    #Check if the final correlation matrix is positive definite, if not
    #find the nearest positive definite matrix (Step 8 in the algorithm)

    if(is.positive.definite(sigma_new)==FALSE) {
        sigma_new=make.positive.definite(sigma_new)
        print("Final correlation matrix is not positive definite,")
        print("Algorithm will be using the closest positive definite matrix!")
    }
    #------------------------------------------------------------------------------------------------------------------

    #Step 1-3: Generate multivariate normal data (Step 9 in the algorithm)
    data=rmvnorm(no.rows,mean=rep(0,d), sigma=sigma_new)

    #------------------------------------------------------------------------------------------------------------------
    #
    ##
    ###
    ####
    ##### shouldn't be abs(data[i,j])<=qnorm(1-p[j])) ???? check BinNOR
    #Step 1-3-1: Obtain binary variables by the thresholds determined by marginal proportions

    for(i in 1:no.rows){
        for(j in 1:no.binary){
            if(data[i,j]<=qnorm(1-p[j])) data[i,j]=0 else data[i,j]=1
        }
    }

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

    #------------------------------------------------------------------------------------------------------------------
    #Step 1-3-3:    Go back to the original scale for normal variables by reverse centering and

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

    #step 1-4: Output is the data matrix!
    diag(sigma_new)=1
    return(list(data,sigma_new))
    #return(data)
    }


#' Boolean functions
#' @description Return TRUE or FALSE for a lazy stream
#' @name lboolean
#' @param x a lazy stream object
#' @param f a predicate function
#'
#' @examples
#' x <- 1%..%10
#' lall(x, function(x) x <= 10)
#' lany(x, function(x) x%%7==0)
#'
NULL

#' @rdname lboolean
#' @export
lall <- function(x, f) {
  if (lnull(x)) TRUE
  else f(lhead(x)) && lall(ltail(x), f)
}

#' @rdname lboolean
#' @export
lany <- function(x, f) {
  if (lnull(x)) FALSE
  else f(lhead(x)) || lany(ltail(x), f)
}

## and :: [Bool] -> Bool
#' @rdname lboolean
#' @export
land <- function(x) {
  if (lnull(x)) TRUE
  else isTRUE(lhead(x)) && land(ltail(x))
}

## or :: [Bool] -> Bool
#' @rdname lboolean
#' @export
lor <- function(x) {
  if (lnull(x)) FALSE
  else isTRUE(lhead(x)) || lor(ltail(x))
}

lsum <- function(x) {
  lfoldl(x, `+`, 0)
}

lproduct <- function(x) {
  lfoldl(x, `*`, 0)
}

lmaximum <- function(x, acc) {
  if (lnull(x)) stop("empty llist")
  else lfoldl1(x, max)
}

lminmum <- function(x) {
  if (lnull(x)) stop("empty llist")
  else lfoldl1(x, min)
}


context("itabulate iterator")

test_that("itabulate functions properly with default values", {
  it <- itabulate(f=function(x) x + 1)
  expect_equal(take(it, 4), as.list(2:5))
})

test_that("itabulate functions properly with a given start value", {
  it <- itabulate(f=function(x) x^2, start=-3)
  expect_equal(take(it, 6), list(9, 4, 1, 0, 1, 4))
})

test_that("itabulate functions properly with given start and step values", {
  it <- itabulate(abs, start=-5, step=2)
  expect_equal(take(it, 6), list(5, 3, 1, 1, 3, 5))
})

test_that("itabulate functions properly with a decreasing sequence", {
  it <- itabulate(exp, start=6, step=-2)
  expect_equal(take(it, 4), as.list(exp(seq(6, 0, by=-2))))
})


#set work directory to rouce file pane

suppressPackageStartupMessages
rm(list = ls())

require("reshape2")
require("plyr")
require("ggplot2")
library("ggrepel")
library("scales")
library("data.table")
library("stringr")

saveplot <- function(plotname)
{
  ggsave(filename=paste("../output/", as.character(gsub(" ", "_", plotname)),".eps", sep=""), plot = last_plot(), width=7, height=5)
  ggsave(filename=paste("../output/", as.character(gsub(" ", "_", plotname)),".pdf", sep=""), plot = last_plot(), width=7, height=5)
}

Gini <- function (x, weights = rep(1, length = length(x)))
{
  ox <- order(x)
  x <- x[ox]
  weights <- weights[ox]/sum(weights)
  p <- cumsum(weights)
  nu <- cumsum(weights * x)
  n <- length(nu)
  nu <- nu/nu[n]
  round(sum(nu[-1] * p[-n]) - sum(nu[-n] * p[-1]), 4)
}
Atkinson <- function (x, weights = rep(1, length = length(x)), gamma=0.7)
{
  pop_share <- weights / sum(weights)
  if(gamma==1){
    round((1 - (exp(sum(pop_share * log(x))) / sum(pop_share * x))), 4)
  }else{
    round((1 - (sum(pop_share * x^(1-gamma))^(1/(1-gamma)) / sum(pop_share * x))), 4)
  }
}

#historical WDI data: GDP per capita, PPP (constant 2011 international $)
pop = read.xlsx("../data/SSP_v9_clean.xlsx", sheet = "POP_WDI_2015", startRow = 1, colNames = TRUE, skipEmptyRows = TRUE, rowNames = FALSE)
cpc = read.xlsx("../data/SSP_v9_clean.xlsx", sheet = "GDP_pc_WDI_2015", startRow = 1, colNames = TRUE, skipEmptyRows = TRUE, rowNames = FALSE)
year = seq(1990,2014,1)
pop <- pop[complete.cases(cpc),(c(-1))]
cpc <- cpc[complete.cases(cpc),(c(-1))]
gamma = 0.7
I_global_hist = data.frame(year)
I_global_hist$I_global=0
for (i in 1:25) {
  I_global_hist$I_global[i] <- Atkinson(cpc[,i],pop[,i])
  I_global_hist$I_global_one[i] <- Atkinson(cpc[,i],pop[,i], 1)
  I_global_hist$Gini[i] <- Gini(cpc[,i],pop[,i])
}
colnames(I_global_hist) <- c("year", "I(0.7)", "I(1.0)", "Gini")
I_global_hist <- melt(I_global_hist, id="year")

# Model run data
#years of both models: 2015-2300
year = as.data.frame(seq(2015,2299,1))
colnames(year) <- "year"

gamma = 0.7

models = c("RICE", "FUND", "SSP")

for(m in models){
s2 <- read.csv(paste("../output/", m, "_sigmasquared.csv", sep=""), fill = TRUE, header=FALSE)
cpc <- data.frame(read.csv(paste("../output/", m, "_cpc.csv", sep=""), fill = TRUE, header=FALSE))
pop <- data.frame(read.csv(paste("../output/", m, "_pop.csv", sep=""), fill = TRUE, header=FALSE))

I_within_regions = round(1 - exp(-0.5*gamma*s2), 4)

pop_share = pop / rowSums(pop)
I_between_regions = as.data.frame(round((1 - (rowSums(pop_share * cpc^(1-gamma))^(1/(1-gamma)) / rowSums(pop_share * cpc))), 4))
colnames(I_between_regions) <- "I_between_regions"
I_global = as.data.frame(round((1 - (rowSums(pop_share * (cpc*(1-I_within_regions))^(1-gamma))^(1/(1-gamma)) / rowSums(pop_share * cpc))), 4))
colnames(I_global) <- "I_global"
I_within_weighted = as.data.frame(round(rowSums(pop_share * I_within_regions), 4))
I_global_minus_between = I_global - I_between_regions

#full data set
Atkinson <- year
Atkinson$I_global <- I_global$I_global
Atkinson$I_between_regions <- I_between_regions$I_between_regions
Atkinson$model <- m

if(m==models[1]){Atkinson_all_models=Atkinson}else{Atkinson_all_models <-rbind(Atkinson_all_models,Atkinson)}

#CPC
CPC_global_computed = as.data.frame(round(rowSums(pop_share * cpc), 4))
#full data set
CPC_global <- year
CPC_global$CPC_global <- CPC_global_computed[,1]
CPC_global$model <- m

if(m==models[1]){CPC_global_all_models=CPC_global}else{CPC_global_all_models <-rbind(CPC_global_all_models,CPC_global)}

}
#add CPC and EDE
Atkinson_all_models <- merge(Atkinson_all_models, CPC_global_all_models, by=c("year", "model"))
Atkinson_all_models$EDE = Atkinson_all_models$CPC_global * (1-Atkinson_all_models$I_global)

Atkinson_all_models <- melt(Atkinson_all_models,id=c("year", "model"))
#only each five years
Atkinson_all_models <- subset(Atkinson_all_models, (Atkinson_all_models$year %% 10) == 0)
#remove SSP after 2100
Atkinson_all_models <- subset(Atkinson_all_models, (!(Atkinson_all_models$model=="SSP" & Atkinson_all_models$year > 2100)))

#rename some variable names #####change MER to PPP if PPP is used
Atkinson_all_models$model = gsub("SSP", "SSP2", Atkinson_all_models$model)
Atkinson_all_models$variable = gsub("I_global", "country inequality", Atkinson_all_models$variable)
Atkinson_all_models$variable = gsub("I_between_regions", "regional inequality", Atkinson_all_models$variable)
Atkinson_all_models$variable = gsub("CPC_global", "Per-capita Consumption", Atkinson_all_models$variable)
#Until when to plot the graphs?
Atkinson_all_models <- subset(Atkinson_all_models, (Atkinson_all_models$year <= 2100))

###################### PLOTS ######################

#Plot of inequality indices comparison [Figure 1]
ggplot(I_global_hist) + geom_line(aes(year,value, colour=variable), stat="identity") + ylab(NULL) + xlab(NULL) + ylim(0, 0.7) + ggtitle("Inequality indices") + guides(colour=guide_legend(title="")) + theme_bw() + theme(legend.position = "none", legend.box.just='left') + geom_text_repel(data=I_global_hist[c(6,39,69),], aes(x=year,y=value,label=variable, color=variable))
saveplot("figure-1-Atkinson_historical")

#Plot of Atkinson indices [Figure 2]
ggplot(subset(Atkinson_all_models, variable=="country inequality" | variable=="regional inequality"),aes(year,value,colour=model, linetype=variable, shape=model)) + geom_line(stat="identity") + geom_point(stat="identity") + ylab(expression(paste("I(", gamma, ")"))) + ylim(0, 0.6) + ggtitle(expression(paste("Atkinson index (", gamma, "=0.7)"))) + theme_bw() + theme(legend.position = c(0.25, 0.15), legend.direction = "vertical", legend.box = "horizontal",  legend.box.just='left', legend.background = element_rect(fill=alpha('white', 0.0))) +
scale_linetype_manual("", values=c("solid", "dashed")) +
scale_colour_discrete("") +
scale_shape_manual("", values=c(1,2,3,4,5))
saveplot("figure-2-Atkinson_indices")

#Plot per-capita consumption and c_ede [Figure 3]
ggplot(subset(Atkinson_all_models, variable=="Per-capita Consumption" | variable=="EDE"),aes(year,value,colour=model, linetype=variable, shape=model)) + geom_line(stat="identity") + geom_point(stat="identity") + ylab("US-$(2014)") + ggtitle(expression(paste("Consumption per-capita and EDE (", gamma, "=0.7)"))) + theme_bw() + theme(legend.position = c(0.2, 0.7), legend.box.just='left', legend.background = element_rect(fill=alpha('white', 0.0))) +
scale_colour_discrete("") +
scale_shape_manual("", values=c(1,2,3,4,5)) +
scale_linetype_manual("", values=c("dashed", "solid"))
saveplot("figure-3-CPC_EDE")


install.packages("neuralnet")
install.packages("nnet")

#calling included libraries
library(quantmod)
library(dplyr)
library(forecast)
library(neuralnet)
library(nnet)
library(devtools)

getSymbols("TCS",src="yahoo", from="2018-05-05", periodicity = "daily"  )

#Storing data in data frames
x<-data.frame(TCS)
write.table(x, file = "TCS$Close.csv", row.names=F, sep = ",")

x$date<-rownames(x)
rownames(x)<-NULL
x <- subset(x, select = c(TCS.Open, TCS.High , TCS.Low, TCS.Close, TCS.Volume, TCS.Adjusted))

x2 <- subset(x, select = c(TCS.Open, TCS.High , TCS.Low, TCS.Close, TCS.Volume, TCS.Adjusted))

str(x)

#for histogram https://www.datamentor.io/r-programming/histogram/
hist(x$TCS.Close,
     main=" TCS closing prices Histogram",
     xlab="x$TCS.Close",
     col="red"
)

plot(x$TCS.Close,type = "o", col = "red", xlab = "Index", ylab = "x$TCS.Close",
     main = "TCS closing prices Line Graph")

#Shows dimension of data frame x
dim(x)

#Head Function in R: returns the first n rows of a matrix or data frame in R.Here n=2

head(x,2,range)

#Apply Function in R: returns the n output in for the given funtion
#Here apply Returns range value
apply(x,2,range)

#Here apply Returns minimum value
minValue <- apply(x,2,min)
minValue

#Here apply Returns maximum value
maxValue <- apply(x,2,max)
maxValue

#dividing training data from our x data frame
t1<- sample(1:nrow(x),150)
tr1<-x[t1,]
dim(tr1)

#dividing test data randomly from our x data frame
te1<- x[-t1,]
dim(te1)

#scale is generic function whose default method centers and/or scales the columns of a numeric matrix
#https://www.rdocumentation.org/packages/base/versions/3.6.0/topics/scale
x<-as.data.frame(scale(x,center = minValue, scale = maxValue-minValue))
ind<-sample(1:nrow(x),150)
trainDF<-x[ind,]
testDF<-x[-ind,]
dim(trainDF)
dim(testDF)

allVars<-colnames(x)
allVars

predictorVarss<- allVars[!allVars%in%"TCS.Close"]
predictorVarss
predictorVarss<-paste(predictorVarss,collapse="+")
predictorVarss

form=as.formula(paste("TCS.Close~", predictorVarss,collapse = "+"))
neuralModel<- neuralnet(formula =form, hidden = c(4,2),linear.output=T,data=trainDF)

plot(neuralModel,col.hidden='black',col.entry = 'red',col.hidden.synapse = 'black',col.intercept = 'blue',col.entry.synapse = 'black',col.out = 'red',fontsize = 16)

predictions<-compute(neuralModel,testDF[,1:5])
str(predictions)

pred<-predictions$net.result
pred
predcsv<-data.frame(pred)
predcsv
predictions<- pred*(max(testDF$TCS.Close)-min(testDF$TCS.Close))+min(testDF$TCS.Close)
predictions

actualValues <- (testDF$TCS.Close)*(max(testDF$TCS.Close)-min(testDF$TCS.Close))
actualValues<-data.frame(actualValues)
write.table(actualValues, file = "actualValues.csv", row.names=F, sep = ",")

plot(testDF$TCS.Close,col='red',main='Real vs predicted NN',pch=18,cex=0.7)
points(predictions,col='blue',pch=18,cex=0.7)
legend('bottomright',legend=c('Real','Predicted'),pch=18,col=c('red','blue'))

plot(testDF$TCS.Close,type = "o",col='red',main='Real vs predicted NN',pch=18,cex=0.7)
points(predictions,type = "o",col='blue',pch=18,cex=0.7)
legend('bottomright',legend=c('Real','Predicted'),pch=18,col=c('red','blue'))

predictions
write.table(predictions, file = "predictions.csv", row.names=F, sep = ",")
testDF$TCS.Close
pred
final<-(testDF$TCS.Close-predictions)
result<-(te1$TCS.Close-final)

#mean square error
MeanSquareError<-sum((predictions - actualValues)^2)/nrow(testDF)
MeanSquareError=MeanSquareError*100
MeanSquareError
MeanSquareAccuracy=100-MeanSquareError
MeanSquareAccuracy
Err=sum((actualValues - predictions))/nrow(testDF)*100
Accuracy=100-Err
Accuracy


# Load the datasets and define some variables
library(dslabs)
data(murders)

population_in_millions <- murders$population/10^6
total_gun_murders <- murders$total

plot(population_in_millions, total_gun_murders)

# Transform population using the log10 transformation and save to object log10_population
log10_population <- log10(murders$population)

# Transform total gun murders using log10 transformation and save to object log10_total_gun_murders
log10_total_gun_murders <- log10(murders$total)

# Create a scatterplot with the log scale transformed population and murders
plot(log10_population, log10_total_gun_murders)


library("ggplot2")

head(economics)

#ggplot(data=economics, aes(x=date, y=unemploy)) + geom_line(color='#FFAA00', lwd=1) + geom_hline(yintercept=mean(economics$unemploy), linetype='dashed')
ggplot(data=economics, aes(x=date, y=unemploy)) + geom_bar(stat='identity', color='#FFAA00', lwd=1) + geom_hline(yintercept=mean(economics$unemploy), linetype='dashed')


# Get IRIS dataset
install.packages("RCurl")
library(RCurl)
iris_url = "https://archive.ics.uci.edu/ml/machine-learning-databases/iris/iris.data"
iris_txt = getURL(iris_url)
iris_data = read.csv(textConnection(iris_txt), header = FALSE)

#Rename the columns
library(plyr)
names(iris_data)
iris = rename(iris_data, c("V1"="Sepal_Length", "V2"="Sepal_Width","V3"="Petal_Length", "V4"="Petal_Width", "V5"="Species"))
names(iris)

#Fit the model
library(e1071)
fit <- naiveBayes(Species~., data=iris)

#Summarize model accuracy
table(predictions, iris$Species)

#Do a prediction using the model and a row of data
predict <- predict(fit, c(5.1,3.5,1.4,0.2))
predict[4]

#Summarize model accuracy
predictSpecies <- function(sepalLength, sepalWidth, petalLength, petalWidth)
{
predictDF <- predict(fit, data.frame("Sepal_Length" = sepalLength, "Sepal_Width" = sepalWidth, "Petal_Length" = petalLength, "Petal_Width" = petalWidth), type="raw")
return(colnames(predictDF)[apply(predictDF, 1, which.max)])
}

predictSpecies(5.1,3.5,1.4,0.9)

RedRabbit ES-R/R - ETL  Score - ES endpoin/Sentiment-classification/iris.r


#' GGplot2 PCA plot of different base R objects
#'
#' @param obj    A PCA object (e.g. from prcomp function)
#' @param aes    Aesthetics mapping; use "PC<num>" for principal components
#' @param annot  Additional data.frame with sample annotation
#' @return       ggplot2 object including PCs and sample annotations
pca = function(obj, aes, annot=NULL, biplot=FALSE, ...) {
    UseMethod("pca")
}

pca.prcomp = function(obj, aes=ggplot2::aes(), annot=NULL, repel=TRUE,
                      biplot=FALSE, bi_color="red", bi_size=5, bi_arrow=0.2, bi_alpha=0.4) {
    # adapted: https://stackoverflow.com/questions/6578355/plotting-pca-biplot-with-ggplot2
    data = cbind(annot, obj$x)
    rot = data.frame(varnames=rownames(obj$rotation), obj$rotation)
    x = rlang::quo_text(aes[["x"]])
    y = rlang::quo_text(aes[["y"]])
    summ = summary(obj)$importance

    mult = min(
        (max(data[,y]) - min(data[,y])/(max(rot[,y])-min(rot[,y]))),
        (max(data[,x]) - min(data[,x])/(max(rot[,x])-min(rot[,x])))
    )
    rot = transform(rot,
        v1 = .7 * mult * rot[[x]],
        v2 = .7 * mult * rot[[y]]
    )

    p = ggplot(data=data, mapping=aes)
    if (grepl("^PC[0-9]+$", x))
        p = p + xlab(sprintf("%s (%.0f%%)", x, 100*summ["Proportion of Variance", x]))
    if (grepl("^PC[0-9]+$", y))
        p = p + ylab(sprintf("%s (%.0f%%)", y, 100*summ["Proportion of Variance", y]))

    if (repel) {
        textfun = function(...) ggrepel::geom_text_repel(..., min.segment.length=Inf)
    } else {
        textfun = geom_text
    }

    if (biplot) {
        p = p + textfun(data=rot, aes(x=v1, y=v2, label=varnames),
                size = bi_size, vjust=1, color=bi_color) +
            geom_segment(data=rot, aes(x=0, y=0, xend=v1, yend=v2), alpha=bi_alpha,
                arrow=arrow(length=unit(bi_arrow,"cm")), color=bi_color)
    }

    p
}

pca.default = function(...) {
    stop("only `prcomp` supported for now")
}

if (is.null(module_name())) {
    library(ggplot2)
    obj = prcomp(iris[1:4])
    pca(obj, aes(x=PC1, y=PC2, color=Species), annot=iris["Species"], biplot=TRUE) +
        geom_point()
}


# Importing the dataset
# Click on the dataset you want to import at the right below pattern and clcick "more" - "Set as working directory"
dataset = read.csv('Data.csv')

# Taking care of missing data
dataset$Age = ifelse(is.na(dataset$Age),
                     ave(dataset$Age,FUN = function(x) mean(x, na.rm = TRUE)), # if there's NaN in the column, remove it and replace it with average value of all columns
                     dataset$Age)

dataset$Salary = ifelse(is.na(dataset$Salary),
                        ave(dataset$Salary, FUN = function(x) mean(x, na.rm = TRUE)),
                        dataset$Salary)
# Encoding categorical data
dataset$Country = factor(dataset$Country,
                         levels = c('France', 'Spain', 'Germany'),
                         labels = c(1, 2, 3))
dataset$Purchased = factor(dataset$Purchased,
                           levels = c('No', 'Yes'),
                           labels = c(0, 1))

# Splitting the dataset into the Training set and Test set
  # install.packages('caTools')
  # library(caTools)
set.seed(123) # we can choose a random number and make a split
split = sample.split(dataset$Purchased, SplitRatio = 0.8) #0.8 is the 80% observation put in the training set
training_set = subset(dataset, split == TRUE) # split == True if the observation is going to the training set
test_set = subset(dataset, split == FALSE) # split == False if the observation is going to the test set

# Feature Scaling
training_set[,2:3] = scale(training_set[,2:3]) # since our first and last column are categorical variables, we can't scale the x_train or x_test directly
  # Therefore, we would only scale the second and third column, which are "Age" and "Salary", index starts at 2 and ends at 3.
test_set[,2:3] = scale(test_set[,2:3])


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R

 library(kohonen)

 training_frame <- data[, c(2,4,5,8)]

 training_matrix <- as.matrix(scale(training_frame))

 training_matrix
             zn       chas         nox           dis
1    0.28454827 -0.2723291 -0.14407485  0.1400749840
2   -0.48724019 -0.2723291 -0.73953036  0.5566090496
3   -0.48724019 -0.2723291 -0.73953036  0.5566090496
4   -0.48724019 -0.2723291 -0.83445805  1.0766711351
5   -0.48724019 -0.2723291 -0.83445805  1.0766711351
6   -0.48724019 -0.2723291 -0.83445805  1.0766711351
7    0.04872402 -0.2723291 -0.26489191  0.8384142195
8    0.04872402 -0.2723291 -0.26489191  1.0236248974
9    0.04872402 -0.2723291 -0.26489191  1.0861216287
10   0.04872402 -0.2723291 -0.26489191  1.3283202075
11   0.04872402 -0.2723291 -0.26489191  1.2117799501
12   0.04872402 -0.2723291 -0.26489191  1.1547920492
13   0.04872402 -0.2723291 -0.26489191  0.7863652700
14  -0.48724019 -0.2723291 -0.14407485  0.4333252240
15  -0.48724019 -0.2723291 -0.14407485  0.3166899868
16  -0.48724019 -0.2723291 -0.14407485  0.3341187865
17  -0.48724019 -0.2723291 -0.14407485  0.3341187865
18  -0.48724019 -0.2723291 -0.14407485  0.2198105553
19  -0.48724019 -0.2723291 -0.14407485  0.0006920764

 som_grid <- somgrid(xdim = 20, ydim=20, topo="hexagonal")

 som_model <- som(training_matrix,
                  grid=som_grid,
                  rlen=1000,
                  alpha=c(0.05,0.01),
                  keep.data = TRUE,
                  n.hood="circular")

 plot(som_model, main ="Training Progress", type="changes", col = "red")

 plot(som_model, main ="Node Count", type="count")

 plot(som_model, main ="Neighbour Distances", type="dist.neighbours")

 plot(som_model, type="codes")

 plot(som_model, type = "property", property = som_model$codes[,4], main=names(som_model$data)[4])

Chapter 07/1Self Organizing Map - Visualisations of  heatmaps.r


# Copyright 2020 The MuLT Authors. All Rights Reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# ==============================================================================

library(ggplot2)
library(dplyr)
library(MESS)

df <- read.csv('data/output/best_model_estimations.csv', sep=',')

simple_roc <- function(labels, scores){
  labels <- labels[order(scores, decreasing=TRUE)]
  list(data.frame(TPR=cumsum(labels)/sum(labels), FPR=cumsum(!labels)/sum(!labels), labels))
}

p <-
  ggplot(df, aes(y_hat, y - y_hat)) + geom_point(aes(colour=as.factor(y))) + ylim(-1, 1) +
  geom_hline(yintercept = 0, lty=2,col="grey") + xlab('Predicted Values') + ylab('Residuals') +
  geom_smooth() + theme(legend.position = c(0.35, .1)) +
  scale_colour_discrete(name = "Risk", labels=c('High', 'Low')) +
  theme(text=element_text(size=11, family='serif'), legend.direction = "horizontal")

ggsave('images/residuals_best_model.pdf', p, units='cm', heigh=7, width=8)

result <-
  df %>%
    group_by(fold) %>%
    summarize(roc = simple_roc(y, y_hat))

final_df = data.frame()

for (i in result$roc) {

  i['INDEX'] = 1:nrow(i)

  final_df <- rbind(final_df, i)

}

final_df <- as.data.frame(cbind(aggregate(TPR ~ INDEX, final_df, mean)$TPR,
      aggregate(TPR ~ INDEX, final_df, sd)$TPR,
      aggregate(FPR ~ INDEX, final_df, mean)$FPR,
      aggregate(FPR ~ INDEX, final_df, sd)$FPR))

colnames(final_df) <- c('TPR.mean', 'TPR.sd', 'FPR.mean', 'FPR.sd')

p <-
  ggplot(final_df, aes(FPR.mean, TPR.mean)) + geom_line(size=1.2) +
  geom_ribbon(aes(x=FPR.mean, ymax=TPR.mean + TPR.sd, ymin=TPR.mean - TPR.sd), alpha=0.2) +
  xlab('False Positive Ratio') + ylab('True Positive Ratio') +
  geom_label(aes(label=paste('AUC of', round(auc(final_df$FPR.mean, final_df$TPR.mean), 2)), x=.75, y=.25), size=3, family='serif', fill = "gray", alpha=.1) +
  theme(text=element_text(size=11, family='serif'))

ggsave('images/roc_curve_best_model.pdf', p, units='cm', heigh=7, width=8)


# Pull OECD into dataframe
work <- get_dataset("PRICES_CPI")

work <- get_dataset("PERS_FUNC")

fte <- work
fte <- fte[which(fte$SECTPERF %in% c("_T")),]
fte <- fte[which(fte$FUNCTION %in% c("RSE")),]
fte <- fte[which(fte$GENDER %in% c("_T")),]
fte <- fte[which(fte$MEASURE %in% c("FTE")),]
fte <- fte[which(fte$COUNTRY %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]

fte$lnrdworker <- log(fte$obsValue)

fig <- plot_ly(fte, x = ~obsTime, y = ~obsValue, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D Workers over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'FTE R&D Workers'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-fte")

fig <- plot_ly(fte, x = ~obsTime, y = ~lnrdworker, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D Workers over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log FTE R&D Workers'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-lnfte")

jpn <- fte[which(fte$COUNTRY %in% c("JPN")),]
fig <- plot_ly(jpn, x = ~obsTime, y = ~lnrdworker, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Japanese R&D Workers over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log FTE R&D Workers'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-lnfte-jpn")

work <- get_dataset("GERD_TOE")

gerd <- work
gerd <- gerd[which(gerd$SECTPERF %in% c("_T")),]
gerd <- gerd[which(gerd$TYPE_COST %in% c("_T")),]
gerd <- gerd[which(gerd$MEASURE %in% c("DF6")),]
gerd <- gerd[which(gerd$COUNTRY %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]
gerd$lnrd <- round(log(gerd$obsValue),digits=2)

fig <- plot_ly(gerd, x = ~obsTime, y = ~lnrd, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D expenditure over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Log real R&D expenditures', type='log'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-logrd")

fig <- plot_ly(gerd, x = ~obsTime, y = ~obsValue, linetype = ~COUNTRY, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'R&D expenditure over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Real R&D expenditures'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-levelrd")

# too large to download directly
p <- read.csv("~/Dropbox/project/studyguide/data/pats_ipc_subset.csv", header=TRUE)

pat <- p
pat <- pat[which(pat$KINDCOUNTRY %in% c("APPLICANTS")),]
pat <- pat[which(pat$KINDPATENT %in% c("USPTO_G")),]
pat <- pat[which(pat$KINDDATE %in% c("GRANT")),]
pat <- pat[which(pat$IPC %in% c("TOTAL")),]
pat <- pat[which(pat$LOCATION %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]

#write.csv(pat,file="~/Dropbox/project/studyguide/data/pats_ipc_subset.csv",row.names=FALSE, na="")

fig <- plot_ly(pat, x = ~Time, y = ~Value, linetype = ~LOCATION, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Patent activity over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'USPTO patent grants'),
              hovermode="x unified")
api_create(fig, filename = "oecd-rd-patent")


### Model Complexity Mincerian wage example
## Use: Generate data for the Mincerian wage example in the paper
## Author: Mark Verhagen

## Load libraries
library(foreign)
library(xgboost)
library(tidyverse)
library(caret)
library(randomForest)
library(doParallel)

source("mincerian/functions.r")

n_obs <- 50000
set.seed(1704)

## Read data from 2018 GSS
data <- read.dta("mincerian/data/raw/GSS2018.dta")

## Transform data
df <- data %>%
  filter(age >= 18,
         age <= 65,
         !is.na(educ)) %>%
  mutate(age_cat = ifelse(age < 25, "18_24",
      ifelse(age < 35, "25_34",
          ifelse(age < 50, "35_49", "50_65")
      )
  ))

## Generate a sample
educ_age_props <- count(df, educ, age_cat, wt = wtss) %>%
    mutate(
        prop = n / sum(n),
        cum_prop = cumsum(prop)
    )

## Sample actual ages
new_sample <- sample_n(educ_age_props, size = n_obs, weight = n, replace = T)

new_sample$age <- ifelse(new_sample$age_cat == "18_24",
    round(runif(dim(new_sample)[1], 18, 24)),
    ifelse(new_sample$age_cat == "25_34",
        round(runif(dim(new_sample)[1], 25, 34)),
        ifelse(new_sample$age_cat == "35_49",
            round(runif(dim(new_sample)[1], 35, 49)),
            round(runif(dim(new_sample)[1], 50, 65))
        )
    )
)

## Generate independent variables
analysis_df <- new_sample %>%
    mutate(
        S = as.numeric(educ),
        X = ifelse(educ >= 10, age - educ - 4, age - 16),
        X = ifelse(X < 0 , 0, X),
        X_sq = X^2
    ) %>%
  rowwise() %>%
  mutate(S_0_8 = min(S, 8),
         S_9_10 = min(2, max(S - 8, 0)),
         S_11_12 = min(2, max(S - 10, 0)),
         S_13_14 = min(2, max(S - 12, 0)),
         S_15p = max(S - 14, 0)) %>%
  ungroup()

## Randomly assign rows to male or female for gender illustration
analysis_df$gender <- ifelse(runif(dim(analysis_df)[1], 0, 1) > 0.5, 1, 0)

## Simulate log wage based on various linear additive models
simul_df <- analysis_df %>%
    mutate(
        epsilon = rnorm(dim(analysis_df)[1], 0, 0.12),
        ln_y_I = 4.5 + 0.125 * S + 0.09 * X +
            rnorm(dim(analysis_df)[1], 0, 0.12),
        ln_y_II = 4.5 + 0.125 * S + 0.09 * X - 0.001 * X^2  +
            rnorm(dim(analysis_df)[1], 0, 0.07),
        ln_y_III = 4.5 + 0.02 * S_0_8 + 0.03 * S_9_10 + 0.30 * S_11_12 +
            0.06 * S_13_14 + 0.06 * S_15p + 0.09 * X - 0.001 * X^2 +
            rnorm(dim(analysis_df)[1], 0, 0.07),
        ln_y_IV = ifelse(gender == 0,
            5.5 + 0.015 * S_0_8 + 0.02 * S_9_10 + 0.25 * S_11_12 +
            0.04 * S_13_14 + 0.04 * S_15p + 0.06 * X - 0.001 * X^2 +
            rnorm(dim(analysis_df)[1], 0, 0.09),
            3.5 + 0.025 * S_0_8 + 0.06 * S_9_10 + 0.35 * S_11_12 +
                0.06 * S_13_14 + 0.08 * S_15p + 0.1 * X - 0.0005 * X^2 +
                rnorm(dim(analysis_df)[1], 0, 0.08)
        )
    ) %>%
    mutate(id = 1 : dim(analysis_df))


# R code
# Luis P. F. Garcia 2018
# Measures for the dsf

gMean <- function(x) {
  mean(x^(1/length(x)))
}

hMean <- function(x) {
  length(x)/sum(1/x)
}