> data <- read.csv("input_1.csv", header = TRUE)
> table(data$landmark)

    N     Y
14076  1009
> prop.table(table(data$landmark))

         N          Y
0.93311236 0.06688764
> library(sampling)
> n <- round(9/10*nrow(data)/3)
> train <- strata(data, stratanames = ("landmark"),
+        size = c(14076*9/10, 1009*9/10),, method="srswor")
> traindata <- data[train$ID_unit,]
> testdata <- data[-train$ID_unit,]
> table(traindata$landmark)

    N     Y
12668   908
> prop.table(table(traindata$landmark))

         N          Y
0.93311727 0.06688273
> #train <- sample(nrow(data), 9/10*15085)
> #traindata <- data[train,]
> #testdata <- data[-train,]
> library(DMwR)
> smotedata <- SMOTE(landmark ~ ., traindata, perc.over = 150,perc.under = 195)
> table(smotedata$landmark)

   N    Y
1770 1816
> prop.table(table(smotedata$landmark))

        N         Y
0.4935862 0.5064138
> library(randomForest)
> set.seed(100)
> rf_ntree <- randomForest(landmark~., data = smotedata, ntree = 600, importance = TRUE)
> pred <- predict(object = rf_ntree,newdata = testdata)
> roc.curve(testdata$landmark, pred)
Area under the curve (AUC): 0.814
> table(testdata$landmark,pred)
   pred
       N    Y
  N 1135  273
  Y   18   83
> importance(rf_ntree,type = 1, scale = TRUE)
                                     MeanDecreaseAccuracy
lon                                              35.10535
lat                                              52.59334
feature.level                                    98.61635
highest.road.level                               20.19906
road.density                                     37.83646
GDP.level                                        25.74159
same.features.in.500.buffer                      39.83412
different.features.in.500.buffer                 43.51922
traffic.stations.nearby.in.Baidu.Map             39.44221
crowd.density                                    38.65292
Bing.search.results                              52.74905
Weibo.search.results                             65.89811
Baidu.Map.poi                                    12.66796
building                                         30.59576
category_2                                       41.32356
category_1                                       21.23061
> importance(rf_ntree,type = 2, scale = TRUE)
                                     MeanDecreaseGini
lon                                          82.81873
lat                                         129.49799
feature.level                               395.20606
highest.road.level                           38.64444
road.density                                 90.92090
GDP.level                                    36.87733
same.features.in.500.buffer                  82.17458
different.features.in.500.buffer             90.66348
traffic.stations.nearby.in.Baidu.Map         81.52226
crowd.density                                99.47272
Bing.search.results                         184.04190
Weibo.search.results                        205.79951
Baidu.Map.poi                                14.14856
building                                     84.80672
category_2                                  141.21173
category_1                                   34.13857
> varImpPlot(rf_ntree)
> write.csv(traindata,"traindata.csv")
> write.csv(testdata,"testdata.csv")
> pred <- predict(object = rf_ntree,newdata = testdata)
> roc.curve(testdata$landmark, pred)
Area under the curve (AUC): 0.814
> table(testdata$landmark,pred)
   pred
       N    Y
  N 1134  274
  Y   18   83
>


# Case Study: Working with Stack Overflow

# A. Initial insights
# 1. Left joining
questions %>%
  left_join(question_tags, by = c("id" = "question_id")) %>%
  left_join(tags, by = c("tag_id" = "id")) %>%
  replace_na(list(tag_name = "only-r"))

# 2. Compare scores across tags
questions_with_tags %>%
	# Group by tag_name
	group_by(tag_name) %>%
	# Get mean score and num_questions
	summarize(score = mean(score),
          	  num_questions = n()) %>%
	# Sort num_questions in descending order
	arrange(desc(num_questions))

# 3. Tags that never appear on R questions
# Using a join, filter for tags that are never on an R question
tags %>%
    anti_join(question_tags, by = c("id" = "tag_id"))

# B. Reviewing questions and answers
# 1. Finding the gap
questions %>%
	# Inner join questions and answers with proper suffixes
	inner_join(answers, by = c("id" = "question_id"), suffix = c("_question", "_answer")) %>%
	# Subtract creation_date_question from creation_date_answer to create gap
	mutate(gap = as.integer(creation_date_answer - creation_date_question))

# 2. Joining question and answer counts
# Count and sort the question id column in the answers table
answer_counts <- answers %>%
	count(question_id) %>% arrange(question_id)

# Combine the answer_counts and questions tables
questions %>%
	full_join(answer_counts, by = c("id" = "question_id")) %>%
	# Replace the NAs in the n column
	replace_na(list(n = 0))

# 3. Adding tags information
question_answer_counts %>%
	# Join the question_tags tables
	inner_join(question_tags, by = c("id" = "question_id")) %>%
	# Join the tags table
	inner_join(tags, by = c("tag_id" = "id"))

# 4. Average number of answers by question
tagged_answers %>%
	# Aggregate by tag_name
    group_by(tag_name) %>%
	# Summarize questions and average_answers
    summarize(questions = n(),
              average_answers = mean(n)) %>%
	# Sort the questions in descending order
    arrange(desc(questions))

# C. The bind_rows() verb. Works by stacking datasets
# 1. Joining the datasets
# Inner join the question_tags and tags tables with the questions table
questions %>%
  inner_join(question_tags, by = c("id" = "question_id")) %>%
  inner_join(tags, by = c("tag_id" = "id"))

# Inner join the question_tags and tags tables with the answers table
answers %>%
  inner_join(question_tags, by = "question_id") %>%
  inner_join(tags, by = c("tag_id" = "id"))

# 2. Binding and counting posts
# Combine the two tables into posts_with_tags
posts_with_tags <- bind_rows(questions_with_tags %>% mutate(type = "question"),
                              answers_with_tags %>% mutate(type = "answer"))

# library(lubridate) # A date package within R
# Add a year column, then count by type, year, and tag_name
posts_with_tags %>%
    mutate(year = year(creation_date)) %>%
    count(type, year, tag_name)

# 3. Visualize the questions and answers
# Filter for the dplyr and ggplot2 tag names
by_type_year_tag_filtered <- by_type_year_tag %>%
  filter(tag_name %in% c("dplyr", "ggplot2"))

# Create a line plot faceted by the tag name
ggplot(by_type_year_tag_filtered, aes(year, n, color = type)) +
  geom_line() +
  facet_wrap(~ tag_name)


#---
#title: "calculating plant density from survey done in 2020 on transect A"
#author: "Tal Dahan-Meir"
#date: "25/08/2021"
#---

require(geosphere)

csv = read.csv("data/2020_plant_densities.csv",colClasses="character")

#get dists between plants to next plants and add to data.frame
nPlants_a = nrow(csv)
coordinates_next_plants = data.frame("altitude_nextPlant" = rep(NA,nPlants_a),
                                     "latitude_nextPlant" = rep(NA,nPlants_a),
                                     "longitude_nextPlant" = rep(NA,nPlants_a))
for (i in 1:(nPlants_a-1)){
  coordinates_next_plants[i,] = csv[i+1,c("altitude","latitude","longitude")]
}
csv_distances = cbind (csv,coordinates_next_plants)
csv_distances$dist_meters = c( apply(csv_distances[1 : (nPlants_a-1), ], 1, function(tt) { distm(x = c(as.numeric(tt[6]), as.numeric(tt[5]) ), y = c(as.numeric(tt[9]), as.numeric(tt[8]) ) )} ), "NA")
csv_distances$position_meters = as.numeric(c( 0 ,cumsum (csv_distances[1:(nPlants_a-1), "dist_meters"] )))
csv_distances$plantsPerMeter = as.numeric(csv_distances$plants_until_next_point) / as.numeric(csv_distances$dist_meters)
csv_distances$plantsinMM_divided_by_pi = as.numeric(csv_distances$plants_in_1MM2) / pi
csv_distances$plantsinM_combined = as.numeric(csv_distances$plantsinMM_divided_by_pi)+as.numeric(csv_distances$plantsPerMeter)

head(csv_distances)

pdf("transect_a_density_2020.pdf", height=8, width=22)
plot (as.numeric(csv_distances$position_meters),
      as.numeric(csv_distances$plantsinMM_divided_by_pi),
      main = "Density transect A",
      cex.main=2,
      pch = 19,
      cex = 0.2,
      cex.lab = 1.5,
      cex.axis=1.4,
      ylim=c(0,25),
      xlim=c(0,320),
      col="black",
      xlab = "position (M)",
      ylab = "spikes per M^2")

apply(csv_distances,1, function(xx){
  rect(xleft = as.numeric(xx[11]),
      ybottom = 0,
      xright = as.numeric(xx[11])+as.numeric(xx[10]),
      ytop = as.numeric(xx[12])/2,
      col="#00ABA920",
      border= NA)} )
names_height_bonus = 0.5
apply(csv_distances,1, function(xx){
  text(x = as.numeric(xx[11]),
       y = as.numeric(xx[13])+names_height_bonus,
       as.character(xx[1]),
       col="black",
       cex=1)} )
dev.off()

###calculate mean density in m^2###
#(sum of plants around peg divided by pi - to transform from circle to ^2)+(sum of plants until next point divided by 2 - to transform from 2 meters to 1 meter width)/(transect length)
(sum(as.numeric(csv_distances$plantsinMM_divided_by_pi))+(sum(as.numeric(csv_distances$plants_until_next_point),na.rm=T)/2))/max(csv_distances$position_meters)


#' Create a co-occurence network
#'
#' @param x either a document-term matrix (DTM) or a tokenlist.
#' @param measure the measure to calcualte adjacency. Currently supports cosine and conditional probability
#' @return A graph in the Igraph format in which edges represent the adjacency of terms
#' @export
coOccurenceNetwork <- function(x, measure='cooccurence', doc.col=getOption('doc.col','doc_id'), position.col=getOption('position.col','position'), word.col=getOption('word.col','word')){
  if('data.frame' %in% class(x)) {
    verifyTokenlistColumns(tokenlist, doc.col, position.col, word.col)
    x = tokenlistToDTM(x, doc.col, position.col, word.col)
  }
  if('DocumentTermMatrix' %in% class(x)) x = dtmToSparseMatrix(x)

  x = as(as(x, 'dgCMatrix'), 'dgTMatrix')
  if(measure == 'cosine') {
    mat = as(getCosine(x), 'dgCMatrix')
    g = graph.adjacency(mat, mode='upper', diag=F, weighted=T)
  }
  if(measure == 'cooccurence') {
    mat = getCoOccurence(x)
    g = graph.adjacency(mat, mode='upper', diag=F, weighted=T)
  }
  if(measure == 'conprob') {
    mat = getConditionalProbability(x)
    g = graph.adjacency(mat, mode='directed', diag=F, weighted=T)
  }
  V(g)$freq = col_sums(x)
  g = set.edge.attribute(g, measure, value=E(g)$weight)
  class(g) = c('semnet',class(g))
  g
}

dtmToSparseMatrix <- function(dtm){
  sm = spMatrix(nrow(dtm), ncol(dtm), dtm$i, dtm$j, dtm$v)
  rownames(sm) = rownames(dtm)
  colnames(sm) = colnames(dtm)
  sm
}

getCoOccurence <- function(m1, m2=m1){
  m1@x[m1@x > 0] = 1
  m2@x[m2@x > 0] = 1
  mat = Matrix::crossprod(m1,m2)
  mat[is.na(mat)] = 0
  mat
}

getConditionalProbability <- function(m1, m2=m1){
  m1@x[m1@x > 0] = 1
  m2@x[m2@x > 0] = 1
  mat = Matrix::crossprod(m1,m2)/Matrix::colSums(m1)
  mat[is.na(mat)] = 0
  mat
}

getCosine <- function(m1, m2=NULL){
  norm = sqrt(Matrix::colSums(m1^2))
  m1@x = m1@x / norm[m1@j+1]
  if(!is.null(m2)){
    norm = sqrt(Matrix::colSums(m2^2))
    m2@x = m2@x / norm[m2@j+1]
    cp = Matrix::crossprod(m1,m2)
  } else cp = Matrix::crossprod(m1)
  cp
}

calculateAdjacency <- function(position.mat, window.mat){
  adj = Matrix::crossprod(position.mat, window.mat)
  g = graph.adjacency(adj, mode='directed', weighted=T, diag=F)
  V(g)$freq = col_sums(position.mat)
  E(g)$cooccurence = E(g)$weight
  E(g)$weight_pct = E(g)$weight / V(g)$freq[get.edgelist(g, names = F)[,1]]
  class(g) = c('semnet',class(g))
  g
}

aggCoOc <- function(x, position.mat, window.mat){
  cooc = position.mat[,x] & window.mat
  cooc = as(cooc, 'lgTMatrix')
  cooc = data.frame(x=x, y=cooc@j+1, context=cooc@i+1, weight=cooc@x)
  cooc = cooc[!cooc$x == cooc$y,]
  ddply(cooc, .(x,y,context), summarize, weight=sum(weight))
}

calculateAdjacencyPerContext <- function(position.mat, window.mat) {
  adj = ldply(1:ncol(position.mat), function(x) aggCoOc(x, position.mat, window.mat))
  adj$context = rownames(position.mat)[adj$context]
  adj$x = as.factor(colnames(position.mat)[adj$x])
  adj$y = as.factor(colnames(position.mat)[adj$y])
  adj
}

#' Merge a list of matrices
#'
#' Merge matrices, by standradizing column and row dimensions and using the Reduce function to merge them.
#'
#' @param matrices A list of matrices
#' @param reduce_func The function to pass to Reduce
#' @return A single matrix
#' @export
mergeMatrices <- function(matrices, reduce_func='+'){
  rowdim = unique(llply(matrices, function(x) rownames(x)))[[1]]
  coldim = unique(llply(matrices, function(x) colnames(x)))[[1]]
  matrices = llply(matrices, function(x) setMatrixDims(x, rowdim, coldim))
  mat = Reduce(reduce_func, matrices)
  rownames(mat) = rowdim
  colnames(mat) = coldim
  mat
}

setMatrixDims <- function(mat, rowdim, coldim){
  ## set rows and columns of matrix to given rowdim and coldim vectors. (usefull for making different matrices identical so that they can be summed up)
  mat = as(mat, 'dgTMatrix')
  d = data.frame(i=rownames(mat)[mat@i+1], j=colnames(mat)[mat@j+1], v=mat@x)
  d = d[d$i %in% rowdim & d$j %in% coldim,]
  d$i = match(d$i, rowdim)
  d$j = match(d$j, coldim)
  spMatrix(length(rowdim), length(coldim), d$i, d$j, d$v)
}

#### using chi-square (experimental)

#' Compute the chi^2 statistic for a 2x2 crosstab containing the values
#' [[a, b], [c, d]]
chi2 <- function(a,b,c,d, yates_correction=rep(F, length(a)), autocorrect=F){
  n = a+b+c+d
  sums = cbind(c1 = a+c, c2 = b+d, r1 = a+b, r2 = c+d)

  if(autocorrect){
    ## apply Cochrans criteria: no expected values below 1 and less than 20% of cells empty (which means none in a 2x2 design)
    ## if these are violated, use the yates_correction
    ## http://www.ncbi.nlm.nih.gov/pmc/articles/PMC2041889/
    e = cbind(sums[,'c1'] / n, sums[,'c2'] / n)
    e = cbind(e * sums[,'r1'], e * sums[,'r2'])
    c1 = rowSums(e < 1) > 0          # at least one expected value below 1
    c2 = rowSums(sums < 5) > 0       # at least one cell below 5
    yates_correction = ifelse(c1 | c2, T, F)
  }
  x = a*d - b*c
  x = ifelse(yates_correction, abs(x) - n/2, x)
  chi = n*x^2 / (sums[,'c1'] * sums[,'c2'] * sums[,'r1'] * sums[,'r2'])
  ifelse(is.na(chi), 0, chi)
}

binom.coef.log <- function(n, k) {
  bcl_func <- function(n, k) sum(log(((n-k+1):n) / ((k-k+1):k)))
  mapply(bcl_func, n, k)
}
fishers.exact <- function(a,b,c,d){
  n = a+b+c+d
  log_p = binom.coef.log(a+b,a) + binom.coef.log(c+d,c) - binom.coef.log(n,a+c)
  exp(log_p)
}

getContextOccurence <- function(m1, m2=m1){
  m2@x[Matrix::which(m2@x > 0)] = 1
  mat = Matrix::crossprod(m1,m2)
  mat[is.na(mat)] = 0
  mat
}

smooth_prob <- function(succes, n, vocabulary_size=NULL, smoothing_parameter=1){
  if(is.null(vocabulary_size)) {
    (word_occ + smoothing_parameter) / (n + smoothing_parameter)
  } else{
    (word_occ + smoothing_parameter) / (n + (vocabulary_size*smoothing_parameter))
  }
}

edgeChi2 <- function(g, wordfreq.col='freq', wordcooc.col='cooccurence', vocabulary=NULL){
  freq = get.vertex.attribute(g, wordfreq.col)
  cooc = get.edge.attribute(g, wordcooc.col)
  e = get.edgelist(g, names = F)
  if(is.null(vocabulary)) vocabulary = structure(freq, names=V(g)$name)

  y_if_x= cooc
  y_ifnot_x = freq[e[,2]] - cooc

  x_total_cooc = tapply(cooc, e[,1], sum)
  n_if_x = x_total_cooc[e[,1]]
  n_ifnot_x = sum(x_total_cooc) - n_if_x

  E(g)$chi =  chi2(y_if_x, y_ifnot_x,
                   n_if_x - y_if_x, n_ifnot_x - y_ifnot_x,
                   autocorrect = T)

  E(g)$chi.p = 1-pchisq(E(g)$chi, 1)
  g
}

#' Get wordassociations based on ratio and chi-2
#'
#' Calculate wordassociations (x -> y) as the ratio of the p
#'
#' @param dtm the main document-term matrix
#' @return A dataframe representing and edge.list
#' @export
chi2_wordassociations <- function(dtm, odds.ratio.thres=1, thres=0.05, measure='fisher', smoothing_parameter=1, use.wordcount=T, return.graph=T) {
  d = coOccurenceDistributionTable(dtm, use.wordcount)

  d$prob_y_if_x = (d$y_if_x / d$n_if_x)
  d$prob_y_ifnot_x = (d$y_ifnot_x / d$n_ifnot_x)
  d$prob_ratio = d$prob_y_if_x / d$prob_y_ifnot_x
  d$odds_ratio = (d$prob_y_if_x / (1 + d$prob_y_if_x)) / (d$prob_y_ifnot_x / (1 + d$prob_y_ifnot_x))
  d = d[d$odds_ratio > odds.ratio.thres,]

  d$chi = chi2(d$y_if_x,
               d$y_ifnot_x,
               d$n_if_x-d$y_if_x,
               d$n_ifnot_x-d$y_ifnot_x)
  d$chi.p = 1-pchisq(d$chi, 1)

  d$fisher.p = fishers.exact(d$y_if_x,
                             d$y_ifnot_x,
                             d$n_if_x-d$y_if_x,
                             d$n_ifnot_x-d$y_ifnot_x)

  d = d[d$chi.p < chi.p.thres,]
  d = d[d$fisher.p < fisher.p.thres,]

  d = d[!d$x == d$y,]
  d$x = colnames(dtm)[d$x]
  d$y = colnames(dtm)[d$y]
  d$n = d$y_if_x

  if(return.graph){

    g = graph.data.frame(d[,c('x','y')])
    E(g)$odds_ratio = d$odds_ratio
    E(g)$smooth_odds_ratio = d$odds_ratio
    E(g)$weight = d$odds_ratio / (1 + d$odds_ratio)

    V(g)$freq = col_sums(dtm)[match(V(g)$name, colnames(dtm))]
    class(g) = c('semnet',class(g))
    return(g)
  } else return(d[,c('x','y', 'n', 'prob_ratio', 'odds_ratio','chi','chi.p', 'fisher.p')])
}

coOccurenceDistributionTable <- function(dtm, use.wordcount=T, smooth_param=1){
  if('DocumentTermMatrix' %in% class(dtm)) dtm = dtmToSparseMatrix(dtm)
  dtm = as(dtm, 'dgCMatrix')

  conocc = as(getContextOccurence(dtm), 'dgTMatrix')
  d = data.frame(x=conocc@j+1, y=conocc@i+1)
  d$y_if_x= conocc@x # how often did y occur in documents in which x occured
  d$y_ifnot_x = Matrix::colSums(dtm)[d$y] - d$y_if_x # how often did y occur in documents in which x did not occur
  d$n_if_x = Matrix::colSums(conocc)[d$x] # how many words occured in documents where x occured
  d$n_ifnot_x = sum(dtm) - d$n_if_x # how many words occured in documents where x did not occur

  d$y_if_x = d$y_if_x + smooth_param
  d$y_ifnot_x = d$y_ifnot_x + smooth_param

  if(use.wordcount){
    vocabulary_if_x = Matrix::colSums(conocc > 0)[d$x]
    vocabulary = Matrix::colSums(dtm)
    vocabulary_ifnot_x = sapply(1:ncol(dtm), function(x) sum(vocabulary > Matrix::colSums(dtm[dtm[,x] > 0, ,drop=F])))
    vocabulary_ifnot_x = vocabulary_ifnot_x[d$x]
    d$n_if_x = d$n_if_x + vocabulary_if_x*smooth_param
    #d$n_ifnot_x = d$n_ifnot_x + ncol(dtm)*smooth_param
    d$n_ifnot_x = d$n_ifnot_x + vocabulary_ifnot_x*smooth_param

  } else {
    d$n_if_x = d$n_if_x + smooth_param
    d$n_ifnot_x = d$n_ifnot_x + smooth_param
  }
  d
}

#' Get wordassociations based on ratio and chi-2
#'
#' Calculate wordassociations (x -> y) as the ratio of the p
#'
#' @param dtm the main document-term matrix
#' @return A dataframe representing and edge.list
#' @export
chi2_wordassociations_alternative <- function(dtm, ratio.thres=1, p.thres=0.05, smoothing_parameter=1, return.graph=T) {
  if('DocumentTermMatrix' %in% class(dtm)) dtm = dtmToSparseMatrix(dtm)
  dtm = as(dtm, 'dgCMatrix')
  conocc = as(getContextOccurence(dtm), 'dgTMatrix')

  d = data.frame(x=conocc@j+1, y=conocc@i+1)
  d$y_if_x= conocc@x # how often did y occur in documents in which x occured
  d$y_ifnot_x = diag(conocc)[d$y] - d$y_if_x # how often did y occur in documents in which x did not occur
  d$n_if_x = colSums(conocc)[d$x] # how many words occured in documents where x occured
  d$n_ifnot_x = sum(dtm) - d$n_if_x # how many words occured in documents where x did not occur

  d$chi = chi2(d$y_if_x,
               d$y_ifnot_x,
               d$n_if_x-d$y_if_x,
               d$n_ifnot_x-d$y_ifnot_x)
  d$p = 1-pchisq(d$chi, 1)
  d = d[d$p < p.thres,]

  d$odds_ratio = (d$y_if_x/d$n_if_x) / (d$y_ifnot_x/d$n_ifnot_x)
  d = d[d$odds_ratio > ratio.thres,]
  d$smooth_odds_ratio = smooth_rel(d$y_if_x, d$n_if_x, nrow(conocc), smoothing_parameter) / smooth_rel(d$y_ifnot_x, d$n_ifnot_x, nrow(conocc), smoothing_parameter)

  d = d[!d$x == d$y,]
  d$x = colnames(conocc)[d$x]
  d$y = colnames(conocc)[d$y]
  d$n = d$y_if_x

  if(return.graph){
    g = graph.data.frame(d[,c('x','y')])
    E(g)$odds_ratio = d$odds_ratio
    E(g)$smooth_odds_ratio = d$smooth_odds_ratio
    E(g)$weight = d$smooth_odds_ratio / (1 + d$smooth_odds_ratio)

    V(g)$freq = colSums(dtm)[match(V(g)$name, colnames(dtm))]
    class(g) = c('semnet',class(g))
    return(g)
  } else return(d[,c('x','y', 'n', 'odds_ratio','smooth_odds_ratio','chi','p')])
}

edgeWeightStatistics <- function(g, edge.coocc.var='weight', vertex.freq.var='freq'){

}


###############################################################
##
## Section 3: Constructing and editing gtables
##
###############################################################

###############################################################
##
## Lecture 8: What is gtable
##
###############################################################

###############################################################
##
## Lecture 9: Constructing a gtable and adding grobs to the gtable
##
##   Construct arrays of grobs
##   Construct an empty gtable
##   Populate a gtable with grobs
##
###############################################################

# gtable can be constructed as
#    a column,
#    a row,
#    an array.

# First, create some grobs.
library(grid)

rect <- rectGrob(gp = gpar(fill = "orange"),
                  name = "gRect")

polygon <- polygonGrob(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0),
                        gp = gpar(fill = "burlywood3", lwd = 3),
                        name = "gPolygon")

text <- textGrob(label = "Learning gtable",
                  gp = gpar(cex = 1.2),
                  name = "gText")

PolygonText <- gTree(name = "gPolygonText", children = gList(polygon, text))

myTree <- gTree(name = "gTree", children = gList(rect, PolygonText))

# Set up a gtable with one column
# Insert grobs
library(gtable)
gCol <- gtable_col(name = "gCol", list(text, polygon, rect))
grid.newpage()
grid.draw(gCol)

# Set up a gtable with one row
# Insert grobs
gRow  <- gtable_row("gRow", list(text, polygon, rect))
grid.newpage()
grid.draw(gRow)

# Alternatively,  we can create a gtable as a matrix
# The grobs need to be in a list,
# and collected into a matrix.
# The last grob in the list is a null grob,
# In the matrix, it is positioned at the bottom right cell.
# Widths and heights need to be set.
# Note the unit function:
#     number and unit of measurement.
# There are two widths because there are two columns;
# There are two heights because there are two rows.

# The null unit:
# Indicates relative widths and heights.
# widths = unit(c(1,1), "null") means two equal widths.
# widths = unit(c(1,2), "null") means the second width is twice the first width.

mat <- matrix(list(rect, polygon, text, nullGrob()), nrow = 2)
gMat <- gtable_matrix("gMat", mat,
	                    widths = unit(c(1, 1), "null"),
	                    heights = unit(c(1,1), "null"))
grid.newpage()
grid.draw(gMat)

## Another way - gtable
# Construct the table,
# then add grobs to selected cells within the table.
# Use gtable() function to construct the gtable;
# here, a 3 X 3 array of cells (note: three heights and three widths)
gt <- gtable(name = "myGtable",
	           heights = unit(c(1, 1, 1), "null"),
	           widths = unit(c(1, 1, 1), "null"))

gt <- gtable_add_grob(gt, text, t=1, l=1, name = text$name)
gt <- gtable_add_grob(gt, PolygonText, t=2, l=2, name = PolygonText$name)
gt <- gtable_add_grob(gt, myTree, t=3, l=3, name = myTree$name)
grid.newpage()
grid.draw(gt)

# Use gtable_add_grob() function to add the grobs:
#   gtable to which grob will be added;
#   grob to be added
#   t = top, l = left, b = bottom, and r = right indicate the cells where the grob will be added.
# If t = b, and/or l = r, there then b and r can be omitted.

## Diagram 1 (Slide 10) What the layout looks like.
library(grid)
pushViewport(viewport(width = .95, h = .95))
#grid.rect()
pushViewport(viewport(x = .5-1/3, y = .5+1/3, w =1/3, h = 1/3))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 1", "col 1"), collapse = "\n"))
upViewport()
pushViewport(viewport(x = .5, y = .5, w = 1/3, h = 1/3))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 2", "col 2"), collapse = "\n"))
upViewport()
pushViewport(viewport(x = .5+1/3, y = .5-1/3, w = 1/3, h = 1/3))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 3", "col 3"), collapse = "\n"))
upViewport()
pushViewport(viewport(x = .5, y = .5+1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5, y = .5-1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5-1/3, y = .5, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5-1/3, y = .5-1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5+1/3, y = .5, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5+1/3, y = .5+1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
upViewport()

## Variation 1
# The grob in the middle row is to span three columns.
gt <- gtable(name = "myGtable",
	           heights = unit(c(1, 1, 1), "null"),
	           widths = unit(c(1, 1, 1), "null"))

gt <- gtable_add_grob(gt, text, t=1, l=1, name = text$name)

#  To position PolygonText to span across the middle row, set l = 1 and r = 3
gt <- gtable_add_grob(gt, PolygonText, t=2, l=1, r=3, name = PolygonText$name)

gt <- gtable_add_grob(gt, myTree, t=3, l=3, name = myTree$name)
grid.newpage()
grid.draw(gt)

## Diagram 2 (Slide 14) - What the layout looks like.
library(grid)
pushViewport(viewport(width = .95, h = .95))
#grid.rect()
pushViewport(viewport(x = .5-1/3, y = .5+1/3, w =1/3, h = 1/3))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 1", "col 1"), collapse = "\n"))
upViewport()
pushViewport(viewport(x = .5+1/3, y = .5-1/3, w = 1/3, h = 1/3))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 3", "col 3"), collapse = "\n"))
upViewport()
pushViewport(viewport(x = .5-1/3, y = .5-1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5+1/3, y = .5+1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5, y = .5-1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5, y = .5+1/3, w = 1/3, h = 1/3))
grid.rect()
upViewport()
pushViewport(viewport(x = .5, y = .5, w = 1, h = 1/3))
grid.rect(gp = gpar(fill = "grey", col="red", lwd = 5))
grid.text(paste(c("row 2", "cols 1, 2, 3"), collapse = "\n"))
upViewport()
upViewport()

# Variation 2
# The centre cell is to have twice the width and twice the height of the other cells.
gt <- gtable(heights = unit(c(1, 2, 1), "null"), widths = unit(c(1, 2, 1), "null"))

gt <- gtable_add_grob(gt, text, t=1, l=1, name = text$name)
gt <- gtable_add_grob(gt, PolygonText, t=2, l=2, name = rect$name)
gt <- gtable_add_grob(gt, myTree, t=3, l=3, name = polygon$name)
grid.newpage()
grid.draw(gt)

## Diagram 3 (Slide 17) - What the layout looks like.
pushViewport(viewport(width = .95, h = .95))
pushViewport(viewport(x = .5-3/8, y = .5+3/8, w =1/4, h = 1/4))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 1", "col 1"), collapse = "\n"), gp = gpar(fontsize = 15))
upViewport()
pushViewport(viewport(x = .5, y = .5, w = 1/2, h = 1/2))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 2", "col 2"), collapse = "\n"), gp = gpar(fontsize = 15))
upViewport()
pushViewport(viewport(x = .5+3/8, y = .5-3/8, w = 1/4, h = 1/4))
grid.rect(gp = gpar(fill = "grey"))
grid.text(paste(c("row 3", "col 3"), collapse = "\n"), gp = gpar(fontsize = 15))
upViewport()
pushViewport(viewport(x = .5, y = .5+3/8, w = 1/2, h = 1/4))
grid.rect()
upViewport()
pushViewport(viewport(x = .5, y = .5-3/8, w = 1/2, h = 1/4))
grid.rect()
upViewport()
pushViewport(viewport(x = .5-3/8, y = .5, w = 1/4, h = 1/2))
grid.rect()
upViewport()
pushViewport(viewport(x = .5-3/8, y = .5-3/8, w = 1/4, h = 1/4))
grid.rect()
upViewport()
pushViewport(viewport(x = .5+3/8, y = .5, w = 1/4, h = 1/2))
grid.rect()
upViewport()
pushViewport(viewport(x = .5+3/8, y = .5+3/8, w = 1/4, h = 1/4))
grid.rect()
upViewport()
upViewport()

## By way of completeness - Doing the same using grid.
layout <- grid.layout(3, 3,
                     heights = unit(c(1, 2, 1), "null"),
                     widths = unit(c(1, 2, 1), "null"))
pushViewport(viewport(layout = layout))

pushViewport(viewport(layout.pos.col=1, layout.pos.row=1))
grid.draw(text)
upViewport()

pushViewport(viewport(layout.pos.col=1:3, layout.pos.row=2))
grid.draw(PolygonText)
upViewport()

pushViewport(viewport(layout.pos.col=3, layout.pos.row=3))
grid.draw(myTree)
upViewport(2)

# The main points
# Use the gtable_col(), gtable_row(), and gtable_matrix() to construct tables of grobs.
# Use gtable() to construct an empty gtable.
# Use gtable_add_grob() to add grobs to selected cell in the gtable.
# Selected cells using t = top, l = left, b = bottom, and r = right.
# Set cell sizes by setting widths and heights.

###############################################################
##
## Lecture 10: Exploring the gtable
##
##   Functions for exploring a gtable
##     gtable_show_layout
##     str
##     names
##       grobs
##       heights; widths
##       layout
##     grid.ls
##
###############################################################

# First, set up a gtable
library(gtable)
library(grid)

rect <- rectGrob(gp = gpar(fill = "orange"),
                  name = "gRect")

polygon <- polygonGrob(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0),
                        gp = gpar(fill = "burlywood3", lwd = 3),
                        name = "gPolygon")

text <- textGrob(label = "Learning gtable",
                  gp = gpar(cex = 1.2),
                  name = "gText")

PolygonText <- gTree(name = "gPolygonText", children = gList(polygon, text))

myTree <- gTree(name = "gMyTree", children = gList(rect, PolygonText))

gt <- gtable(name = "myGtable", heights = unit(c(1, 1, 1), "null"),
                                widths = unit(c(1, 1, 1), "null"))

gt <- gtable_add_grob(gt, text, t=1, l=1, name = text$name)
gt <- gtable_add_grob(gt, PolygonText, t=2, l=2, name = PolygonText$name)
gt <- gtable_add_grob(gt, myTree, t=3, l=3, name = myTree$name)
grid.newpage()
grid.draw(gt)

## Get a diagram of the gtable layout
gtable_show_layout(gt)

# The numbers in the cells are the row and column numbers.
# The red number and unit are the widths and heights.

## Structure of the gtable
str(gt)

# Note: Three grobs: gText, gPolygonText, and gMyTree
# gPolygonText contains two children: gPolygon and gText
# gMyTree contains two children: gRect and gPolygonText;
#    and gPolygonText in turn contains two children: gPolygon and gTex
# At the end: layout and widths. More later

## Components of the gtable
names(gt)

# grobs: A list of grobs - what type of grob, and its name.
# layout: A dataframe giving the position of each grob in the layout.
# widths: Size (number and unit) of each column of the layout.
# heights: Size (number and unit) of each row of the layout.
# respect: Parameter indicating whether dimensions are linked (fixed aspect ratio).
# colnames: Rows can be given names.
# rownames: Columns can be given names.
# name: Name of the whole table - defaults to "layout".
# gp: Graphics parameters, but they cannot be set via the gp slot for the gtable as a whole.
# vp: Viewport defining location, size and orientation of the gtable - Graphics parameters for the whole table can be set here.
# children: List of children - applies only to the grobs that have children.
# childrenOrder: Order in which children are drawn - applies only to the grobs that have children.

## What are the values for some of these components?
gt$name
gt$widths
gt$heights
gt$grobs

## A closer look at layout
gt$layout

# A dataframe.
# name:    The names of the grobs.
# z:       The order in which the grobs are drawn.
# clip:    Whether or not the grobs are clipped to their viewports.
#          Note: the default for gtable is "on".
# t,l,b,r: Locations of the grobs in the layout.
#          They should agree with t,l,b,r used to populate the gtable with grobs.
#          That is, they should agree with the values set in gtable_add_grob().

gt <- gtable(name = "myGtable",
         heights = unit(c(1, 1, 1), "null"), widths = unit(c(1, 1, 1), "null"))
gt <- gtable_add_grob(gt, text, t=1, l=1, name = text$name)

gt <- gtable_add_grob(gt, PolygonText,
           t=2, l=1, r=3,
           name = PolygonText$name)

gt <- gtable_add_grob(gt, myTree, t=3, l=3, name = myTree$name)

gtable_show_layout(gt)
gt$layout

## Use grid functions to explore the gtable.
# grid.ls() returns a list of grobs.
# Unfortunately, grid.ls sees just one grob.
grid.newpage()
grid.draw(gt)
grid.ls()

# Apply grid.force first,
# then grid.ls sees the grobs
grid.ls(grid.force())

## current.vpTree() returns the viewports
grid.newpage()
grid.draw(gt)
current.vpTree()

# Function to make the output of current.vpTree() more readable
# Call it like this ...
#   formatVPTree(current.vpTree())
formatVPTree <- function(x, indent=0) {
	  x = gsub("viewport\\[", "", x)
    x = gsub("\\]", "", x)
    end <- regexpr("[)]+,?", x)
    sibling <- regexpr(", ", x)
    child <- regexpr("[(]", x)
    if ((end < child || child < 0) && (end < sibling || sibling < 0)) {
        lastchar <- end + attr(end, "match.length")
        cat(paste0(paste(rep("  ", indent), collapse=""),
                   substr(x, 1, end - 1), "\n"))
        if (lastchar < nchar(x)) {
            formatVPTree(substring(x, lastchar + 1),
                         indent - attr(end, "match.length") + 1)
        }
    }
    if (child > 0 && (sibling < 0 || child < sibling)) {
        cat(paste0(paste(rep("  ", indent), collapse=""),
                   substr(x, 1, child - 3), "\n"))
        formatVPTree(substring(x, child + 1), indent + 1)
    }
    if (sibling > 0 && sibling < end && (child < 0 || sibling < child)) {
        cat(paste0(paste(rep("  ", indent), collapse=""),
                   substr(x, 1, sibling - 1), "\n"))
        formatVPTree(substring(x, sibling + 2), indent)
    }
}

formatVPTree(current.vpTree())

# The main points
# gtable_show_layout() returns a diagram of the layout of the gtable.
# str() returns the structure of the gtable: lists within lists.
# names() returns the names of the objects within the gtable.
#    gtable$names returns the names of the grobs.
#    gtable$widths; gtable$heights returns the widths and heights of the columns and rows.
#    gtable$layout returns a dataframe of layout information.
# grid.ls(grid.force()) - a grid function for getting the names of the grobs.
# current.vpTree() - a grid function for getting the names of the viewports.

###############################################################
##
## Lecture 11: A first go at editing gtable
##
##   Change the shape and layout of a given gtable
##    Adjusting widths, heights, and layout
##
###############################################################

# Three ways to think about editing a gtable:

#   1. Changing the shape or layout of a given table
#   2. Adding to or subtracting from a gtable
#   3. Editing the grobs that populate a gtable

#  This lecture: Changing width, height and layout parameters
#  to change the shape and layout of a given gtable.

# Lecture 12: Use gtable functions to add to or substract from a gtable.
# Lecture 13: Editing the grobs.

# Set up a gtable
library(gtable)
library(grid)

rect <- rectGrob(gp = gpar(fill = "orange"),
                  name = "gRect")

polygon <- polygonGrob(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0),
                        gp = gpar(fill = "burlywood3", lwd = 3),
                        name = "gPolygon")

text <- textGrob(label = "Learning gtable",
                  gp = gpar(cex = 1.2),
                  name = "gText")

PolygonText <- gTree(name = "gPolygonText", children = gList(polygon, text))

myTree <- gTree(name = "gMyTree", children = gList(rect, PolygonText))

gt <- gtable(name = "myGtable", heights = unit(c(1, 1, 1), "null"),
                                widths = unit(c(1, 1, 1), "null"))

gt <- gtable_add_grob(gt, text, t=1, l=1, name = text$name)
gt <- gtable_add_grob(gt, PolygonText, t=2, l=2, name = PolygonText$name)
gt <- gtable_add_grob(gt, myTree, t=3, l=3, name = myTree$name)
grid.newpage()
grid.draw(gt)

# Recall the objects:
#   widths and heights
#   layout
#
# In Lecture 10, I re-drew a gtable.
# That is not always possible.
# Here, I edit the gtable by adjusting:
#    width; heights
#    layout

# Consider these edits:
#   The middle cell, the cell that contains gPolygonText, is to have twice the height and twice the width of its surrounding cells;
#   The content of the middle cell, gPolygonText to extend across all three columns;
#   The content of the middle cell, gPolygonText to fill the whole table;
#   Swap the positions of gText and gMyTree.

## EDIT 1: widths and heights to change the size of the cell that contains a grob.
gt1 <- gt   # So I keep the original
gt1$heights
gt1$widths

# The second height and the second width need to be doubled.

gt1$heights[2] <- unit(2, "null")
gt1$widths[2] <- unit(2, "null")

grid.newpage()
grid.draw(gt1)

## EDIT 2: t, l, b, r to change the extent of a grob
# layout is a data frame - Indexing
gt2 <- gt    # So I keep the original
gt2$layout

gt2$layout[2, 2] <- 1
gt2$layout[2, 4] <- 3
gt2$layout

grid.newpage()
grid.draw(gt2)

## Alternative EDIT 2:
# gt$layout is a data frame -
# If the grobs have a name, select the grob using its name.
# Select appropriate t, l, b, r columns.
gt2 <- gt    # So I keep the original
gt2$layout

gt2$layout$name == "gPolygonText"

gt2$layout[gt2$layout$name == "gPolygonText", c("l", "r") ] <- c(1, 3)
gt2$layout

grid.newpage()
grid.draw(gt2)

# 2nd alternative EDIT 2:
# gt$layout is a data frame - subset to select the rows and columns,
# I use regular expression to select the row.
gt2 <- gt    # So I keep the original
gt2$layout

row <- grepl("Poly", gt2$layout$name)

gt2$layout[row, c("l", "r")] <- c(1, 3)
gt2$layout

grid.newpage()
grid.draw(gt2)

## Another EDIT 2: Change the order of printing
# gt$layout is a data frame - subset to select the rows and columns.
# I use regular expression to select the row.
gt3 = gt    # So I keep the original
gt3$layout

row = grepl("Tree", gt3$layout$name)

gt3$layout[row, c("t", "l")] <- c(1, 1)
gt3$layout

grid.newpage()
grid.draw(gt3)

# Consider column z in the layout.
gt3$layout[3, "z"] <- 0
grid.newpage()
grid.draw(gt3)

## EDIT 3:
# gt$layout is a data frame - subset to select the rows and columns,
# gPolygonText to occupy 3,3
# gMyTree to occupy 1,1

gt4 = gt    # So that I keep the original
gt4$layout

gt4$layout[grepl("gText", gt4$layout$name), c("t", "l", "b", "r")] <- 3
gt4$layout[grepl("Tree", gt4$layout$name), c("t", "l", "b", "r")] <- 1
gt4$layout

grid.newpage()
grid.draw(gt4)

## The main points
# Adjust values and units in \texttt{widths} and \texttt{heights} to change the size of cells.
# Adjust values for t, l, b, r in the layout data frame to change the extent of a particular grob.
# Adjust values for t, l, b, r in the layout data frame to change the position of a particular grob.
# Adjust value for z in the layout data frame to change the order in which grobs are drawn.
# Select the relevant rows and columns of the layout data frame using index notation.
# Select the relevant rows and columns of the layout data frame using names and/or regular expressions.

###############################################################
##
## Lecture 12: Adding to and subtracting from the gtable
##
## Adding rows and columns to a gtable
## Combining gtables
## Extracting grobs from a gtable,
## and putting them somewhere else in the gtable
##
###############################################################

# Modifying the table
# Editing function in gtable:

#   gtable_add_rows, gtable_add_cols: add rows and columns to the gtable
#   cbind, rbind - combine gtables
#   gtable_filter - extract cells

#   Indexing - select cells from a table - or drop cells from a table

#   Not a function but it would be good if there was one - delete grobs but not the cells

# Set up a gtable
library(gtable)
library(grid)

rect <- rectGrob(gp = gpar(fill = "orange"),
                  name = "gRect")

polygon <- polygonGrob(x=c(0, 0.5, 1, 0.5), y=c(0.5, 1, 0.5, 0),
                        gp = gpar(fill = "burlywood3", lwd = 3),
                        name = "gPolygon")

text <- textGrob(label = "Learning gtable",
                  gp = gpar(cex = 1.2),
                  name = "gText")

PolygonText <- gTree(name = "gPolygonText", children = gList(polygon, text))

myTree <- gTree(name = "gMyTree", children = gList(rect, PolygonText))

gt <- gtable(name = "myGtable", heights = unit(c(1, 1, 1), "null"),
                                widths = unit(c(1, 1, 1), "null"))

gt <- gtable_add_grob(gt, text, t=3, l=3, name = text$name)
gt <- gtable_add_grob(gt, PolygonText, t=2, l=2, name = PolygonText$name)
gt <- gtable_add_grob(gt, myTree, t=1, l=1, name = myTree$name)
grid.newpage()
grid.draw(gt)

## Adding rows and columns to the gtable

# Use the gtable_add_rows() function,
# or the gtable_add_cols() function.

# Parameters are:
#    The gtable to be modified;
#    The height of the row (or the width of the column);
#    Position in the table where the new row (or column) is to be added.

# The height is a unit vector - as before.
# So far, I used the null unit.
# All grid units are available:
#   absolute units such as: in, cm, mm, point;
#   relative units such as: null, npc, native;
#   units that adjust to the size of a grob, such as: grobwidth, strwidth, lines.

# Position is a number - the numbers you see in gtable_show_layout.
# The new row (or column) is added below (or to the right of) the position number.
# Exceptions: pos=0    new row added to the top (or the far left).
#             pos=-1   new row added to the bottom (or the far right).

gt1 <- gtable_add_rows(gt, unit(3, "lines"), 0)

gtable_show_layout(gt)   # Original
gtable_show_layout(gt1)  # Modified

gt$layout
gt1$layout

grid.newpage()
grid.draw(gt)

grid.newpage()
grid.draw(gt1)

# The new row is empty.
# Any grob can be added.
# I'll add a title - that is, a textGrob

# Title grob
Title <- textGrob("Some grobs in a gtable")

# Add Title grob to row 1
gt2 <- gtable_add_grob(gt1, Title, t = 1, l = 1, r = 3, name = "gTitle")

# Draw the gtable
grid.newpage()
grid.draw(gt2)

# The new row had its height set with "lines" unit.
# The height of a "line" is determined by fontsize and cex already in place in the table.
# I want the new row's height to adjust its height according to fontsize of the Title grob.

# A title, but the row it goes into adjusts to the title's height.
Title <- textGrob("Some grobs in a gtable",
               gp = gpar(fontface = "bold", fontsize = 18))

convertHeight(grobHeight(Title), "cm")

Title <- textGrob("Some grobs in a gtable",
               gp = gpar(fontface = "bold", fontsize = 40))

convertHeight(grobHeight(Title), "cm")

# A little extra space for the Title grob
padding <- unit(1, "lines")

# Create the grob to be added to the new row
Title <- textGrob("Some grobs in a gtable",
               gp = gpar(fontface = "bold", fontsize = 18))

# Add a new row to the gtable
gt1 <- gtable_add_rows(gt,
               heights = grobHeight(Title) + padding, 0)

# Add the new grob to the new row
gt2 <- gtable_add_grob(gt1, Title,
               t = 1, l = 1, r = 3, name = "gTitle")

# Draw the new gtable
grid.newpage()
grid.draw(gt2)

## A title that is itself a combinations of grobs - a rectangle and text.

# Create the separate grobs to be added to the new row
TitleText <- textGrob("Some grobs in a gtable",
            gp = gpar(fontface = "bold", fontsize = 18))
TitleRect <- rectGrob(gp = gpar(fill = "skyblue"))

# Combine the two
Title <- gTree(name = "gTitle",
             children = gList(TitleRect, TitleText))

padding <- unit(2.5, "lines")
# Add a new row to the gtable.
# But with some care.
# The Title grob doesn't have a height, or rather it has the default height.
# To set the height to the height of the text, I need to get the grob height of the text height.
gt1 <- gtable_add_rows(gt,  grobHeight(TitleText) + padding, 0)

# Add the new grob to the new row
gt2 <- gtable_add_grob(gt1, Title, t = 1, l = 1, r = 3, name = "gTitle")

# Draw the new gtable
grid.newpage()
grid.draw(gt2)

# Suppose the height needs to be a little larger; say twice the padding
# I could redraw the gtable with the new padding;
# or, use the gtable's height parameter to set the required height.
# Which height needs adjusting?
gt2$heights
# The first height.
gt2$heights[1] <- grobHeight(TitleText) + 2*padding
grid.newpage()
grid.draw(gt2)

## Extra for experts
# The title was centred within the blue rectangle.
# Another approach to title - the ggplot2 approach.
# Titles appear often in ggplot: plot titles, axis titles, tick mark labels, strip labels.
# In ggplot, titles have margins.
# And of course, the margins can differ.

# The text is set up as before
text_grob <- textGrob("Some grobs in a gtable", gp = gpar(fontface = "bold", fontsize = 18))

# There are three heights: upper and lower margins, and the height of the text.
# The upper margin is "1 lines", the lower margin is "2 lines".
# The three heights are combined - concatenated - in the sense of the c() function;
# but it's the unit.c() function that concatenates units.
heights <- unit.c(unit(1, "lines"), unit(1, "grobheight", text_grob), unit(2, "lines"))

# Some pure grid.
# Set up a column of three viewports.
# Recall from Lecture 9: a matrix of viewports can be set up using the grid.layout function;
# analogous to the gtable function.
vp <- viewport(layout = grid.layout(3, 1,    # 3 rows, 1 column
                   heights = heights), name = "vp1")

# The middle row, where the title text will appear, is named as 'child_vp'.
child_vp <- viewport(layout.pos.row = 2,    # select 2nd row
                     name = "vp2")

# I have set up a column of three viewports.
# But only the middle viewport will take the text.
# The upper and lower viewports, the margin viewports, will remain empty.

# Recall that the gTree function is used to set up parent-child structures for grobs.
# The gTree function can also set up parent-child structures for viewports.
#
# Analogous to children = gList() for parent-child grob structures,
# parent-child viewport structures are set up using: vp = vpTree();
# vpTree takes two arguments: the parent viewport, and the child viewport.

# One child grob (in gList); one child viewport (in vpList);
# thus the child grob is drawn in the child viewport.
# Also, the heights of the three viewports are set here.
# (For this drawing, it's not necessary to set the heights here in the gTree function.
# But ggplot does, and thus there are two places where the heights are set.)

TitleText <- gTree(children = gList(text_grob),
                   vp = vpTree(vp, vpList(child_vp)), heights = heights)

# Combine the TitleText with the blue rectangle, as before.
TitleRect <- rectGrob(gp = gpar(fill = "skyblue"))

Title <- gTree(name = "gTitle",
             children = gList(TitleRect, TitleText))

# Add a new row to the gtable
gt1 <- gtable_add_rows(gt,
               heights = sum(heights), 0)

# Add the new Title grob to the new row
gt1 <- gtable_add_grob(gt1, Title,
               t = 1, l = 1, r = 3, name = "gTitle")

grid.newpage()
grid.draw(gt1)

#  Using cbind, rbind to combine gtables

# When combining by columns (cbind), the two gtables must have the same number of rows.
# When combining by rows (rbind), the two gtables must have the same number of columns.
# Use the gt gtable constructed earlier.

# Consider row binding:
# The tables might have the same number of columns,
# but suppose the widths of the columns in the two tables differ.

# rbind aligns the two tables so that the widths are the same.

# Use the gt gtable constructed earlier.
# Set up a second version that has different widths
gt1 <- gt
gt1$widths <- unit(c(1, 3, 1), c("inches", "inches", "null"))
gt2 <- gt
gt2$widths <- unit(c(3, 1, 1), c("inches", "inches", "null"))
# Check the widths for the two tables
gt1$widths
gt2$widths

grid.newpage()
grid.draw(gt1)

grid.newpage()
grid.draw(gt2)

# Stack the two gtables, but use gt1's widths
gtFirst <- rbind(gt1, gt2, size = "first")
grid.newpage()
grid.draw(gtFirst)

# Stack the two gtables, but use gt'2 widths
gtLast <- rbind(gt1, gt2, size = "last")
grid.newpage()
grid.draw(gtLast)

# Stack the two gtables, but use maximum widths
gtMax <- rbind(gt1, gt2, size = "max")
grid.newpage()
grid.draw(gtMax)

## Set clipping - I haven't yet considered the 'clip' column in the layout data frame.
# Notice that the text no longer fits into the viewport set up for gPolygonText.
gtLast$layout
# That's because clip is set to "on".
# That is, any part of the grob that overflows the viewport is clipped.
# Turn clipping off, and we should see all the text.
# That is, allow the text to extend beyond the boundaries of the viewport.
gtLast$layout$clip <- "off"
grid.newpage()
grid.draw(gtLast)

##   Extract the content of a cell using gtable_filter.
# Why would I want to extract a grob?
# To move it somewhere else.
# To edit the grob then put it back into the gtable.
# But I deal with editing of grobs in the next lecture.

# Using the gt gtable constructed before
MiddleGrob <- gtable_filter(gt, "gPolygonText")

gtNew <- gtable_add_grob(gt, MiddleGrob, t = 2, l = 1)
gtNew <- gtable_add_grob(gtNew, MiddleGrob, t = 2, l = 3)

# Or, add the grobs as a list of grobs
 gtNew <- gtable_add_grob(gt, rep(list(MiddleGrob), 2), t = 2, l = c(1, 3))

grid.newpage()
grid.draw(gtNew)

# Notice I was a little lazy and didn't give the new grobs names when they entered the table.
# So they get default names.
gtNew$layout

# But I could have given them names
gtNew <- gtable_add_grob(gt, rep(list(MiddleGrob), 2), t = 2, l = c(1, 3),
            name = paste0("gPolygonText", c(1, 3)))
gtNew$layout

# Alternatively, I can select a cell and its contents using indexing.
# It works, but for complex gtables, it is better to use the grobs names
MiddleGrob <- gt[2,2]
grid.newpage()
grid.draw(MiddleGrob)

# Another alternative: select the grob from the list of grobs.
# Again it works, but for complex tables,
# it can be difficult finding the grob.
gt$grobs
# I want the second grob
MiddleGrob <- gt$grobs[[2]]
grid.newpage()
grid.draw(MiddleGrob)

## Drop cells from a table using indexing
# For instance, drop the middle column from gtNew
gtNew1 <- gtNew[, -2]
grid.newpage()
grid.draw(gtNew1)

# Suppose I want to delete the grob but not the cells.
# I need to drop the grob from the list of grobs,
# AND I need to drop the appropriate row from the layout,

gtNew$grobs
gtNew$layout

gtNew2 <- gtNew
gtNew2$grobs <- gtNew2$grobs[-2]
gtNew2$layout <- gtNew2$layout[-2, ]

grid.newpage()
grid.draw(gtNew2)

# Using grep to select the position of the grob:
# 2nd in the list of grobs, 2nd in the layout data frame;
# grep returns a vector of indices.
gtNew3 <- gtNew

pos <- gtNew3$layout$name == "gPolygonText"
pos

gtNew3$grobs <- gtNew3$grobs[!pos]
gtNew3$layout <- gtNew3$layout[!pos, ]

gtNew3$grobs
gtNew3$layout

grid.newpage()
grid.draw(gtNew3)

# But, to delete a grob but not the cells,
# it's probably easier to replace a grob with the nullGrob().

gtNew4 <- gtNew

pos <- gtNew4$layout$name == "gPolygonText"
pos

gtNew4$grobs[[which(pos)]] <- nullGrob()

gtNew4$grobs
gtNew4$layout

grid.newpage()
grid.draw(gtNew4)

# or

gtNew4 <- gtNew

pos <- gtNew4$layout$name == "gPolygonText"
pos

gtNew4$grobs[pos] <- list(nullGrob())

gtNew4$grobs
gtNew4$layout

grid.newpage()
grid.draw(gtNew4)

###############################################################
##
## Lecture 13: Editing the grobs that populate a gtable
##
##  Editing using grid functions
##  Editing the slot within a gtable
##  Exracting the grob first, then editing
##  Push to a viewport then editing
##
###############################################################

# Grobs
# Some with hierarchical structures
# within a gtable

# Method 1. Edit using grid edit functions (using lessons learned in Lecture 7)
# Method 2. Edit the slot within the gtable
# Method 3. Extract the grob, edit it, then put it back
# Method 4. Push to the viewport that contains the grob, then edit

# First, create the gtable
library(gtable)
library(grid)

rect <- rectGrob(gp = gpar(fill = "orange"),
                  name = "gRect")

polygon <- polygonGrob(x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0),
                        gp = gpar(fill = "burlywood3", lwd = 3),
                        name = "gPolygon")

text <- textGrob(label = "Learning gtable",
                  gp = gpar(cex = 1.2),
                  name = "gText")

PolygonText <- gTree(name = "gPolygonText", children = gList(polygon, text))

myTree <- gTree(name = "gMyTree", children = gList(rect, PolygonText))

gt <- gtable(name = "myGtable", heights = unit(c(1, 1, 1), "null"),
                                widths = unit(c(1, 1, 1), "null"))

gt <- gtable_add_grob(gt, text, t=3, l=3, name = text$name)
gt <- gtable_add_grob(gt, PolygonText, t=2, l=2, name = PolygonText$name)
gt <- gtable_add_grob(gt, myTree, t=1, l=1, name = myTree$name)
grid.newpage()
grid.draw(gt)

## Remember from Lecture 10:
# grid.ls() shows the list of grobs,
# but grid.ls() sees only one grob in a gtable.
# Apply grid.force() first, then the grobs are visible to grid.ls()

## Also, recall from Lecture 4:
# There two versions of the commands for obtaining grobs:
#   *Grob     - Creates a graphic object but does not produce output
#    grid.*   - Creates a graphic object and produces output

# Same goes for the editing function:
#    editGrob   - Edits the object but does not produce output
#    grid.edit  - Edits the object and outputs the result

# That is,
# I can edit on-screen, using grid.edit

# Or, I can edit off-screen, using editGrob.

### Method 1. Edit using grid edit functions (using lessons learned in Lecture 7)

# It treats the gtable as if it is a grid object,
# with grobs arranged in hierarchical structures.
# I need to be able to name the relevant grob;
# and I need the grobs to be visible to the editing function.

## First, some on-screen editing.

gt1 <- gt
grid.newpage()
grid.draw(gt1)

# Editing the grobs within the gtable
grid.ls(grid.force())

grid.edit("gPolygonText.2-2-2-2", gp = gpar(col = "red"))

## Tedious and prone to error having to type full name

grid.newpage(); grid.draw(gt1)
grid.force()
grid.edit("gPolygonText", grep = TRUE, gp = gpar(col = "red"))

## There are two polygonTexts in the gtable.
# Suppose I want the colour for both to be set to "red"

grid.newpage(); grid.draw(gt1)
grid.force()
grid.edit("gPolygonText", grep = TRUE, global = TRUE, gp = gpar(col = "red"))

## grid.gedit function - g for global and g for grep

grid.newpage(); grid.draw(gt1)
grid.force()
grid.gedit("gPolygonText", gp = gpar(col = "red"))

## But what if I want the second PolygonText to be coloured "red".
# I need to provide a path to the relevant grob

grid.newpage(); grid.draw(gt1)
grid.force()
grid.edit("gMyTree.1-1-1-1::gPolygonText", gp = gpar(col = "red"))

## grid.gedit works with the path.
# and the path can be generated in the gPath() function
grid.newpage(); grid.draw(gt1)
grid.force()
grid.gedit(gPath("gMyTree", "Poly"), gp = gpar(col = "red"))

## Now change the line width
grid.gedit(gPath("gMyTree", "Poly"), gp = gpar(lwd = 20))

# The command has no effect because the change to the gp slot is applied to gPolygonText
# But when I set up gPolygonText,
# line width was applied to one of its children, to gPolygon.
# Remember the rule: A graphic parameter applied to a parent
# would normally flow through to the children
# except for the children that already have that parameter set.
# I need to get to the gPloygon grob to change the line width.
# The path begins with gMyTree,
# then proceeds to gPolygonText,
# on its way to gPolygon.
# In the code below, grid.gedit means partial names will work:
#    The first "Poly" stands for "gPolygonText",
#    The second "Poly" stands for "gPolygon".
# These are the names of the child or grand child of "gMyTree", at the head of the tree

grid.gedit(gPath("gMyTree", "Poly", "Poly"), gp = gpar(lwd = 20))

# All this so far is editing on-screen.
# What about editing off-screen
# Because we're dealing with a gtable,
# the grobs in the gtable are invisible to editing functions.
# Apply grid.force().

gt1 <- gt
grid.ls(grid.force(gt1))  # list of grobs

# Apply the two edits:
#    In gMyTree, change colour of text and line to red
#    and increase line width to 40

gt1 <- editGrob(grid.force(gt1), gPath("gMyTree", "Poly"), grep = TRUE,
         gp = gpar(col = "red"))

gt1 <- editGrob(grid.force(gt1), gPath("gMyTree", "Poly", "Poly"), grep = TRUE,
         gp = gpar(lwd = 20))

grid.newpage(); grid.draw(gt1)

### Method 2. Edit a slot within the gtable

grid.newpage()
grid.draw(gt)

# I want to set the colour of the text in PolygonText to white.
# Within the gt gtable there is a gp slot for the text child of the PolygonText grob.
# Can it be found?
# It can found. But if the gtable is complex,
# it will be tedious finding the path to the relevant slot -
# as shown in what follows.

gt2 <- gt

# The gp slot will be in the grobs
gt2$grobs

# The PolygonText grob is the second grob
gt2$grobs[[2]]

# I need to see the structure
str(gt2$grobs[[2]])
# gText is in the children
gt2$grobs[[2]]$children

# Two children. gText is the required child
gt2$grobs[[2]]$children$gText

# I need to see the structure
str(gt2$grobs[[2]]$children$gText)

# I set colour in the gp slot. I need to gp slot
gt2$grobs[[2]]$children$gText$gp

# cex is already set. I need to set col to "white"
gt2$grobs[[2]]$children$gText$gp$col <- "white"

# Draw the modified gtable
grid.newpage()
grid.draw(gt2)

### An aside:
# Why go all the way to the gp slot of gText?
# Why not change colour at the gp slot for gPolygonText?
# Because that would change not only the colour of the text,
# but also the colour of the ploygon's boundary.
# Remember: gpar parameters flow down to all children
# (provided the child does not already have that parameter set).
gt2 <- gt
gt2$grobs[[2]]$gp = gpar(col = "white")

grid.newpage()
grid.draw(gt2)

# Method 3. Extract the grob, edit it, then put it back
# Do some editing on PolygonText grob
# Change the font colour to white

# Get the grob
# Two ways to get the grob

Grob1 <- gtable_filter(gt, "gPolygonText")

Grob2 <- gt$grobs[[grep(pattern = "gPolygonText", gt$layout$name)]]

Grob3 <- gt[2, 2]

# Problem is, they are not the same
# They are all grobs
is.grob(Grob1); is.grob(Grob2); is.grob(Grob3)

# But the first and third are also a gtables
is.gtable(Grob1); is.gtable(Grob2); is.gtable(Grob3)
# For want of better terminology, Grob1 and Grob3 are gtable grobs,
# Grob2 is a pure grob, or a grid grob

## In the discussion to follow, Grob3 behaves in the same way as Grob1. So, only
## Grob1 and Grob2 are considered in the Lecture 13. But I will include Grob3 here.

# Don't forget to apply grid.force() so that the grobs are visible to grid.ls()
grid.newpage()
grid.draw(Grob1)
grid.ls(grid.force())

grid.newpage()
grid.draw(Grob3)
grid.ls(grid.force())

# Grob2 is not a gtable.
# Therefore, grid.ls() (without grid.force) sees all the grobs
grid.newpage()
grid.draw(Grob2)
grid.ls()

# The same applies when obtaining the
# structure of an off-screen gtable object.

grid.ls(grid.force(Grob1))
grid.ls(grid.force(Grob3))
grid.ls(Grob2)

# So, take care when editing grobs.
# If the grob is a gtable,
# apply grid.force first.

# If the grob is a pure grid grob,
# There is no need to apply grid.force
# but no harm if grid.force is applied

### Start again Method 1.
## Edit off-screen
EGrob1 <- editGrob(grid.force(Grob1), "gText", gp = gpar(col = "white"))
grid.newpage()
grid.draw(EGrob1)

EGrob2 <- editGrob(Grob2, "gText", gp = gpar(col = "white"))
grid.newpage()
grid.draw(EGrob2)

EGrob3 <- editGrob(grid.force(Grob3), "gText", gp = gpar(col = "white"))
grid.newpage()
grid.draw(EGrob3)

## Getting the edited grob back into the original gtable
gt3 <- gt
pos <- grep(pattern = "gPolygonText", gt3$layout$name)
gt3$grobs[[pos]] = EGrob3
grid.newpage()
grid.draw(gt3)

## Edit on-screen: grid.edit()
# Apply grid.force to gtable grobs
# gtable
grid.newpage()
grid.draw(Grob1)
grid.force()
grid.edit("gText", gp = gpar(col = "white"))

# Not a gtable
grid.newpage()
grid.draw(Grob2)
grid.edit("gText", gp = gpar(col = "white"))

# gtable
grid.newpage()
grid.draw(Grob3)
grid.force()
grid.edit("gText", gp = gpar(col = "white"))

# Putting the edited grob back into the original gtable
EGrob3 <- grid.grab()
gt3 <- gt
pos <- grep(pattern = "gPolygonText", gt3$layout$name)
gt3$grobs[[pos]] = EGrob3
grid.newpage()
grid.draw(gt3)

# Method 4. Push to the viewport, then add grobs to the viewport
# It's not editing a grob
# It adds grobs to a viewport
gt4 <- gt
grid.newpage()
grid.draw(gt4)

# Get the names of the viewports.
# Recall: The format function makes the list a little easier to read
formatVPTree(current.vpTree())

# The PolygonText grob is in the PolygonText viewport
# Move "down" to that viewport
downViewport("gMyTree.1-1-1-1")

grid.rect(width = 0.7, height = 0.2, gp = gpar(fill = "red"))
grid.text("Learning gtable", gp = gpar(col = "white", cex = 1.2))

upViewport(0)

Tree <- as.character(current.vpTree())
text <- "tree"
pattern <- paste0("^.*\\[(.*", text, ".*?)\\].*$")
Tree <- gsub(pattern, "\\1", Tree, ignore.case = TRUE)
downViewport(Tree)

grid.rect(width = 0.7, height = 0.2, gp = gpar(fill = "red"))
grid.text("Learning gtable", gp = gpar(col = "white", cex = 1.2))

upViewport(0)

# Revisiting Method 3:
# Use gtable_add_grob to put the edited grob back into the gtable.
# A lot of the time it doesn't matter that the original remains.
# But sometimes, it does.
# If the edited version does not exactly overlap the original,
# then the original can show through.
gt5 <- gt
pos <- grep(pattern = "Poly", gt5$layout$name)
Grob <- gt5$grobs[[pos]]
Grob <- editGrob(Grob, vp = viewport(angle = 30))
gt5 <- gtable_add_grob(gt5, Grob, t = 2, l = 2)

grid.newpage()
grid.draw(gt5)

# If it matters that the original shows through,
# remove the original.
gt5 <- gt
pos <- grep(pattern = "Poly", gt5$layout$name)

Grob <- gt5$grobs[[pos]]
Grob <- editGrob(Grob, vp = viewport(angle = 30))

gt5$grobs[[pos]] <- nullGrob()

gt5 <- gtable_add_grob(gt5, Grob, t = 2, l = 2)
grid.newpage()
grid.draw(gt5)

#### Finished Section 3


#' Fisher's test to measure overlap between two sets of intervals.
#'
#' Calculate Fisher's test on number of intervals that are shared and unique
#' between two sets of `x` and `y` intervals.
#'
#' @param x [ivl_df]
#' @param y [ivl_df]
#' @param genome [genome_df]
#'
#' @template stats
#'
#' @family interval statistics
#'
#' @seealso
#'   \url{https://bedtools.readthedocs.io/en/latest/content/tools/fisher.html}
#'
#' @return [ivl_df]
#'
#' @examples
#' genome <- read_genome(valr_example('hg19.chrom.sizes.gz'))
#'
#' x <- bed_random(genome, n = 1e4, seed = 1010486)
#' y <- bed_random(genome, n = 1e4, seed = 9203911)
#'
#' bed_fisher(x, y, genome)
#'
#' @export
bed_fisher <- function(x, y, genome) {
  x <- check_interval(x)
  y <- check_interval(y)
  genome <- check_genome(genome)

  # number of intervals
  n_x <- nrow(x)
  n_y <- nrow(y)

  # union of intervals (i.e. total bases covered)
  union_x <- interval_union(x)
  union_y <- interval_union(y)

  # mean interval sizes
  mean_x <- union_x / n_x
  mean_y <- union_y / n_y

  # heuristic from bedtools fisher.cpp
  mean_total <- mean_x + mean_y

  # number of intersections (`n11` in fisher.cpp)
  isect <- bed_intersect(x, y)
  n_i <- nrow(isect)

  # x, not y (`n12` in fisher.cpp)
  n_x_only <- max(0, n_x - n_i)
  # y, not x (`n21` in fisher.cpp)
  n_y_only <- max(0, n_y - n_i)

  genome_size <- sum(as.numeric(genome$size))

  # estimated total intervals (`n22_full`)
  total_est <- round(max(
    n_i + n_x_only + n_y_only,
    genome_size / mean_total
  ))

  # estimate n for neither x nor y (`n22`)
  not_est <- total_est - n_i - n_x_only - n_y_only

  fisher_mat <- matrix(
    c(n_i, n_x_only, n_y_only, not_est),
    nrow = 2,
    dimnames = list(
      "in y?" = c("yes", "no"),
      "in x?" = c("yes", "no")
    )
  )

  stat <- stats::fisher.test(fisher_mat)
  broom::tidy(stat)
}

#' @noRd
interval_union <- function(x) {
  res <- bed_merge(x)
  res <- mutate(res, .size = end - start)

  sum(res$.size)
}


first.year<- 1963                #first year on plot, negative value means value defined by data
last.year<- 2100               #last year on plot

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

my.dev<-'screen'   # output device:  'screen', 'wmf', 'png', 'pdf'

cleanup()

#dat1<-Read.summary.data(read.init.function=F)
dat<-dat1
dat<-droplevels(subset(dat,Year %in% c(first.year:last.year) & Quarter==1  & M2> -1))
dat$Nage<-dat$N*dat$Age
dat$Nwest<-dat$N*dat$west

dat<-aggregate(cbind(N,Nwest,Nage)~Species+Year+Species.n,sum,na.rm=T,data=dat)
dat$Mwest<-dat$Nwest/dat$N
dat$Mage<-dat$Nage/dat$N

nox<-4; noy<-3;
noxy<-nox*noy

dev<-'screen'
plot_Mage<-function(x,header='Species') {
  cleanup();newplot(dev,nox,noy); i<-0
  for (sp in seq(first.VPA,nsp)) {
    if (i==noxy) {newplot(dev,nox,noy); i<-0 }
     a<-droplevels(subset(x,sp==Species.n))
     plot(x=a$Year,y=a$Mage,main=a[1,header],xlab=NULL,ylab='Mean age')
    i<-i+1
  }
}

plot_Mage(dat)

by(dat,dat$Species.n,

dat$group1<-'all'
dat[dat$Species %in% c('Cod','Whiting','Haddock','Saithe'),'group1']<-'large gadoids'
dat[dat$Species %in% c('Plaice','Sole'),'group1']<-'flatfish'
dat[dat$Species %in% c('Sandeel','Nor. pout','Sprat'),'group1']<-'industrial'

dat<-aggregate(cbind(N,Nwest,Nage)~Year+group1,sum,na.rm=T,data=dat)
dat$Mwest<-dat$Nwest/dat$N
dat$Mage<-dat$Nage/dat$N

plot_Mage(dat,header='group1')


## Import Data
raw_dat <- read.table("Matrix.csv", header = T, row.names = 1, sep = " ")
samples_scirep <- read.table("scirep_classes.txt", sep = ",", header = T)
batch_dat <- read.table("scirep_batch.txt", header = T, row.names = 1, sep = ",")

reference_gene <- c("ENST00000408438.1", "ENST00000385271.1", "ENST00000607334.3", "ENST00000385059.1",
                    "ENST00000362134.1", "ENST00000385245.1", "ENST00000385045.1", "ENST00000362117.1",
                    "ENST00000384832.1", "ENST00000579846.3")

## Remove NA and less-transcript gene
dat <- na.omit(raw_dat)
dat <- dat[which(rowSums(dat) > 100),]

## Remove duplicate samples
dat <- dat[,-ncol(dat)]
dat <- dat[,-191]
nrow(dat)
head(dat)

## Necessary Library
library(SCnorm)
library(EDASeq)
library(RUVSeq)
library(sva)
library(scRNA.seq.funcs)
library(dplyr)
library(ggplot2)
library(reshape2)

## CPM & RUVs
total_gene <- apply(dat, 2, sum)
CPM_dat <- t( t(dat) * 1000000 / total_gene )

scirepcpm <- log(CPM_dat + 0.001)
scIdx <- matrix(-1, ncol = max(table(samples_scirep$label)), nrow = 2)
tmp1 <- which(samples_scirep$label == "Colorectal Cancer")
scIdx[1, 1:length(tmp1)] <- tmp1
tmp2 <- which(samples_scirep$label == "Healthy Control")
scIdx[2, 1:length(tmp2)] <- tmp2
cIdx <- rownames(scirepcpm)
ruvs <- RUVs(as.matrix(scirepcpm), cIdx, k = 10, scIdx = scIdx, isLog = T)

CPM_RUV_dat <- exp(ruvs$normalizedCounts)
write.table(CPM_RUV_dat, "CPM_RUVs_Exp_Matrix.txt", col.names = T, row.names = T, sep = "\t")

## CPM & Combat

#total_gene <- apply(dat, 2, sum)
#CPM_dat <- t( t(dat) * 1000000 / total_gene )

mat <- as.data.frame(CPM_dat)
batch_info <-read.table("scirep_batch.txt",sep=',',row.names=1,header=T,check.names = FALSE)
batchname <-toString(names(batch_info)[1])
batch_info=batch_info[names(mat),]
mod <- model.matrix(~ 1, data = batch_info)
if (!dim(mat)[2]==dim(batch_info)[1])
    stop('sample numbers in batch info and expression matrix should be same')
combat <- ComBat(
    dat = log(mat+0.001),
    batch = factor(batch_info[,1]),
    mod = mod,
    par.prior = TRUE,
    prior.plots = FALSE
)
mat <- exp(combat)

write.table(mat, "CPM_Combat_Exp_Matrix.txt", col.names = T, row.names = T, sep = "\t")

## SCnorm & Combat

Conditions = rep(1, dim(dat)[2])
DataNorm <- SCnorm(Data = dat, Conditions = Conditions, PrintProgressPlots = TRUE, NCores = 4)
Normalized_Data <- results(DataNorm)

mat <- as.data.frame(Normalized_Data)
batch_info <-read.table("scirep_batch.txt",sep=',',row.names=1,header=T,check.names = FALSE)
batchname <-toString(names(batch_info)[1])
batch_info=batch_info[names(mat),]
mod <- model.matrix(~ 1, data = batch_info)
if (!dim(mat)[2]==dim(batch_info)[1])
    stop('sample numbers in batch info and expression matrix should be same')
combat <- ComBat(
    dat = log(mat+0.001),
    batch = factor(batch_info[,1]),
    mod = mod,
    par.prior = TRUE,
    prior.plots = FALSE
)
mat <- exp(combat)

write.table(mat, "SCnorm_Combat_Exp_Matrix.txt", col.names = T, row.names = T, sep = "\t")

## SCnorm & RUVs

#Conditions = rep(1, dim(dat)[2])
#DataNorm <- SCnorm(Data = dat, Conditions = Conditions, PrintProgressPlots = TRUE, NCores = 4)
#Normalized_Data <- results(DataNorm)

scirepcpm <- log(Normalized_Data + 0.001)
scIdx <- matrix(-1, ncol = max(table(samples_scirep$label)), nrow = 2)
tmp1 <- which(samples_scirep$label == "Colorectal Cancer")
scIdx[1, 1:length(tmp1)] <- tmp1
tmp2 <- which(samples_scirep$label == "Healthy Control")
scIdx[2, 1:length(tmp2)] <- tmp2
cIdx <- rownames(scirepcpm)
ruvs <- RUVs(as.matrix(scirepcpm), cIdx, k = 10, scIdx = scIdx, isLog = T)

SC_RUV_dat <- exp(ruvs$normalizedCounts)
write.table(SC_RUV_dat, "SCnrm_RUVs_Exp_Matrix.txt", col.names = T, row.names = T, sep = "\t")

## Process Batch Effect Information

temp <- as.data.frame(t(dat))
temp$sum <- apply(temp, 1, sum)
sample_dat <- temp[order(rownames(temp)), ]
batch_dat <- batch_dat[order(rownames(batch_dat)),]
batch_dat$names <- rownames(batch_dat)
sample_dat$names <-  rownames(sample_dat)

batch_info_dat <- merge(batch_dat, sample_dat, all=FALSE)
rownames(batch_info_dat) <- batch_info_dat$names
batch_info_dat = batch_info_dat[, -1]

## Visualize Batch Effect_1

batch_info_dat$RNA.Isolation.batch <- factor(batch_info_dat$RNA.Isolation.batch)

pdf("RNA_Isolation_batch.pdf", 7, 7)
ggplot(data=batch_info_dat, aes(x = RNA.Isolation.batch, y = sum, col = RNA.Isolation.batch)) +
    geom_boxplot() +
    labs(x = "RNA Isolation batch", y = "Total gene count")
dev.off()

## Visualize Batch Effect_2

batch_info_dat$library.prepration.day <- factor(batch_info_dat$library.prepration.day)

pdf("library_prepration_day.pdf", 7, 7)
ggplot(data=batch_info_dat, aes(x = library.prepration.day, y = sum, col = library.prepration.day)) +
    geom_violin(data=batch_info_dat, aes(x = library.prepration.day, y = sum, col = library.prepration.day, fill = library.prepration.day)) +
    labs(x = "library prepration day", y = "Total gene count")
dev.off()

## Visualize Batch Effect_3

batch_info_dat$gel.cut.size.selection <- factor(batch_info_dat$gel.cut.size.selection)

pdf("gel_cut_size_selection.pdf", 7, 7)
ggplot(data=batch_info_dat, aes(x = gel.cut.size.selection, y = sum, col = gel.cut.size.selection)) +
    geom_boxplot() +
    labs(x = "gel cut size selection", y = "Total gene count")
dev.off()

## Reference gene

reference_gene_matrix <- dat[match(reference_gene, rownames(dat)),]
reference_gene_matrix <- na.omit(reference_gene_matrix)
rownames(reference_gene_matrix) <- c('MIR1228', 'MIR16-1', 'MIR16-2', 'MIR21', 'MIR23A', 'MIR23B', 'MIR23C', 'MIR451A', 'MIR15A', 'MIR15B')

temp <- melt(t(reference_gene_matrix))
temp$Var2 <- factor(temp$Var2)
temp$value <- log(temp$value)

pdf("Reference_Gene_count(log).pdf", 7, 7)
ggplot(data=temp, aes(x = Var2, y = value, fill = Var2)) +
    geom_violin() +
    labs(x = "Reference gene", y = "log of gene count")
dev.off()

rowSums(reference_gene_matrix)

head(Normalized_Data)

scirepcpm <- log(Normalized_Data + 0.001)

head(SC_RUV_dat, n = 20)


library(glmnet)
set.seed(19875)

# take significant features
sign.feats = unique(strsplit(paste(na.omit(read.table('./tested_sign_features(transcript).txt',
                        sep ='\t', header = 1, row.names = 1, stringsAsFactors = F)$Confirmed),
                        collapse = ', '),split=', ')[[1]])

# make a db [samples]x[feats/age/tissue(?)]
samp.annot = read.table('./subj_sample_annot.txt', stringsAsFactors = F, sep = '\t', header = 1, row.names = 1)
samp.annot = samp.annot[substr(rownames(samp.annot),1,1) == 'G',]
samp.annot$Age = as.numeric(paste0(substr(samp.annot[['Age']], 1, 1),'5'))
samp.annot$Tissue = gsub(' ', '', samp.annot$Tissue)

df = as.data.frame(matrix(ncol = length(sign.feats) + 3, nrow = nrow(samp.annot)))
colnames(df) = c('Age', 'Tissue', 'Sex', sign.feats)
rownames(df) = rownames(samp.annot)

df['Sex'] = samp.annot['Sex']
df['Age'] = samp.annot['Age']
df['Tissue'] = samp.annot['Tissue']

# cut data for tweaking purposes
# df = df[1:5000, 1:500]

for (t in unique(samp.annot$Tissue)){
  print(t)
  print(which(unique(samp.annot$Tissue) == t))
  tis.samp = read.table(paste0('./v7/tissue_samples/samples_from_',t,'.txt'),
                        sep = '\t', header = 1, row.names = 1, stringsAsFactors = F,
                        check.names=F)
  tis.samp$gene_id = NULL
  tis.samp = as.data.frame(t(tis.samp[rownames(tis.samp) %in% sign.feats,]))

  df[rownames(tis.samp), colnames(tis.samp)] <- tis.samp

  na_count <- apply(df[df['Tissue'] == t,], 1, function(x) sum(is.na(x)))
  df = df[!rownames(df) %in% names(na_count[na_count>0]), ]

}

tis.presented = as.data.frame(table(df$Tissue))
tis.presented = as.character(tis.presented[tis.presented$Freq > 200,]$Var1)
# tis.presented = c(
#   "Adipose-Subcutaneous",
#   "Adipose-Visceral(Omentum)",
#   "Artery-Aorta",
#   "Artery-Tibial",
#   "Breast-MammaryTissue",
#   "Cells-Transformedfibroblasts",
#   "Colon-Sigmoid",
#   "Colon-Transverse",
#   "Esophagus-GastroesophagealJunction",
#   "Esophagus-Mucosa",
#   "Esophagus-Muscularis",
#   "Heart-AtrialAppendage",
#   "Heart-LeftVentricle",
#   "Lung",
#   "Muscle-Skeletal",
#   "Nerve-Tibial",
#   "Pancreas",
#   "Skin-NotSunExposed(Suprapubic)",
#   "Skin-SunExposed(Lowerleg)",
#   "Stomach",
#   "Testis",
#   "Thyroid",
#   "WholeBlood"
# )
df = df[df$Tissue %in% tis.presented,]

# Even out age groups
n = 500
ages = unique(df$Age)
df_downsamp = df[0,]
for (a in ages){
  ids = rownames(df[df$Age == a,])[1:min(n,length(df[df$Age == a,2]))]
  df_downsamp = rbind(df_downsamp,df[((df$Age == a)&(rownames(df) %in% ids)),])
}

# write.table(df,'./v7/subset_v7.txt', sep = '\t', quote = F)
rm(t,i,j,na_count)

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

n = nrow(df_downsamp)
m = ncol(df_downsamp)
train_rows <- sample(1:n, .66*n)
df.train <- df_downsamp[train_rows, ]
df.test <- df_downsamp[-train_rows, ]

fit.lasso <- glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, family="gaussian", alpha=1)
fit.ridge <- glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, family="gaussian", alpha=0)
fit.elnet <- glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, family="gaussian", alpha=.5)

# fit.lasso.cv <- cv.glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, type.measure="mse", family="gaussian", alpha=1)
# fit.ridge.cv <- cv.glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, type.measure="mse", family="gaussian", alpha=0)
# fit.elnet.cv <- cv.glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, type.measure="mse", family="gaussian", alpha=0.5)

for (i in 0:10) {
  assign(paste("fit", i, sep=""), cv.glmnet(as.matrix(df.train[,-c(1,2,3)]), df.train$Age, type.measure="mse",
                                            alpha=i/10,family="gaussian"))
}

par(mfrow=c(3,2))

plot(fit.lasso, xvar="lambda")
plot(fit10, main="LASSO")

plot(fit.ridge, xvar="lambda")
plot(fit0, main="Ridge")

plot(fit.elnet, xvar="lambda")
plot(fit5, main="Elastic Net")

yhat0 <- predict(fit0, s=fit0$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat1 <- predict(fit1, s=fit1$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat2 <- predict(fit2, s=fit2$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat3 <- predict(fit3, s=fit3$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat4 <- predict(fit4, s=fit4$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat5 <- predict(fit5, s=fit5$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat6 <- predict(fit6, s=fit6$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat7 <- predict(fit7, s=fit7$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat8 <- predict(fit8, s=fit8$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat9 <- predict(fit9, s=fit9$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))
yhat10 <- predict(fit10, s=fit10$lambda.1se, newx=as.matrix(df.test[,-c(1,2,3)]))

mse0 <- mean((df.test$Age - yhat0)^2)
mse1 <- mean((df.test$Age - yhat1)^2)
mse2 <- mean((df.test$Age - yhat2)^2)
mse3 <- mean((df.test$Age - yhat3)^2)
mse4 <- mean((df.test$Age - yhat4)^2)
mse5 <- mean((df.test$Age - yhat5)^2)
mse6 <- mean((df.test$Age - yhat6)^2)
mse7 <- mean((df.test$Age - yhat7)^2)
mse8 <- mean((df.test$Age - yhat8)^2)
mse9 <- mean((df.test$Age - yhat9)^2)
mse10 <- mean((df.test$Age - yhat10)^2)

# nuzhen downsampling!

beta = fit.elnet$beta[, which(fit6$lambda == fit6$lambda.1se)]
beta = beta[beta != 0]


library(ggplot2)
library(reshape2)
library(sandwich)
library(lmtest)
library(tseries)
library(dplyr)
library(urca)
library(forecast)
library(data.table)
library(stargazer)
library(xtable)

rm(list=ls())
gc()

w_frac <- 80

## load the data
load("forecast80.RData")
load("subset.RData")

p <- 12
h <- 12

frac <- w_frac/100

# in-sample and out-of-sample periods
n <- nrow(subset_dt)
R <- round(frac*n)
P <- n-R-h+1

subset_dt$DATE[c(h+p+1,R)]

c_num <- ncol(subset_dt)-1

c_names <- names(subset_dt)[1:c_num]

commodities <- c("Aluminum","Bananas","Cotton","Diammonium Phosphate","Fishmeal",
                 "Groundnut Oil","Groundnuts","Gold","Hides","Lamb",
                 "Lead","Soft Logs","Oranges","Olive Oil","Platinum",
                 "Plywood","Palm Oil","Rice","Rapeseed Oil","Rubber",
                 "Soybean Oil","Hard Sawnwood","Soft Sawnwood","Uran","Urea")

multistep_dt <- data.table(commodities,t(round(apply(array_pval,c(1,3),mean),3)))
colnames(multistep_dt)[-1] <- paste0("h",c(1:12))

rmsfe_mean <- array(dim=c(h,8,c_num))

mean.nl_i <- array(dim=c(h,4,c_num))
mean.nl_d <- array(dim=c(h,4,c_num))
mean.id_l <- array(dim=c(h,4,c_num))
mean.id_n <- array(dim=c(h,4,c_num))
mean.indl <- array(dim=c(h,4,c_num))

mean_i <- array(dim=c(h,4,c_num))
mean_n <- array(dim=c(h,4,c_num))

mean.nl_i_a <- array(dim=c(h,4,c_num))
mean.nl_d_a <- array(dim=c(h,4,c_num))
mean.id_l_a <- array(dim=c(h,4,c_num))
mean.id_n_a <- array(dim=c(h,4,c_num))
mean.indl_a <- array(dim=c(h,4,c_num))

mean_i_a <- array(dim=c(h,4,c_num))
mean_n_a <- array(dim=c(h,4,c_num))

for(k in 1:c_num){

  # forecast errors
  e.il_mean <- array_forecast[,1,,k]-array_forecast[,3,,k]
  e.in_mean <- array_forecast[,1,,k]-array_forecast[,4,,k]
  e.dl_mean <- array_forecast[,1,,k]-array_forecast[,5,,k]
  e.dn_mean <- array_forecast[,1,,k]-array_forecast[,6,,k]

  # combined forecast errors
  e.i_mean <- .5*e.il_mean+.5*e.in_mean
  e.d_mean <- .5*e.dl_mean+.5*e.dn_mean
  e.l_mean <- .5*e.il_mean+.5*e.dl_mean
  e.n_mean <- .5*e.in_mean+.5*e.dn_mean

  # root mean square forecast errors
  rmsfe.il_mean <- apply(e.il_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.in_mean <- apply(e.in_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.dl_mean <- apply(e.dl_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.dn_mean <- apply(e.dn_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.i_mean <- apply(e.i_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.d_mean <- apply(e.d_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.l_mean <- apply(e.l_mean,1,function(x) sqrt(mean(x^2)))
  rmsfe.n_mean <- apply(e.n_mean,1,function(x) sqrt(mean(x^2)))

  rmsfe_mean[,,k] <- cbind(rmsfe.il_mean,rmsfe.in_mean,rmsfe.dl_mean,rmsfe.dn_mean,rmsfe.i_mean,rmsfe.d_mean,rmsfe.l_mean,rmsfe.n_mean)

  # (1) iterated STAR vs iterated AR
  d.nl_i <- e.in_mean^2-e.il_mean^2
  # (2) direct STAR vs direct AR
  d.nl_d <- e.dn_mean^2-e.dl_mean^2
  # (3) iterated AR vs direct AR
  d.id_l <- e.il_mean^2-e.dl_mean^2
  # (4) iterated STAR vs direct STAR
  d.id_n <- e.in_mean^2-e.dn_mean^2
  # (5) iterated STAR vs direct AR
  d.indl <- e.in_mean^2-e.dl_mean^2

  # (C1) iterated combined vs direct combined
  d_i <- e.i_mean^2-e.d_mean^2
  # (C2) nonlinear combined vs linear combined
  d_n <- e.n_mean^2-e.l_mean^2

  # (1) iterated STAR vs iterated AR
  mat.nl_i <- matrix(nrow=h,ncol=4)
  mat.nl_i_a <- matrix(nrow=h,ncol=4)
  for(j in 1:h){
    d.reg <- lm(d.nl_i[j,]~1)
    mat.nl_i[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat.nl_i[j,3] <- mat.nl_i[j,3]*harvey
    mat.nl_i[j,4] <- 2*pt(abs(mat.nl_i[j,3]),df=P-1,lower.tail=F)

    if(j>=2){
      wd.nl_i <- colMeans(d.nl_i[1:j,])
      wd.reg <- lm(wd.nl_i~1)
      mat.nl_i_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat.nl_i_a[j,3] <- mat.nl_i_a[j,3]*harvey
      mat.nl_i_a[j,4] <- 2*pt(abs(mat.nl_i_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat.nl_i_a[j,] <-  mat.nl_i[j,]
    }

  }
  mean.nl_i[,,k] <- mat.nl_i
  mean.nl_i_a[,,k] <- mat.nl_i_a

  # (2) direct STAR vs direct AR
  mat.nl_d <- matrix(nrow=h,ncol=4)
  mat.nl_d_a <- matrix(nrow=h,ncol=4)
  for(j in 1:h){
    d.reg <- lm(d.nl_d[j,]~1)
    mat.nl_d[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat.nl_d[j,3] <- mat.nl_d[j,3]*harvey
    mat.nl_d[j,4] <- 2*pt(abs(mat.nl_d[j,3]),df=P-1,lower.tail=F)

    if(j>=2){
      wd.nl_d <- colMeans(d.nl_d[1:j,])
      wd.reg <- lm(wd.nl_d~1)
      mat.nl_d_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat.nl_d_a[j,3] <- mat.nl_d_a[j,3]*harvey
      mat.nl_d_a[j,4] <- 2*pt(abs(mat.nl_d_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat.nl_d_a[j,] <-  mat.nl_d[j,]
    }

  }
  mean.nl_d[,,k] <- mat.nl_d
  mean.nl_d_a[,,k] <- mat.nl_d_a

  # (3) iterated AR vs direct AR
  mat.id_l <- matrix(nrow=h,ncol=4)
  mat.id_l_a <- matrix(nrow=h,ncol=4)
  for(j in 2:h){
    d.reg <- lm(d.id_l[j,]~1)
    mat.id_l[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat.id_l[j,3] <- mat.id_l[j,3]*harvey
    mat.id_l[j,4] <- 2*pt(abs(mat.id_l[j,3]),df=P-1,lower.tail=F)

    if(j>2){
      wd.id_l <- colMeans(d.id_l[2:j,])
      wd.reg <- lm(wd.id_l~1)
      mat.id_l_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat.id_l_a[j,3] <- mat.id_l_a[j,3]*harvey
      mat.id_l_a[j,4] <- 2*pt(abs(mat.id_l_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat.id_l_a[j,] <-  mat.id_l[j,]
    }

  }
  mean.id_l[,,k] <- mat.id_l
  mean.id_l_a[,,k] <- mat.id_l_a

  # (4) iterated STAR vs direct STAR
  mat.id_n <- matrix(nrow=h,ncol=4)
  mat.id_n_a <- matrix(nrow=h,ncol=4)
  for(j in 2:h){
    d.reg <- lm(d.id_n[j,]~1)
    mat.id_n[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat.id_n[j,3] <- mat.id_n[j,3]*harvey
    mat.id_n[j,4] <- 2*pt(abs(mat.id_n[j,3]),df=P-1,lower.tail=F)

    if(j>2){
      wd.id_n <- colMeans(d.id_n[2:j,])
      wd.reg <- lm(wd.id_n~1)
      mat.id_n_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat.id_n_a[j,3] <- mat.id_n_a[j,3]*harvey
      mat.id_n_a[j,4] <- 2*pt(abs(mat.id_n_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat.id_n_a[j,] <-  mat.id_n[j,]
    }

  }
  mean.id_n[,,k] <- mat.id_n
  mean.id_n_a[,,k] <- mat.id_n_a

  # (5) iterated STAR vs direct AR
  mat.indl <- matrix(nrow=h,ncol=4)
  mat.indl_a <- matrix(nrow=h,ncol=4)
  for(j in 1:h){
    d.reg <- lm(d.indl[j,]~1)
    mat.indl[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat.indl[j,3] <- mat.indl[j,3]*harvey
    mat.indl[j,4] <- 2*pt(abs(mat.indl[j,3]),df=P-1,lower.tail=F)

    if(j>=2){
      wd.indl <- colMeans(d.indl[1:j,])
      wd.reg <- lm(wd.indl~1)
      mat.indl_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat.indl_a[j,3] <- mat.indl_a[j,3]*harvey
      mat.indl_a[j,4] <- 2*pt(abs(mat.indl_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat.indl_a[j,] <-  mat.indl[j,]
    }

  }
  mean.indl[,,k] <- mat.indl
  mean.indl_a[,,k] <- mat.indl_a

  # (C1) iterated combined vs direct combined
  mat_i <- matrix(nrow=h,ncol=4)
  mat_i_a <- matrix(nrow=h,ncol=4)
  for(j in 1:h){
    d.reg <- lm(d_i[j,]~1)
    mat_i[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat_i[j,3] <- mat_i[j,3]*harvey
    mat_i[j,4] <- 2*pt(abs(mat_i[j,3]),df=P-1,lower.tail=F)

    if(j>=2){
      wd_i <- colMeans(d_i[1:j,])
      wd.reg <- lm(wd_i~1)
      mat_i_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat_i_a[j,3] <- mat_i_a[j,3]*harvey
      mat_i_a[j,4] <- 2*pt(abs(mat_i_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat_i_a[j,] <-  mat_i[j,]
    }

  }
  mean_i[,,k] <- mat_i
  mean_i_a[,,k] <- mat_i_a

  # (C2) nonlinear combined vs linear combined
  mat_n <- matrix(nrow=h,ncol=4)
  mat_n_a <- matrix(nrow=h,ncol=4)
  for(j in 1:h){
    d.reg <- lm(d_n[j,]~1)
    mat_n[j,] <- coeftest(d.reg,vcov.=NeweyWest(d.reg,lag=h))

    harvey <- sqrt((P+1-2*j+j*(j-1)/P)/P)
    mat_n[j,3] <- mat_n[j,3]*harvey
    mat_n[j,4] <- 2*pt(abs(mat_n[j,3]),df=P-1,lower.tail=F)

    if(j>=2){
      wd_n <- colMeans(d_n[1:j,])
      wd.reg <- lm(wd_n~1)
      mat_n_a[j,] <- coeftest(wd.reg,vcov.=NeweyWest(wd.reg,lag=h))
      mat_n_a[j,3] <- mat_n_a[j,3]*harvey
      mat_n_a[j,4] <- 2*pt(abs(mat_n_a[j,3]),df=P-1,lower.tail=F)
    }else{
      mat_n_a[j,] <-  mat_n[j,]
    }

  }
  mean_n[,,k] <- mat_n
  mean_n_a[,,k] <- mat_n_a

}

# (1) iterated STAR vs iterated AR
rat.nl_i_mean <- round(t(rmsfe_mean[,2,]/rmsfe_mean[,1,]),3)
dm.nl_i_mean <- round(t(mean.nl_i[,4,]),3)
dm.nl_i_mean_a <- round(t(mean.nl_i_a[,4,]),3)

# (2) direct STAR vs direct AR
rat.nl_d_mean <- round(t(rmsfe_mean[,4,]/rmsfe_mean[,3,]),3)
dm.nl_d_mean <- round(t(mean.nl_d[,4,]),3)
dm.nl_d_mean_a <- round(t(mean.nl_d_a[,4,]),3)

# (3) iterated AR vs direct AR
rat.id_l_mean <- round(t(rmsfe_mean[,1,]/rmsfe_mean[,3,]),3)
dm.id_l_mean <- round(t(mean.id_l[,4,]),3)
dm.id_l_mean_a <- round(t(mean.id_l_a[,4,]),3)

# (4) iterated STAR vs direct STAR
rat.id_n_mean <- round(t(rmsfe_mean[,2,]/rmsfe_mean[,4,]),3)
dm.id_n_mean <- round(t(mean.id_n[,4,]),3)
dm.id_n_mean_a <- round(t(mean.id_n_a[,4,]),3)

# (5) iterated STAR vs direct AR
rat.indl_mean <- round(t(rmsfe_mean[,2,]/rmsfe_mean[,3,]),3)
dm.indl_mean <- round(t(mean.indl[,4,]),3)
dm.indl_mean_a <- round(t(mean.indl_a[,4,]),3)

# (C1) iterated combined vs direct combined
rat.i_mean <- round(t(rmsfe_mean[,5,]/rmsfe_mean[,6,]),3)
dm.i_mean <- round(t(mean_i[,4,]),3)
dm.i_mean_a <- round(t(mean_i_a[,4,]),3)

# (C2) nonlinear combined vs linear combined
rat.n_mean <- round(t(rmsfe_mean[,8,]/rmsfe_mean[,7,]),3)
dm.n_mean <- round(t(mean_n[,4,]),3)
dm.n_mean_a <- round(t(mean_n_a[,4,]),3)

## commodity ordering
## this is sort of arbitrary, but in general:
## agricultural--forestry--metals and minerals
cmd_sequence <- c(5,.9,1,4,2,
                  2,2,5,1.9,1.8,
                  5,3,.9,2,5,
                  3,2,1,2,2.5,
                  2,3,3,5,4)

################
###  TABLES  ###
################

# (1) iterated STAR vs iterated AR
tab1_dt <- data.table(Commodity=commodities,rat.nl_i_mean)
tab1_dt$grp <- cmd_sequence
tab1_dt <- tab1_dt[order(grp,Commodity)]
tab1_dt$grp <- NULL
colnames(tab1_dt) <- c("Commodity",paste0("h",c(1:12)))

dm1_dt <- data.table(Commodity=commodities,dm.nl_i_mean)
dm1_dt$grp <- cmd_sequence
dm1_dt <- dm1_dt[order(grp,Commodity)]
dm1_dt$grp <- NULL
colnames(dm1_dt) <- c("Commodity",paste0("h",c(1:12)))

dma1_dt <- data.table(Commodity=commodities,dm.nl_i_mean_a)
dma1_dt$grp <- cmd_sequence
dma1_dt <- dma1_dt[order(grp,Commodity)]
dma1_dt$grp <- NULL
colnames(dma1_dt) <- c("Commodity",paste0("h",c(1:12)))

tab1_dt$Methods <- "iSTAR/iAR"
tab1_lg <- melt(tab1_dt,id.vars=c("Commodity","Methods"),variable.name="Horizon",value.name="Ratio")

tab1_dt$Methods <- NULL
print(xtable(tab1_dt),include.rownames=FALSE)
write.table(tab1_dt,file="Paper/table_2.txt",sep=",",quote=F,row.names=F)

# (2) direct STAR vs direct AR
tab2_dt <- data.table(Commodity=commodities,rat.nl_d_mean)
tab2_dt$grp <- cmd_sequence
tab2_dt <- tab2_dt[order(grp,Commodity)]
tab2_dt$grp <- NULL
colnames(tab2_dt) <- c("Commodity",paste0("h",c(1:12)))

dm2_dt <- data.table(Commodity=commodities,dm.nl_d_mean)
dm2_dt$grp <- cmd_sequence
dm2_dt <- dm2_dt[order(grp,Commodity)]
dm2_dt$grp <- NULL
colnames(dm2_dt) <- c("Commodity",paste0("h",c(1:12)))

dma2_dt <- data.table(Commodity=commodities,dm.nl_d_mean_a)
dma2_dt$grp <- cmd_sequence
dma2_dt <- dma2_dt[order(grp,Commodity)]
dma2_dt$grp <- NULL
colnames(dma2_dt) <- c("Commodity",paste0("h",c(1:12)))

tab2_dt$Methods <- "dSTAR/dAR"
tab2_lg <- melt(tab2_dt,id.vars=c("Commodity","Methods"),variable.name="Horizon",value.name="Ratio")

tab2_dt$Methods <- NULL
print(xtable(tab2_dt),include.rownames=FALSE)
write.table(tab2_dt,file="Paper/table_3.txt",sep=",",quote=F,row.names=F)

# (3) iterated AR vs direct AR
tab3_dt <- data.table(Commodity=commodities,rat.id_l_mean)
tab3_dt$grp <- cmd_sequence
tab3_dt <- tab3_dt[order(grp,Commodity)]
tab3_dt$grp <- NULL
colnames(tab3_dt) <- c("Commodity",paste0("h",c(1:12)))

dm3_dt <- data.table(Commodity=commodities,dm.id_l_mean)
dm3_dt$grp <- cmd_sequence
dm3_dt <- dm3_dt[order(grp,Commodity)]
dm3_dt$grp <- NULL
colnames(dm3_dt) <- c("Commodity",paste0("h",c(1:12)))

dma3_dt <- data.table(Commodity=commodities,dm.id_l_mean_a)
dma3_dt$grp <- cmd_sequence
dma3_dt <- dma3_dt[order(grp,Commodity)]
dma3_dt$grp <- NULL
colnames(dma3_dt) <- c("Commodity",paste0("h",c(1:12)))

tab3_dt$Methods <- "iAR/dAR"
tab3_lg <- melt(tab3_dt,id.vars=c("Commodity","Methods"),variable.name="Horizon",value.name="Ratio")

tab3_dt$Methods <- NULL
print(xtable(tab3_dt),include.rownames=FALSE)
write.table(tab3_dt,file="Paper/table_6.txt",sep=",",quote=F,row.names=F)

# (4) iterated STAR vs direct STAR
tab4_dt <- data.table(Commodity=commodities,rat.id_n_mean)
tab4_dt$grp <- cmd_sequence
tab4_dt <- tab4_dt[order(grp,Commodity)]
tab4_dt$grp <- NULL
colnames(tab4_dt) <- c("Commodity",paste0("h",c(1:12)))

dm4_dt <- data.table(Commodity=commodities,dm.id_n_mean)
dm4_dt$grp <- cmd_sequence
dm4_dt <- dm4_dt[order(grp,Commodity)]
dm4_dt$grp <- NULL
colnames(dm4_dt) <- c("Commodity",paste0("h",c(1:12)))

dma4_dt <- data.table(Commodity=commodities,dm.id_n_mean_a)
dma4_dt$grp <- cmd_sequence
dma4_dt <- dma4_dt[order(grp,Commodity)]
dma4_dt$grp <- NULL
colnames(dma4_dt) <- c("Commodity",paste0("h",c(1:12)))

tab4_dt$Methods <- "iSTAR/dSTAR"
tab4_lg <- melt(tab4_dt,id.vars=c("Commodity","Methods"),variable.name="Horizon",value.name="Ratio")

tab4_dt$Methods <- NULL
print(xtable(tab4_dt),include.rownames=FALSE)
write.table(tab4_dt,file="Paper/table_4.txt",sep=",",quote=F,row.names=F)

# (5) iterated STAR vs direct AR
tab5_dt <- data.table(Commodity=commodities,rat.indl_mean)
tab5_dt$grp <- cmd_sequence
tab5_dt <- tab5_dt[order(grp,Commodity)]
tab5_dt$grp <- NULL
colnames(tab5_dt) <- c("Commodity",paste0("h",c(1:12)))

dm5_dt <- data.table(Commodity=commodities,dm.indl_mean)
dm5_dt$grp <- cmd_sequence
dm5_dt <- dm5_dt[order(grp,Commodity)]
dm5_dt$grp <- NULL
colnames(dm5_dt) <- c("Commodity",paste0("h",c(1:12)))

dma5_dt <- data.table(Commodity=commodities,dm.indl_mean_a)
dma5_dt$grp <- cmd_sequence
dma5_dt <- dma5_dt[order(grp,Commodity)]
dma5_dt$grp <- NULL
colnames(dma5_dt) <- c("Commodity",paste0("h",c(1:12)))

tab5_dt$Methods <- "iSTAR/dAR"
tab5_lg <- melt(tab5_dt,id.vars=c("Commodity","Methods"),variable.name="Horizon",value.name="Ratio")

tab5_dt$Methods <- NULL
print(xtable(tab5_dt),include.rownames=FALSE)
write.table(tab5_dt,file="Paper/table_5.txt",sep=",",quote=F,row.names=F)

################
###  FIGURE  ###
################

tab_lg <- rbind(tab1_lg,tab2_lg,tab4_lg,tab5_lg,tab3_lg)

tab_lg$Commodity <- factor(tab_lg$Commodity,levels=unique(tab_lg$Commodity))
tab_lg$Methods <- factor(tab_lg$Methods,levels=unique(tab_lg$Methods))

gg_ratios <- ggplot(tab_lg,aes(x=Horizon,y=Ratio,color=Methods,linetype=Methods,group=Methods))+
  geom_line(size=0.4)+
  geom_hline(yintercept = 1,color="gray70",linetype=5,size=.2)+
  facet_wrap(~Commodity,ncol=5,scale="free")+
  scale_color_manual(values=c("gray30","steelblue","indianred","seagreen","goldenrod"))+
  scale_x_discrete(breaks=c("h3","h6","h9","h12"),labels=c(3,6,9,12))+
  scale_y_continuous(labels = scales::number_format(accuracy=0.01))+
  labs(x="Forecast Horizon",y="RMSFE Ratio")+
  theme_classic()+
  theme(axis.title = element_text(size=10),axis.text.x=element_text(size=6,hjust=.8),axis.text.y=element_text(size=6),strip.text=element_text(size=6),strip.background=element_blank(),legend.position = "top",legend.title=element_blank())

# ggsave(paste("Paper/Forecasts",w_frac,".eps",sep=""),gg_ratios,width=6.5,height=6.5,units="in",device="eps")
# ggsave(paste("Paper/Forecasts",w_frac,".png",sep=""),gg_ratios,width=6.5,height=6.5,units="in",device="png")
# ggsave(paste("Presentation/Forecasts",w_frac,".png",sep=""),gg_ratios,width=6.5,height=4.5,units="in",device="png")


# [Data yang digunakan](https://academy.dqlab.id/main/projectcode/215/398/1993)
df_loan <- read.csv('https://dqlab-dataset.s3-ap-southeast-1.amazonaws.com/loan_disbursement.csv',
                    stringsAsFactors = F)
dplyr::glimpse(df_loan)

# [Memfilter data bulan Mei 2020, dan jumlahkan data per cabang](https://academy.dqlab.id/main/projectcode/215/399/1994)
library(dplyr)

df_loan_mei <- df_loan %>%
  filter(tanggal_cair >=  '2020-05-01',
         tanggal_cair <= '2020-05-31') %>%
  group_by(cabang) %>%
  summarise(total_amount = sum(amount))
df_loan_mei

# [Tampilkan data 5 cabang dengan total amount paling besar](https://academy.dqlab.id/main/projectcode/215/399/1995)
library(dplyr)
library(scales)

df_loan_mei %>%
  arrange(desc(total_amount)) %>%
  mutate(total_amount = comma(total_amount)) %>%
  head(5)

# [Tampilkan data 5 cabang dengan total amount paling kecil](https://academy.dqlab.id/main/projectcode/215/399/1996)
library(dplyr)
library(scales)

df_loan_mei %>%
  arrange(total_amount) %>%
  mutate(total_amount = comma(total_amount)) %>%
  head(5)

# [Menghitung umur cabang (dalam bulan)](https://academy.dqlab.id/main/projectcode/215/400/1998)
library(dplyr)

df_cabang_umur <- df_loan %>%
  group_by(cabang) %>%
  summarise(pertama_cair = min(tanggal_cair)) %>%
  mutate(umur = as.numeric(as.Date('2020-05-15') - as.Date(pertama_cair)) %/% 30)

df_cabang_umur

# [Gabungkan data umur dan performa mei](https://academy.dqlab.id/main/projectcode/215/400/1999)
library(dplyr)

df_loan_mei_umur <- df_cabang_umur %>%
  inner_join(df_loan_mei, by = 'cabang')

df_loan_mei_umur

# [Plot relasi umur dan performa mei](https://academy.dqlab.id/main/projectcode/215/400/2000)
library(ggplot2)

ggplot(df_loan_mei_umur, aes(x = umur, y = total_amount)) +
  geom_point() +
  scale_y_continuous(labels = scales::comma) +
  labs(title = "Semakin berumur, perfoma cabang akan semakin baik",
       x = "Umur (bulan)",
       y = "Total Amount")

# [Mencari cabang yang perfoma rendah untuk setiap umur](https://academy.dqlab.id/main/projectcode/215/401/2002)
library(dplyr)
library(scales)

df_loan_mei_flag <- df_loan_mei_umur %>%
  group_by(umur) %>%
  mutate(Q1 = quantile(total_amount, 0.25),
         Q3 = quantile(total_amount, 0.75),
         IQR = (Q3 - Q1)) %>%
  mutate(flag = ifelse(total_amount < (Q1 - IQR), 'rendah', 'baik'))

df_loan_mei_flag %>%
  filter(flag == 'rendah') %>%
  mutate_if(is.numeric, funs(comma))

# [Buat Scatterplot lagi dan beri warna merah pada cabang yang rendah tadi](https://academy.dqlab.id/main/projectcode/215/401/2003)
library(ggplot2)

ggplot(df_loan_mei_flag, aes(x = umur, y = total_amount)) +
  geom_point(aes(color = flag)) +
  scale_color_manual(breaks = c("baik", "rendah"),
                     values = c("blue", "red")) +
  scale_y_continuous(labels = scales::comma) +
  labs(title = "Ada cabang berpeforma rendah padahal tidak termasuk bottom 5 nasional",
       color = "",
       x = "Umur (bulan)",
       y = "Total Amount")

# [Lihat perbadingan performa cabang di umur yang sama](https://academy.dqlab.id/main/projectcode/215/402/2004)
library(dplyr)
library(scales)

df_loan_mei_flag %>%
  filter(umur == 3) %>%
  inner_join(df_loan, by = 'cabang') %>%
  filter(tanggal_cair >= '2020-05-01', tanggal_cair <= '2020-05-31') %>%
  group_by(cabang, flag)  %>%
  summarise(jumlah_hari = n_distinct(tanggal_cair),
            agen_aktif = n_distinct(agen),
            total_loan_cair = n_distinct(loan_id),
            avg_amount = mean(amount),
            total_amount = sum(amount)) %>%
  arrange(total_amount) %>%
  mutate_if(is.numeric, funs(comma))

# [Lihat perbadingan performa agen pada cabang yang rendah](https://academy.dqlab.id/main/projectcode/215/402/2005)
library(dplyr)
library(scales)

df_loan_mei_flag %>%
  filter(umur == 3, flag == 'rendah') %>%
  inner_join(df_loan, by = 'cabang') %>%
  filter(tanggal_cair >= '2020-05-01', tanggal_cair <= '2020-05-31') %>%
  group_by(cabang, agen) %>%
  summarise(jumlah_hari = n_distinct(tanggal_cair),
            total_loan_cair = n_distinct(loan_id),
            avg_amount = mean(amount),
            total_amount = sum(amount)) %>%
  arrange(total_amount) %>%
  mutate_if(is.numeric, funs(comma))

# [Lihat perbadingan performa agen pada cabang yang paling baik umur 3 bulan](https://academy.dqlab.id/main/projectcode/215/402/2007)
library(dplyr)
library(scales)

df_loan %>%
  filter(cabang == 'AH') %>%
  filter(tanggal_cair >= '2020-05-01', tanggal_cair <= '2020-05-31') %>%
  group_by(cabang, agen) %>%
  summarise(jumlah_hari = n_distinct(tanggal_cair),
            total_loan_cair = n_distinct(loan_id),
            avg_amount = mean(amount),
            total_amount = sum(amount)) %>%
  arrange(total_amount) %>%
  mutate_if(is.numeric, funs(comma))

R/Project/Project Data Analysis for Finance Performa Cabang.r