#### FUNCTIONS FOR CREATING GRAPHS

#' Cast data.frame to sparse matrix
#'
#' Create a sparse matrix from matching vectors of row indices, column indices and values
#'
#' @param rows a vector of row indices: [i,]
#' @param columns a vector of column indices: [,j]
#' @param values a vector of the values for each (non-zero) cell: [i,j] = value
#' @return a sparse matrix of the dgTMatrix class (\code{\link{Matrix}} package)
#' @export
cast.sparse.matrix <- function(rows, columns, values=NULL, agg.func='sum') {
  if(is.null(values)) values = rep(1, length(rows))
  d = data.frame(rows=rows, columns=columns, values=values)
  if(nrow(d) > nrow(unique(d[,c('rows','columns')]))){
    message(paste('(Aggregating duplicate row-column matches. agg.func =', agg.func))
    d = aggregate(values ~ rows + columns, d, FUN=agg.func)
  }
  unit_index = unique(d$rows)
  char_index = unique(d$columns)
  sm = spMatrix(nrow=length(unit_index), ncol=length(char_index),
                match(d$rows, unit_index), match(d$columns, char_index), d$values)
  rownames(sm) = unit_index
  colnames(sm) = char_index
  sm
}

#' Calculates the similarity between rows of a matrix
#'
#' Calculates the similarity between rows of a matrix using various similarity/distance measures. Output can be a matrix or a graph object in the \code{\link{igraph}} format
#'
#' @param matrix A matrix object, which can be a sparse matrix.
#' @param similarity.measure A character string giving a method for computing similarity. Options are: 'correlation', 'cosine','conditional_probability','coincidence_count' and 'overlap_jacard'.
#' @param as.graph A character string indicating whether output should be a 'graph' (instead of a matrix). The graph is directed if assymetrical similarity measures are used ('conditional_probability' or 'overlap_jacard')
#' @return An adjacency matrix or graph object
#' @export
matrix.rowsimilarities <- function(mat, similarity.measure, as.graph=F, min.similarity=NULL, decimals=3){
  if(similarity.measure=='correlation') output = matrix.correlation(t(mat))
  if(similarity.measure=='cosine') output = matrix.cosine(t(mat))
  if(similarity.measure=='conditional_probability') output=matrix.conprob(t(mat))
  if(similarity.measure=='coincidence_count') output=matrix.coincidence.count(t(mat))
  if(similarity.measure=='overlap_jacard') output=matrix.overlap.jacard(t(mat))

  if(!is.null(min.similarity)) output[which(output < min.similarity)] = 0
  mat = round(mat, decimals)
  if(as.graph==T) {
    if(similarity.measure %in% c('overlap_jacard','conditional_probability')) edge.type = 'directed' else edge.type = 'undirected'
    colnames(output) = rownames(output) = rownames(mat)
    output = graph.adjacency(as.matrix(output), mode=edge.type, weighted=TRUE, diag=FALSE)
  }
  output
}

#' Compute coincidence count for matrix columns
#'
#' Computes the coincidence of all columnso of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.coincidence.count <- function(mat){
  mat[which(mat > 0)] = 1
  crossprod(mat)
}

#' Compute jacard for matrix columns
#'
#' Computes jacard between all columnso of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.overlap.jacard <- function(mat){
  mat[which(mat > 0)] = 1
  output = crossprod(mat) / colSums(mat)
}

#' Compute correlations for matrix columns
#'
#' Computes correlations between all columnso of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.correlation <- function(mat){
  covmat = tcrossprod(colMeans(mat), (-2*colSums(mat)+nrow(mat)*colMeans(mat)))
  crossp = crossprod(mat)
  covmat = covmat + crossp
  sdvec = sqrt(diag(covmat))
  covmat / crossprod(t(sdvec))
}

#' Compute cosine for matrix columns
#'
#' Computes the cosine distance for all columns of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.cosine <- function(mat){
  cp = crossprod(mat)
  cp / crossprod(t(diag(sqrt(cp))))
}

#' Compute conditional probability for matrix columns
#'
#' Computes the conditional probability for all columns of a matrix
#'
#' @param mat A matrix object. Can be a sparse matrix.
#' @param alpha A weighting value to transform count to probabilities
#' @return An adjacency matrix
#' @export
matrix.conprob <- function(mat, alpha=2){
  mat = 1 - ((1/alpha) ^ mat)
  colsums = colSums(mat)
  mat = crossprod(mat) / colsums
  mat[is.na(mat)] = 0
  mat
}

#' Aggregates a (sparse) matrix
#'
#' Uses the \code{\link{slam}} package rollup function to efficiently aggregate a sparse matrix. Also allows multiple vectors to be used as grouping vars.
#'
#' @param mat A matrix object, can be a sparse matrix
#' @param grouping.vars The grouping elements. Can be a single vector, or a list or data.frame with multiple vectors
#' @param The name of the function to be applied
#' @return A list containing a (sparse) matrix and a data.frame with the variables matching the matrix rows
#' @export
matrix.aggregate <- function(mat, grouping.vars, FUN='sum'){
  grouping.vars = data.frame(grouping.vars)
  index = match(apply(grouping.vars, 1, list), apply(unique(grouping.vars), 1, list)) # silly but efficient way to get unique ids for 1 or more columns

  ncolumns = ncol(mat)
  mat = rollup(as.simple_sparse_array(mat), 1L, index, FUN=FUN)
  mat = Matrix(mat, ncol=ncolumns, sparse=T)

  grouping.vars = unique(grouping.vars)
  grouping.vars$n = as.numeric(tapply(rep(1,length(index)), index, FUN='sum'))
  list(matrix=mat, vars=grouping.vars)
}

#' Create a content similarity graph
#'
#' Makes a document similarity graph in the \code{\link{igraph}} format, based on a matrix in which rows are documents, and columns are content characteristics (e.g., terms, issues, topics).
#' Vertices (i.e. nodes) are defined as unique combinations of vertex.grouping.vars. If vertices cover multiple documents (e.g., authors of several documents) then content characteristics are first aggregated.
#' The (aggregated) content characteristics are used to calculate the similarities between vertices, for which various similarity measures can be used
#'
#' @param m A (sparse) matrix where rows are documents (e.g., news articles, forum posts) and columns are content characteristics (e.g., terms, topics). Values represent the presence of content characteristics within documents. Examples are: a \code{\link{DocumentTermMatrix}} or the transposed $document_sums (topics by documents matrix) created with \code{\link{lda.collapsed.gibbs.sampler}}.
#' @param vertex.grouping.vars A data.frame or list with named vectors representing vertex characteristics. Each unique combination of characteristics will be considered a vertex. In the graph object these characteristics are stored as vertex attributes.
#' @param similarity.measure A character string giving a method for computing similarity. Options are: 'correlation', 'cosine','conditional_probability','overlap_count' and 'overlap_jacard'.
#' @param min.similarity A numeric scalar representing the threshold for similarities. All ties with a value below min.similarity will be deleted. Can be used to reduce the size of large graphs with many weak ties.
#' @param content.totals.as.vertexmeta Can be used to include the sum values per node per content characteristic. if 'all', all content characteristics will be included. Can also be a numeric vector to select specific content characteristics. The attribute names for content characteristics are C followed by the number (C1, C2, etc)
#' @param content.totals.relative Logical. If content.totals.as.vertexmeta is used, use relative attention for content characteristic
#' @return A graph object in the \code{\link{igraph}} format
#' @export
content.similarity.graph <- function(m, vertex.grouping.vars, similarity.measure='cosine', min.similarity=NULL, content.totals.as.vertexmeta=NULL, content.totals.relative=T){
  matlist = matrix.aggregate(m, vertex.grouping.vars)
  g = matrix.rowsimilarities(matlist$matrix, similarity.measure, as.graph=T, min.similarity)

  #if(!is.null(min.similarity)) g = delete.edges(g, which(E(g)$weight < min.similarity))
  E(g)$similarity = E(g)$weight

  matlist$vars$values_sum = rowSums(matlist$matrix)
  if(!is.null(content.totals.as.vertexmeta)) matlist$vars = cbind(matlist$vars, get.attribute.totals(matlist$matrix, content.totals.as.vertexmeta, content.totals.relative))

  vertex.attributes(g) = as.list(matlist$vars)
  g = default.graph.attributes(g)
  g
}

#' Sets basic default values for content.similarity.graph
#'
#' Sets basic default values for content.similarity.graph
#'
#' @param g A graph object in the \code{\link{igraph}} format
#' @return A graph object in the \code{\link{igraph}} format
default.graph.attributes <- function(g){
  g$layout = layout.fruchterman.reingold
  V(g)$size = log(V(g)$values_sum)*2
  V(g)$label = as.character(1:length(V(g)))
  V(g)$label.cex = V(g)$size / 15
  V(g)$label.color = 'black'
  E(g)$weight = E(g)$similarity
  E(g)$width = E(g)$weight*10
  g
}

#' Create a graph based on similarites of vertices/nodes
#'
#' Makes a graph (in the \code{\link{igraph}} format) in which ties represent similarities between nodes, based on a matrix in which rows are cases (e.g., documents, authors, organizations), and columns are attributes of these cases (e.g., terms, authored-documents, countries).
#' Vertices (i.e. nodes) are defined as unique combinations of vertex.grouping.vars. If vertices cover multiple documents (e.g., authors of several documents) then content characteristics are first aggregated.
#' The (aggregated) content characteristics are used to calculate the similarities between vertices, for which various similarity measures can be used.
#'
#' @param m A (sparse) matrix where rows represent cases and columns represent attributes. Similarities are calculated between cases based on their scores on attributes. For example, if rows are documents, and columns are terms (e.g., a \code{\link{DocumentTermMatrix}}), then the similarities between documents are calculated based on their terms. Or, if rows are authors and columns are documents, then similarity between authors is calculated based on what documents they co-authored.
#' @param vertex.grouping.vars Vectors of the same length and order as the rows of m, representing vertex/node characteristics. Each unique combination of characteristics will be considered a vertex. In the graph object these characteristics are stored as vertex attributes.
#' @param similarity.measure A character string giving a method for computing similarity. Options (currently) are: 'correlation', 'cosine','conditional_probability','overlap_count' and 'overlap_jacard'.
#' @param min.similarity A numeric scalar representing the threshold for similarities. All ties with a value below min.similarity will be deleted. Can be used to reduce the size of large graphs with many weak ties.
#' @param attributes.as.vertexmeta Can be used to include the sum of values of attributes for each vertex as vertex meta. if 'all', all attributes will be included. Can also be a numeric vector to select specific attributes. If m has row names, these are used to name the attributes. Otherwise, they are labeled 'att' followed by the number (att1, att2, etc)
#' @param attributes.relative Logical. If attributes.as.vertexmeta is used, should the summed attribute scores per vertex be made relative to all attribute scores of the vertex?
#' @return A graph object in the \code{\link{igraph}} format
#' @export
similarity.graph <- function(m, vertex.grouping.vars, similarity.measure='cosine', min.similarity=NULL, attributes.as.vertexmeta=NULL, attributes.relative=T){
  matlist = matrix.aggregate(m, vertex.grouping.vars)
  g = matrix.rowsimilarities(matlist$matrix, similarity.measure, as.graph=T, min.similarity)

  matlist$vars$values_sum = rowSums(matlist$matrix)
  if(!is.null(attributes.as.vertexmeta)) matlist$vars = cbind(matlist$vars, get.attribute.totals(matlist$matrix, attributes.as.vertexmeta, attributes.relative))

  vertex.attributes(g) = as.list(matlist$vars)
  g
}

get.attribute.totals <- function(mat, attributes.as.vertexmeta, attributes.relative){
  mat = as.matrix(mat)
  colnames(mat) = paste('att', 1:ncol(mat),sep='')
  if(attributes.relative==T) mat = mat / rowSums(mat)
  if(class(attributes.as.vertexmeta) %in% c('integer','numeric')) mat = mat[,attributes.as.vertexmeta, drop=F]
  if(attributes.as.vertexmeta[1] == 'all') mat = mat
  mat
}

#' Calculate adjacency of units
#'
#' Calculate the adjacency (or coincidence) of units based on the contexts in which the units occured, and optionally a value for how often they occured in this context.
#' Various measures for calculating the adjacency/similarity are possible. Output is returned either as an adjacency matrix or as a graph in the \code{\link{igraph}} format.
#'
#' @param unit.vars Vectors representing the units. Can be a single vector or multiple vectors (as a data.frame or list). Units are then defined as unique combinations of vectors (e.g., first and last name of a person)
#' @param context A vector representing the context in which the units occured. For instance, conversations in which they participated or communities they are members of.
#' @param values Optional, a numerical vector with values for how often a unit occured in the context.
#' @param measure The measure for adjacency that is used. Use 'coincidence_count' to get the number of context in which units co-occured. To take into account how many times units co-occured in the same context, 'cosine' is advised.
#' @param as.graph Logical. If TRUE, the output is returned as a graph. Otherwise output is a list containing the adjacency matrix and vectors representing its rows/columns
#' @return Either a list containing the adjacency matrix and vectors representing the rows/columns, or a graph (if as.graph == T)
#' @export
adjacency <- function(unit.vars, context, values=NULL, measure='coincidence_count', as.graph=FALSE){
  row.vars = data.frame(unit.vars)
  col.vars = data.frame(context)
  row.index = match(apply(row.vars, 1, list), apply(unique(row.vars), 1, list))
  col.index = match(apply(col.vars, 1, list), apply(unique(col.vars), 1, list))
  mat = cast.sparse.matrix(rows=row.index, columns=col.index, values=values)

  if(as.graph == TRUE) {
    g = matrix.rowsimilarities(mat, measure, TRUE, min.similarity=NULL, decimals=3)
    vertex.attributes(g) = as.list(unique(row.vars))
    g
  } else {
    mat = matrix.rowsimilarities(mat, measure, FALSE, min.similarity=NULL, decimals=3)
    list(matrix=mat, dim.vars=unique(row.vars))
  }
}

location.matrix <- function(location, shift.by, context=NULL, value=NULL){
  if(is.list(context) | is.data.frame(context)) context = match(apply(data.frame(context), 1, list), apply(unique(data.frame(context)), 1, list))
  i = 1:length(location)
  if(is.null(value)) value = rep(1, length(location))
  if(is.null(context)){
    columns = unique(location)
    col.index = match(location-1, columns)
  } else {
    columns = unique(apply(cbind(context, location), 1, list))
    col.index = match(apply(cbind(context, location+shift.by), 1, list), columns)
  }
  index = data.frame(i=i, j=col.index, value=value)
  index = index[!is.na(index[,2]),]
  spMatrix(nrow=max(i), ncol=length(columns), i=index$i, j=index$j, index$value)
}

location.window.matrix <- function(location, context, window.size, value=NULL, window.shape=NULL, two.sided=F){
  if(is.null(value)) value = rep(1, window.size-1)
  window.index = data.frame(shift.by=1:(window.size-1), value=value)
  if(two.sided==T) window.index = rbind(window.index, data.frame(shift.by=-(window.size-1):-1, value=value))
  mat = location.matrix(location, 0, context)
  if(!is.null(window.shape)){
    ### hippe functies om de window te wegen (exp decay)
  }
  if(nrow(window.index > 0)) for(i in 1:nrow(window.index)) mat = mat + location.matrix(location, window.index$shift.by[i], context, window.index$value[i])
  mat
}

#' Calculate adjacency of units within moving windows
#'
#' Calculate the adjacency (or coincidence) of units within moving windows over the order in which they occur. For instance, the adjacency of words in a given word distance or actors within converstations in a given distance of messages.
#' Additionally, the context in which the units occured can be given. For instance, the documents in which words occur or the converstations in which messages occur.
#' Optionally, the order of units can also be used to indicate the direction in which units co-occur. For instance, only counting how often an actor responded to another actor in a conversation.
#'
#' @param unit.vars Vectors representing the units. Can be a single vector or multiple vectors (as a data.frame or list). Units are then defined as unique combinations of vectors (e.g., first and last name of a person)
#' @param order A numerical vector indicating the order in which units occured (within each context)
#' @param context A vector representing the context in which the units occured.
#' @param window.size A numerical scalar indicating the size of the moving window. The default (and minimum) is 2, which means that only units directly next to each other are counted.
#' @param count.double Logical. If TRUE, multiple occurence of the same unit within a window are summed. If FALSE, units are only counted once.
#' @param direction A character string. If 'undirected', the co-occurence of units in windows is counted. If 'up', it is counted how often a unit occured after other units in windows. if 'down', it is counted how often a unit occured before other units (simply the inverse of 'up')
#' @param as.graph Logical. If TRUE, the output is returned as a graph. Otherwise output is a list containing the adjacency matrix and vectors representing its rows/columns
#' @return Either a list containing a (sparse) matrix and vector representing rows/columns, or a graph (if as.graph == T)
#' @export
windowed.adjacency <- function(unit.vars, order, context=NULL, window.size=2, count.once=F, direction='undirected', as.graph=FALSE){
  mat = location.matrix(order, 0, context)
  if(direction=='undirected') two.sided=T else two.sided=F
  mat.lag = location.window.matrix(order, context, window.size,two.sided=two.sided)
  diag(mat.lag) = 0
  matagg = matrix.aggregate(mat, unit.vars)
  if(count.once==T) agg.func = 'max' else agg.func = 'sum'
  mat.lagagg = matrix.aggregate(mat.lag, unit.vars, FUN=agg.func)
  adjmat = crossprod(t(matagg$matrix),t(mat.lagagg$matrix))

  if(direction == 'down') adjmat = t(adjmat)

  if(as.graph == TRUE) {
    g = graph.adjacency(adjmat, mode='directed', weighted=TRUE, diag=FALSE)
    vertex.attributes(g) = as.list(matagg$vars)
    E(g)$average.XY = E(g)$weight / V(g)$n[get.edgelist(g)[,1]]
    E(g)$average.YX = E(g)$weight / V(g)$n[get.edgelist(g)[,2]]
    g
  } else list(matrix=adjmat, dim.vars=matagg$vars)
}

graph.as.dataframes <- function(g){
  edgelist = get.edgelist(g)
  e = data.frame(x=edgelist[,1], y=edgelist[,2])
  e = cbind(e, data.frame(edge.attributes(g)))
  v = data.frame(vertex.attributes(g))
  list(edges=e, vertices=v)
}

#' Assign vertex colors to a graph
#'
#' A convenience function to add colors to a graph of the \code{\link{igraph}} format based on a vector of vertex attributes.
#'
#' @param g A graph object in the \code{\link{igraph}} format
#' @param attribute A vertex attribute to organize the colors. Either use a categorical vector (factor, character) to color categories in different colors, or use a numerical vector (numerical, integer) to highlight with one color (like a heat map)
#' @param pallete Optional. Add a custom pallete, which should be a character vector with color codes that igraph can use.
#' @return A graph object in the \code{\link{igraph}} format
#' @export
graph.color.vertices <- function(g, attribute, pallete=NULL){
  if(class(attribute) %in% c('character','factor')) {
    if(is.null(pallete)) pallete = colors()[grep('[0-9]', colors(), invert=T)]
    unique.att = unique(attribute)
    if(length(unique.att) > length(pallete)) replace_colors = TRUE else replace_colors = FALSE
    pallete = data.frame(attribute=unique.att, color=sample(pallete, replace=replace_colors, length(unique.att)))
    V(g)$color = as.character(pallete$color[match(attribute, pallete$attribute)])
    print(pallete)
  }
  if(class(attribute) %in% c('numeric','integer')) {
    attribute = attribute / max(attribute)
    attribute = round(attribute*1000)
    pallete = colorRampPalette(c("white","darkred"), bias=0.5, interpolate='spline')(max(attribute)+1)
    V(g)$color = as.character(pallete)[attribute+1]
  }
  g
}

#' A wrapper for plotting graphs
#'
#' A wrapper for plotting graphs in the \code{\link{igraph}} format that incorporates the functions to delete edges and vertices
#'
#' @param g A graph object in the \code{\link{igraph}} format
#' @param min.edge.value Numerical scalar. Edges with a lower weight will be deleted
#' @param max.edge.value Like min.edge.value, but for the max value
#' @param delete.vertices Either a logical vector (TRUE/FALSE) with TRUE meaning that a vertex will be deleted, or indices for vertices that will be deleted
#' @param select.vertices Same as delete.vertices, but inversed
#' @param min.degree Numerical scalar, indicating the minimum number of edges a vertex needs to have in order to be included in the graph. Set to 1 to ignore unconnected vertices
#' @param use.tkplot Logical. If TRUE, tkplot is used instead of plot, which allows some interactive editing of the network
#' @param return.graph Logical. If TRUE, the function will return the (filtered) graph object
#' @return if return.graph is TRUE, A graph object in the \code{\link{igraph}} format
#' @export
graph.plot <- function(g, edge.weight=NULL, min.edge=NULL, max.edge=NULL, delete.vertices=NULL, select.vertices=NULL, min.degree=NULL, use.tkplot=FALSE, ego=NULL, return.graph=FALSE){
  if(!is.null(edge.weight)) {
    E(g)$weight = edge.weight
    E(g)$width = edge.weight*3
  }
  if(!is.null(ego)){
    if(class(ego) == 'logical') ego = which(ego)
    g = delete.edges(g, which(!get.edgelist(g)[,1] %in% ego & !get.edgelist(g)[,2] %in% ego))
  }
  if(!is.null(min.edge)) g=delete.edges(g, which(E(g)$weight < min.edge))
  if(!is.null(max.edge)) g=delete.edges(g, which(E(g)$weight > max.edge))
  if(!is.null(delete.vertices)){
    if(class(delete.vertices) == 'logical') delete.vertices = which(delete.vertices)
    g=delete.vertices(g, delete.vertices)
  }
  if(!is.null(select.vertices)){
    if(class(select.vertices) == 'logical') select.vertices = which(select.vertices)
    all.vertices = 1:length(V(g))
    g=delete.vertices(g, all.vertices[-select.vertices])
  }
  if(!is.null(min.degree)) g = delete.vertices(g, which(degree(g) < min.degree))

  if(use.tkplot == TRUE) tkplot(g) else plot(g)
  if(return.graph == TRUE) g
}

#### SOCIAL NETWORK FUNCTIONS

#' Split strings to rows with matching ids
#'
#' A convenience function. Mainly designed for preparing data for co-author type networks, if an unknown number of authors per document is stored as a single character string with delimiters.
#' A character string is split by a given character vector. For each part of the string a new row is created. An id value indicates which parts belong together. An order value indicates which part of the original string the stringpart was
#'
#' @param x A character vector.
#' @param split_by The character vector by which x will be split. By default should be a regular expression (see \code{\link{strsplit}}) but can be changed using the ellipsis parameters
#' @param id The id to be assigned to the rows. If a vector of the same lengt of x is given, these values will be used.
#' @param ... additional parameters to be passed to the strsplit function
#' @return A data.frame with the columns id, order and substring
#' @export
strsplit.to.rows <- function(x, id=NULL, split_by=';', ...){
  if(is.null(id)) id = 1:length(x)
  tmp = strsplit(as.character(x), split_by, ...)
  nMax = max(sapply(tmp, length))
  cols = t(sapply(tmp, function(i) i[1:nMax]))
  substring = as.vector(t(cols))
  ord = rep(1:nMax, times=length(id))
  id = rep(id, each=nMax)
  d = data.frame(id=id, order=ord, substring=substring)
  unique(d[!is.na(d$substring),])
}

########### OBSOLETE #############

#' Create a coincidence graph
#'
#' Create a graph from conversation data
#'
#' @param conversation.id A vector representing the conversation authors were engaged in (e.g. a thread, meeting)
#' @param author A vector with unique author names/ids
#' @return A graph object in the \code{\link{igraph}} format
#' @export
#' @examples
#' d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
#'               author=c('Alice','Bob','Alice','Dave','Bob','Bob','Alice','Bob','Alice','Bob'),
#'               order.nr=c(1,2,3,4,5,6,1,2,3,4))
#' g = author.coincidence.graph(d$conversation, d$author) # In how many conversations did author.X and author.Y communicate?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = author.coincidence.graph(d$conversation, d$author, 'overlap_jacard') # Similar to default (coincidence_count) but with direction (by dividing coincidence by number of conversations author participated in)
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.messages*15)
#' g = author.coincidence.graph(d$conversation, d$author, 'cosine') # Cosine can be used to also take into account how many times each author participated within conversations
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.messages*15)
coincidence.graph <- function(participation.id, author, similarity.measure='coincidence_count'){
  m = cast.sparse.matrix(author, participation.id)
  g = matrix.rowsimilarities(m, similarity.measure=similarity.measure, output.as='graph')
  g = add.author.participation.meta(g, participation.id, author)
  g
}

add.author.participation.meta <- function(g, participation.id, author){
  conauth = data.frame(participation.id, author)
  n.document = data.frame(table(unique(conauth)$author))
  n.messages = data.frame(table(conauth$author))
  V(g)$author = V(g)$name
  V(g)$n.context = n.document[match(V(g)$name, n.document[,1]),2]
  V(g)$n.messages = n.messages[match(V(g)$name, n.messages[,1]),2]
  g
}

#' Create a graph from conversation data
#'
#' Create a graph from conversation data, in which ties are drawn between each authors in the conversation and the first author.
#'
#' @param conversation.id A vector representing the conversation authors were engaged in (e.g. a thread, meeting)
#' @param author A vector with unique author names/ids
#' @param order.nr Optional. A vector representing the order in which authors communicated within a conversation.
#' @param direction A character string, indicating the direction of the ties. If 'undirected', ties between authors go both ways. If 'directed.up', ties are directed from author to previous authors (only if order is given). if 'directed.down', ties are directed from author to later authors.
#' @param once.per.conversation Logical. If TRUE, count only the number of conversations in which a first-author <-> later-author coincidence occurs. It is then ignored how many times the later author participated in the conversation. If FALSE, the number of participation times is counted.
#' @return A graph object in the \code{\link{igraph}} format
#' @export
#' @examples
#' d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
#'               author=c('Alice','Bob','Alice','Dave','Bob','Bob','Alice','Bob','Alice','Bob'),
#'               order.nr=c(1,2,3,4,5,6,1,2,3,4))
#' g = first.author.graph(d$conversation, d$author, d$order.nr) # in how many conversations initiated by author.Y did author.X communicate?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = first.author.graph(d$conversation, d$author, d$order.nr, once.per.conversation=FALSE) # how many times did author.X communicate in a conversation initiated by author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.messages*15)
#' g = first.author.graph(d$conversation, d$author, d$order.nr, direction='undirected') # drop direction author.X and author.Y
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = first.author.graph(d$conversation, d$author, d$order.nr, direction='directed.down') # switch direction
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
first.author.graph <- function(conversation, author, order.nr, direction='directed.up', once.per.conversation=TRUE){
  index = unique(author)
  author = match(author, unique(author))
  m = ties.per.message(conversation, author, order.nr, 1)
  m = aggregate.ties(m, conversation, author, once.per.conversation)
  rownames(m) = colnames(m) = index

  g = authormatrix.to.graph(m, direction)
  g = add.author.participation.meta(g, conversation, index[author])
  g
}

#' Create a graph from conversation data
#'
#' Create a graph from conversation data, in which ties are drawn between authors and the authors that communicated within a given distance (lookback) before them.
#'
#' @param conversation.id A vector representing the conversation authors were engaged in (e.g. a thread, meeting)
#' @param author A vector with unique author names/ids
#' @param order.nr Optional. A vector representing the order in which authors communicated within a conversation.
#' @param lookback The number of previous author with whom a tie with an author should be drawn
#' @param direction A character string, indicating the direction of the ties. If 'undirected', ties between authors go both ways. If 'directed.up', ties are directed from author to previous authors (only if order is given). if 'directed.down', ties are directed from author to later authors.
#' @param once.per.conversation Logical. If TRUE, max one tie between two unique authors will be counted per conversation, even if an author communicated within the given distance multiple times within the conversation.
#' @return A graph object in the \code{\link{igraph}} format
#' @export
#' @examples
#' d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
#'              author=c('Alice','Bob','Alice','Dave','Bob','Bob','Alice','Bob','Alice','Bob'),
#'               order.nr=c(1,2,3,4,5,6,1,2,3,4))
#' g = previous.authors.graph(d$conversation, d$author, d$order.nr, lookback=1) # how many times did author.X communicate directly after author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = previous.authors.graph(d$conversation, d$author, d$order.nr, lookback=1, once.per.conversation=TRUE) # in how many conversations did author.X communicate directly after author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = previous.authors.graph(d$conversation, d$author, d$order.nr, lookback=2) # how many times did author.X communicate within two messages after author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
previous.authors.graph <- function(conversation, author, order.nr, lookback=1, direction='directed.up', once.per.conversation=F){
  index = unique(author)
  author = match(author, unique(author))
  id = 1:length(author)
  for(lb in 1:lookback) {
    order.nr.Y = order.nr - lb
    if(lb == 1) m = ties.per.message(conversation, author, order.nr, order.nr.Y)
    if(lb > 1) m = m + ties.per.message(conversation, author, order.nr, order.nr.Y)
  }
  m = aggregate.ties(m, conversation, author, once.per.conversation)
  rownames(m) = colnames(m) = index

  g = authormatrix.to.graph(m, direction)
  g = add.author.participation.meta(g, conversation, index[author])
  g
}

ties.per.message <- function(conversation, author, order.nr.X, order.nr.Y){
  nauthors = length(unique(author))
  id = 1:length(author)
  previous_author = author[match(apply(cbind(conversation, order.nr.Y), 1, list), apply(cbind(conversation,order.nr.X), 1, list))]
  xy = cbind(id=id, y=previous_author)
  xy = xy[!is.na(xy[,2]),]
  if(is.null(nrow(xy))) next
  spMatrix(nrow=max(id), ncol=nauthors, i=xy[,1], j=xy[,2], rep(1, nrow(xy)))
}

aggregate.ties <- function(m, conversation, author, once.per.conversation=T){
  m[which(m > 0)] = 1 # count max 1 tie for each message.
  if(once.per.conversation == TRUE) {
    m = matrix.aggregate(m, list(conversation=conversation, author=author))
    m$matrix[which(m$matrix > 0)] = 1
    m = matrix.aggregate(m$matrix, list(author=m$vars$author))$matrix
  } else m = matrix.aggregate(m, list(author=author))$matrix
  m
}

authormatrix.to.graph <- function(m, direction){
  if(direction == 'undirected') {
    m = forceSymmetric(m, uplo='U') + forceSymmetric(m, uplo='L')
    g = graph.adjacency(m, mode='undirected', weighted=TRUE, diag=FALSE)
  }
  if(direction == 'directed.up') g = graph.adjacency(m, mode='directed', weighted=TRUE, diag=FALSE)
  if(direction == 'directed.down') g = graph.adjacency(t(m), mode='directed', weighted=TRUE, diag=FALSE)
  E(g)$author.ties = E(g)$width = E(g)$weight
  g
}


#Objetivo:  dibujar la "curva ROC de una variable"

#limpio la memoria
rm(list=ls())
gc()

library("data.table")

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

#cargo los datos
dataset <- fread("201902.txt")

#creo una clase que se 1 cuando es BAJA+2   , y  0 en caso contrario
#esto me simplifica las cuentas
dataset[ , clase01:= as.numeric(clase_ternaria=="BAJA+2") ]

#creo una variable azar que me va a ser util
#para ordenar al azar los registros que tienen el mismo valor para un campo
#asi el dibujo de la curva ROC de ese segmento es una recta
dataset[ , azar   := runif(nrow(dataset)) ]

#calculos basicos
universo  <-  nrow(dataset )
pos_total <-  sum(dataset$clase01 )
neg_total <-  universo -  pos_total

#Creo dos funciones de forma de poder superponer varios cortes de una misma variable

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

graficar_init  = function()
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #la diagonal
  azar_neg <- c( 0, neg_total )
  azar_pos <- c( 0, pos_total )

  #grafico
  plot( azar_neg,
        azar_pos,
        type="n",
        main=paste( "ROC Curve" ),
        xlab="neg",
        ylab="pos",
        pch=19)

  lines( azar_neg, azar_pos,   type="l" , col="black", lwd=2)
}
#----------------------

pred_graficar  = function(dataset, pcolumna, pvalor )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  pos_pred <- sum( dataset[ get(pcolumna) <= pvalor , clase01] )
  neg_pred <- sum( 1 - dataset[ get(pcolumna) <= pvalor, clase01] )

  AUC <- (pos_pred*neg_pred + (pos_pred + pos_total)*(neg_total-neg_pred) ) / (2*pos_total*neg_total)

  #creo el vector con los tres puntos
  vneg <- c( 0, neg_pred,  neg_total )
  vpos <- c( 0, pos_pred,  pos_total )

  #grafico
  lines( vneg, vpos,   type="l" , col="green", lwd=2)

  return( AUC )
}
#----------------------

graficar_init()

#ejecutar las instrucciones de a una y ver el efecto
pred_graficar( dataset, "mcuentas_saldo", -100000 )
pred_graficar( dataset, "mcuentas_saldo",  -10000 )
pred_graficar( dataset, "mcuentas_saldo",   -2000 )
pred_graficar( dataset, "mcuentas_saldo",       0 )
pred_graficar( dataset, "mcuentas_saldo",   10000 )#Mejor AUC
pred_graficar( dataset, "mcuentas_saldo",   50000 )
pred_graficar( dataset, "mcuentas_saldo",  100000 )

#----------------------
#Concepto fundamental
#se ordena el dataset por una variable
#y se lleva el conteo de positivos y negativos

columna_graficar  = function(dataset, pcolumna )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  #dentro de los registros que tienen el mismo valor de pcolumna, ordeno por el campo que invente llamado  azar
  #los NA de pcolumna  van al inicio del orden
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  #dibujo la curva, que esta compuesta de miles de puntos
  lines( neg_acum, pos_acum,   type="l" , col="red", lwd=2)

  #calculo el vector de cada AUC, que consiste en cortar exactamente en ese punto
  AUC_vector <-  ( pos_acum*neg_acum + (pos_acum+pos_total)*(neg_total-neg_acum) ) / (2*pos_total*neg_total)

  #voy a calcular cual es el corte que genera la mayor AUC

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( AUC_vector ),  get(pcolumna)],
                 "AUC_max" = max( AUC_vector)
               )
        )

}
#----------------------

columna_graficar(  dataset, "mcuentas_saldo"  )#AUC_mAX de  0.75
columna_graficar(  dataset, "cliente_edad"  )
columna_graficar(  dataset, "Visa_mconsumototal"  )#AUC_mAX de  0.732
columna_graficar(  dataset, "ttarjeta_visa"  )
columna_graficar(  dataset, "ttarjeta_master"  )
columna_graficar(  dataset, "Visa_cuenta_estado"  )

#ahora uso el valor optimo que encontre en la instruccion anterior
#cortar mcuentas_saldo en 1275.59

graficar_init()
pred_graficar( dataset, "mcuentas_saldo", 1275.59 )
columna_graficar(  dataset, "mcuentas_saldo"  )#AUC_mAX de  0.75

#cortar Visa_mconsumototal en 863.19
graficar_init()
pred_graficar( dataset, "Visa_mconsumototal", 863.19 )
columna_graficar(  dataset, "Visa_mconsumototal"  )#AUC_mAX de  0.732

#cortar cliente_edad en 36
graficar_init()
pred_graficar( dataset, "cliente_edad", 36 )
columna_graficar(  dataset, "cliente_edad"  )#AUC_mAX de  0.527

#como da la tabla de contingencia de mcuentas_saldo
ftable(dataset[ mcuentas_saldo <= 1275.59, clase_ternaria])
ftable(dataset[ mcuentas_saldo >  1275.59, clase_ternaria])

#como da la tabla de contingencia de Visa_mconsumototal
ftable(dataset[ Visa_mconsumototal <= 863.19, clase_ternaria])
ftable(dataset[ Visa_mconsumototal >  863.19, clase_ternaria])

#-----------------------
#Desvio,  calcular la ganancia acumulada

columna_graficar_ganancia  = function(dataset, pcolumna )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  #dentro de los registros que tienen el mismo valor de pcolumna, ordeno por el campo que invente llamado  azar
  #los NA de pcolumna  van al inicio del orden
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  #grafico
  plot( seq(universo),
        gan_acum,
        type="n",
        main=paste( "Ganancia ordenado por", pcolumna  ),
        xlab="registros",
        ylab="Ganancia",
        pch=19)

  lines( seq(universo), gan_acum,   type="l" , col="blue", lwd=2)

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( gan_acum ),  get(pcolumna)],
                 "gan_max" = max( gan_acum),
                 "regis"   = which.max( gan_acum )
               )
         )
}
#---------------------

columna_graficar_ganancia( dataset, "mcuentas_saldo"  )#AUC_mAX de  0.75
columna_graficar_ganancia( dataset, "cliente_edad"  )
columna_graficar_ganancia( dataset, "Visa_mconsumototal"  )#AUC_mAX de  0.732
columna_graficar_ganancia( dataset, "ttarjeta_visa"  )
columna_graficar_ganancia( dataset, "ttarjeta_master"  )
columna_graficar_ganancia( dataset, "Visa_cuenta_estado"  )

# Y ahora graficando los primeros  n registros

columna_graficar_ganancia_n  = function(dataset, pcolumna, pcantidad )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  #grafico
  plot( seq(pcantidad),
        gan_acum[1:pcantidad],
        type="n",
        main=paste( "Ganancia ordenado por", pcolumna  ),
        xlab="registros",
        ylab="Ganancia",
        pch=19)

  lines( seq(pcantidad), gan_acum[1:pcantidad],   type="l" , col="blue", lwd=2)

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( gan_acum ),  get(pcolumna)],
                 "gan_max" = max( gan_acum),
                 "regis"   = which.max( gan_acum )
               )
         )
}
#---------------------

columna_graficar_ganancia_n( dataset, "mcuentas_saldo", 20000  )
columna_graficar_ganancia_n( dataset, "Visa_mconsumototal", 40000  )


fac <- function(f) {
  function(n) {
    if (n<2)
      1
    else
      n*f(n-1)
  }
}

fib <- function(f) {
  function(n) {
    if (n <= 1)
      n
    else
      f(n-1) + f(n-2)
  }
}


anglesFromLineSizes <- function(a, b, c)
  acos((a**2 - c**2 - b**2)/(-2*b*c)) * 57.295779513

c(anglesFromLineSizes(1.25, 13.30, 13.10),
anglesFromLineSizes(1.55, 13.10, 13.00),
anglesFromLineSizes(1.55, 13.00, 13.10),
anglesFromLineSizes(1.55, 13.10, 13.30))

c(anglesFromLineSizes(1.25, 4.75, 4.35),
  anglesFromLineSizes(1.55, 4.35, 4.00),
  anglesFromLineSizes(1.55, 4.00, 4.35),
  anglesFromLineSizes(1.55, 4.35, 4.75))


library(MASS)
library(flexmix)
n.iters <- 1000

policy.RPM.Logit.LC2 <- function(m,y,...){

  d$impressions <- m
  d$conversions <- y

  d$arm <- d$sizeandconcept
  arm.names <- levels(d$arm)

  y.perarm <- tapply(d$conversions, list(d$arm), sum)
  m.perarm <- tapply(d$impressions, list(d$arm), sum)
  mu.obs <- y.perarm/m.perarm

  concept <- d$concept
  size <- d$size
  concept_each <- factor(rep(levels(concept),3))
  size_each <- factor(rep(levels(size),each=4))
  creative.names <- paste(size_each, concept_each, sep="_")
  designmatrix.interactions <- model.matrix( ~ size_each*concept_each)[,-1]
  rownames(designmatrix.interactions) <- creative.names

model2seg.interactions <- stepFlexmix(cbind(conversions,impressions-conversions) ~ 1+ size*concept | unitid,
            model = FLXMRglmfix(family = "binomial",fixed = ~1 ),
            data = d, k = 2, nrep = 5,
            control = list(iter=20, verbose=0, classify="weighted")
            )
model2seg.interactions.refit <- refit(model2seg.interactions)

mi <- model2seg.interactions
miref <- model2seg.interactions.refit
ncoef <- length(miref@coef)-1

#miref@coef
#miref@vcov
#miref@coef[(ncoef+1)]
#miref@coef[-(ncoef+1)]
#miref@vcov[-(ncoef+1),-(ncoef+1)]
#posterior(mi)[,2]
#summary(miref)
#miref@coef[(ncoef+1)]
#sqrt( miref@vcov[(ncoef+1),(ncoef+1)] )
#miref@vcov[(ncoef+1),(ncoef+1)]

mu.wgtavg <- apply( fitted(mi)*posterior(mi) , 1, sum)
mu.obs <- d$conversions/d$impressions

latent.class.assignment <- clusters(mi)
latent.class.postprob <- posterior(mi)

# for each segment
idx.1 <- 1:(ncoef/2)
idx.2 <- (ncoef/2+1):ncoef

beta.glm.mean.1 <- miref@coef[idx.1]
beta.glm.se.1 <- sqrt(diag(miref@vcov[idx.1,idx.1]))
beta.glm.varcov.1 <- miref@vcov[idx.1,idx.1]

beta.glm.mean.2 <- miref@coef[idx.2]
beta.glm.se.2 <- sqrt(diag(miref@vcov[idx.2,idx.2]))
beta.glm.varcov.2 <- miref@vcov[idx.2,idx.2]

### ------  estimates2allocprobs( ) ----- ###
### ---- FUNCTION STAR ----- ###
estimates2allocprobs <- function(beta.glm.mean, beta.glm.varcov, desmat=designmatrix.interactions, ...){ # begin
  beta.glm.samp <- mvrnorm(n.iters, beta.glm.mean, beta.glm.varcov)
  zstar.samp <- beta.glm.samp %*% t(cbind(rep(1,nrow(desmat)),desmat))
  zstar.which.max <- factor( apply(zstar.samp, 1, which.max), levels=1:ncol(zstar.samp) )
  alloc.probs <- as.numeric( table( zstar.which.max )/dim(zstar.samp)[1] )

  zstar.which.max.size1 <- factor( apply(zstar.samp[,1:4],1,which.max), levels=1:4 )
  zstar.which.max.size2 <- factor( apply(zstar.samp[,5:8],1,which.max), levels=1:4 )
  zstar.which.max.size3 <- factor( apply(zstar.samp[,9:12],1,which.max), levels=1:4 )
  alloc.probs.size1 <- as.numeric( table( zstar.which.max.size1 )/dim(zstar.samp)[1] )
  alloc.probs.size2 <- as.numeric( table( zstar.which.max.size2 )/dim(zstar.samp)[1] )
  alloc.probs.size3 <- as.numeric( table( zstar.which.max.size3 )/dim(zstar.samp)[1] )

  zstar.byarm.post.mean <- apply( zstar.samp, 2, mean )
  p.samp <- 1/( 1 + exp(-zstar.samp) )
  z.samp <- zstar.samp
  prob.byarm.post.mean <- 1/( 1 + exp(-zstar.byarm.post.mean) )
  alloc.probs.byconcept <- c(sum( alloc.probs[ c(1,5,9) ] ),
                            sum( alloc.probs[ c(2,6,10) ] ),
                            sum( alloc.probs[ c(3,7,11) ] ),
                            sum( alloc.probs[ c(4,8,12) ] ) )
  alloc.probs.withinsize <- c(alloc.probs.size1, alloc.probs.size2, alloc.probs.size3 )
  return(list(p.samp=p.samp,
              z.samp=z.samp,
              alloc.probs=alloc.probs,
              alloc.probs.byconcept=alloc.probs.byconcept,
              alloc.probs.withinsize=alloc.probs.withinsize)
         )
} #
### ---- FUNCTION END ----- ###

psamplist.seg1 <- estimates2allocprobs(beta.glm.mean.1, beta.glm.varcov.1, desmat=designmatrix.interactions)
psamplist.seg2 <- estimates2allocprobs(beta.glm.mean.2, beta.glm.varcov.2, desmat=designmatrix.interactions)

p.samp.seg1 <- psamplist.seg1$p.samp
z.samp.seg1 <- psamplist.seg1$z.samp
alloc.probs.seg1 <- psamplist.seg1$alloc.probs
alloc.probs.byconcept.seg1 <- psamplist.seg1$alloc.probs.byconcept
alloc.probs.withinsize.seg1 <- psamplist.seg1$alloc.probs.withinsize

p.samp.seg2 <- psamplist.seg2$p.samp
z.samp.seg2 <- psamplist.seg2$z.samp
alloc.probs.seg2 <- psamplist.seg2$alloc.probs
alloc.probs.byconcept.seg2 <- psamplist.seg2$alloc.probs.byconcept
alloc.probs.withinsize.seg2 <- psamplist.seg2$alloc.probs.withinsize

# create space for resampling within each j
d.long <- d[ rep(1:nrow(d), each=n.iters), ]
d.long$iter <- rep(1:n.iters, nrow(d))
d.long$p.samp <- rep(0, nrow(d)*n.iters)
d.long$z.samp <- rep(0, nrow(d)*n.iters)

# draw latent class assignments using seg2 probabilities
d.long$latent.class.postprob.seg2 <- latent.class.postprob[ rep(1:nrow(d), each=n.iters), 2]
d.long$segnum <- rbinom(nrow(d.long), d.long$latent.class.postprob.seg2, size=1) + 1
d.long$segment <- paste("segment",d.long$segnum,sep="")

# combine p sampled from each segment in proportion to membership prob to each segment
d.long$adsize <- d.long$size
K <- length(arm.names)
for (k in 1:K){
    curobs.long.1 <- d.long$arm==arm.names[k] & d.long$segment=="segment1"
    curobs.long.2 <- d.long$arm==arm.names[k] & d.long$segment=="segment2"
    d.long$z.samp[curobs.long.1] <- sample(z.samp.seg1[,k],size=sum(curobs.long.1),replace=T)
    d.long$z.samp[curobs.long.2] <- sample(z.samp.seg2[,k],size=sum(curobs.long.2),replace=T)
}

# obtain combined w, looping over j
w <- rep(0,nrow(d))
place <- d$placeid
for ( curplace in levels(place) ){
  curobs.long <- which(d.long$placeid == curplace)
  zsampperj <- matrix( d.long$z.samp[curobs.long], nrow=n.iters, ncol=4, byrow=F )
  zsampperj.whichmax <- factor( apply(zsampperj,1,which.max) , levels=1:4 )
  wcur <- as.numeric( table( zsampperj.whichmax ) )/n.iters
  curobs <- which(d$placeid == curplace)
  w[ curobs ] <- wcur
}

return(list(w=w))

} ### END FUNCTION  policy.RPM.Logit.LC2


# Define the function for Bayesian Parallel Analysis --------------------

bayes.pa <- function(data, n.thin = 1, N.draw = 100, n.burnin = 1000, N.CD = 100, quantile = .95, report = "probability"){

  # data refers to the raw data of scores
  # n.thin refers to the thinning parameter for MCMC
  # N.draw refers to the number of draws from the posterior to be used in B-PA
  # n.burnin refers to the number of iterations to burn in MCMC sampler
  # N.CD refers to the number of comparison datasets (per each draw from the posterior)
  # quantile refers to the cutoff of the distribution used to evaluate whether the observed eigenvalue is sufficiently large
  # report refers to whether to report results as a probability or percentage

  # load the required packages
  library(psych)
  library(MCMCpack)

  #function for generating the model syntax to run lavaan
  triag_model <- function(P, num.factor){

    random.rows <- sample(1:P, num.factor, replace=F) #generate random numbers to decide which rows to use

    output_fixed <- matrix(rep(NA,(num.factor)*(num.factor-1)),
                           nrow = (num.factor)*(num.factor-1)/2, ncol = 2)

    output_constraint <- matrix(rep(NA,num.factor*2), ncol = 2)

    count2 <- 1
    for (i1 in 1:(num.factor-1)){
      for (i2 in (i1+1):num.factor){
        output_fixed[count2,1] <- i2
        output_fixed[count2,2] <- random.rows[i1]
        count2 <- count2 + 1
      }
    }

    for (i1 in 1: num.factor){
      output_constraint[i1,1] <- i1
      output_constraint[i1,2] <- random.rows[i1]
    }

    colnames(output_fixed)      <- c("factor","item")
    colnames(output_constraint) <- c("factor","item")

    #specifying the loading matrix
    row_which.factor <- c(rep(NA,num.factor))
    tmp1 <- matrix(c(rep(NA,P)),nrow=num.factor,ncol=P)
    for (which.factor in 1:num.factor){
      for (which.item in 1:P){
        tmp1[which.factor, which.item] <- paste("r",which.factor,which.item, "*V", which.item, sep="")
      }

      row_which.factor[which.factor] <- paste("f", which.factor,"=~", tmp1[which.factor, 1]  ,sep="")
      for (which.item in 2:P){
        row_which.factor[which.factor] <- paste(row_which.factor[which.factor], tmp1[which.factor, which.item], sep="+")
      }
    }

    #facor correlations need to be fixed at 0;
    #given num.factor, I need num.factor-1 rows to make it an identity matrix
    row_factor_cor <- c(rep(NA, (num.factor*(num.factor-1)/2)))
    for (i in 2:num.factor){
      for (j in 1: (i-1))
        row_factor_cor[ (i-1)*(i-2)/2+j ] <- paste("f", i, "~~0*f", j, sep="")
    }

    #next, put the loadings to zero indicated by the randomly selected rows;
    rows_constraint <- rep(NA, (num.factor)*(num.factor-1)/2)

    count<-1

    for (i in 1: (length(random.rows)-1)){
      for (j in (i+1):(num.factor)){
        rows_constraint[count] <- paste("r", j ,random.rows[i],"==0",sep="")
        count<-count+1
      }
    }

    #Last, combine the syntax to form the model specification
    model <- row_which.factor[1]
    for (i in 2:(num.factor)){
      model <- paste(model, row_which.factor[i],sep='\n')
    }

    for (i in 1:length(row_factor_cor)){
      model <- paste(model, row_factor_cor[i],sep='\n')
    }

    for (i in 1:length(rows_constraint)){
      model <- paste(model, rows_constraint[i], sep='\n')
    }
    # print the syntax I wrote using : cat(model)
    #random.rows

    fixed_param <- rep(NA, num.factor)

    for (i in 1:num.factor){

      fixed_param[i] <- paste("r", i, random.rows[i], sep="")

    }

    return(list(model=model,
                fixed_param=fixed_param,
                output_fixed = output_fixed,
                output_constraint = output_constraint))
  }
  #function for generating parallel data set
  gen.pa.data <- function(n_sample, ni, est_lambda_CD, est_unique_CD){

    implied_matrix <- est_lambda_CD %*% t(est_lambda_CD) + diag(est_unique_CD)
    generated.data <- mvrnorm(n = n_sample, mu = rep(0, ni), Sigma = implied_matrix)

  }

  N <- dim(data)[1] #sample size
  P <- dim(data)[2] #n of item

  data <- as.matrix(data)

  c_names <- rep(NA, P)
  for (i in 1:P){c_names[i]<-paste("V",i,sep="")}
  colnames(data) <- c_names

  eigs.data <- fa(data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values # Compute the eigenvalues for observed data
  F.Max <- sum(eigs.data>0) #define the max number of possible factors

  eigs.comp.array <- array(NA, c(P, N.CD, N.draw, F.Max)) # set up array for saving eigenvalues from comparsion datasets

  #create a vector to save the results
  sav_result <- matrix(rep(NA, N.draw * P), nrow = N.draw, P)

  # Generate N.CD comparision datasets based on the kth factor and compare eigen values, test the number of factors
  T.NFactor=1 # Start with testing one factor

  while(T.NFactor <= F.Max){ # Loop from one factor to the max number of factors
    # Testing the first factor
    if(T.NFactor==1){

      print(paste0("Evaluating factor ", T.NFactor, " of ", F.Max))

      for(which.cd in 1:N.CD){ # Loop over N.CD comparsion datasets

        # generate one comparsion dataset using computed loadings
        comp.data <- matrix(rnorm(N*P), nrow=N, ncol=P)
        cor.comp.data <- cor(comp.data) # compute the correlation matrix

        # save the eigenvalues from running PAF on the comparison dataset
        eigs.comp.array[ , which.cd, 1, T.NFactor] <- fa(cor.comp.data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values
      }

      if(eigs.data[T.NFactor]>as.numeric(quantile(eigs.comp.array[T.NFactor, , 1,  T.NFactor], quantile))) T.NFactor <- T.NFactor+1 else break
    }

    # Testing the second factor
    if(T.NFactor==2){

      print(paste0("Evaluating factor ", T.NFactor, " of ", F.Max))

      #step 1, fit the 1 factor CFA model to bayes
      list.of.lambda.constraints <- list(
        V1=list(1,"+") #constrain the first loading to be positive
      )

      posterior.draws <- MCMCfactanal(
        x = data,
        factors = T.NFactor-1,
        lambda.constraints = list.of.lambda.constraints,
        burnin = n.burnin,
        mcmc = N.draw*n.thin,
        thin = n.thin,
        store.scores = FALSE,
        std.var = TRUE
      )

      #step 2, generate CD based on posterior.draws
      #save the estimated loading parameters
      est_lambda <- array(1, c(P, T.NFactor-1, N.draw)) #I don't need N.CD here, because I'm drawing parameters

      for (which.draw in 1: N.draw){
        count <- 1 #a count number to asist entering the parameters

        for (i1 in 1:P){
          for (j1 in 1:(T.NFactor-1)){

            if (est_lambda[i1, j1, which.draw] == 1 ){
              est_lambda[i1, j1, which.draw] <- posterior.draws[which.draw,][count]
              count <- count+1
            }

            if (i1 == P & j1 == (T.NFactor-1) ){ count <- 0 } #reset the count to 0 for the next draw

          }
        }
      }

      #save the estimated unique variances
      est_unique <- matrix(NA, nrow=N.draw, ncol=P)

      for (which.draw in 1: N.draw){
        for (i1 in P:1){
          est_unique[which.draw, i1] <- posterior.draws[which.draw, ncol(posterior.draws)- (P-i1)]
        }
      }

      #get the eigen values for each CD.
      for (which.draw in 1: N.draw){
        for (which.cd2 in 1:N.CD){
          comp.data <- gen.pa.data(N, P, est_lambda[,,which.draw], est_unique[which.draw,])
          cor.comp.data <- cor(comp.data) # compute the correlation matrix
          eigs.comp.array[ , which.cd2, which.draw, T.NFactor] <- fa(cor.comp.data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values
        }

        #decide if we want to move to the next number of factor given this parameter draw
        if(eigs.data[T.NFactor]> as.numeric(quantile(eigs.comp.array[T.NFactor, , which.draw, T.NFactor], quantile))) {
          sav_result[which.draw, T.NFactor] <- 1
        } else {
          sav_result[which.draw, T.NFactor] <- 0
        }
      }

      #decide if we want to move to the next number of factor
      if( sum(sav_result[, T.NFactor], na.rm = TRUE)>0 ) {
        T.NFactor <- T.NFactor+1
      } else break
    }

    # Testing the 3rd, 4th... factor
    if(T.NFactor>2 & T.NFactor<=F.Max){

      print(paste0("Evaluating factor ", T.NFactor, " of ", F.Max))

      Msyntax1 <- triag_model(P,  T.NFactor-1) #get the model syntax to run the CFA in lavaan

      # Create the list of constraints for MCMCpack
      # Initiate file and start sending text
      sink("temp1.R")
      cat("list.of.lambda.constraints <- list(")
      cat("\n") # go to next line

      # loop over constraints that fix loadings to 0
      which.constraint=1
      for(which.constraint in 1:nrow(Msyntax1$output_fixed)){
        cat(
          "V", Msyntax1$output_fixed[which.constraint, 2], "=list(", Msyntax1$output_fixed[which.constraint, 1], ",0),", sep=""
        )
        cat("\n") # go to next line
      }

      cat("\n") # go to next line

      # loop over constraints that fix loadings to be > 0
      which.constraint=1
      for(which.constraint in 1:nrow(Msyntax1$output_constraint)){

        # if it's not the last constraint, include a comma at the end
        if(which.constraint < nrow(Msyntax1$output_constraint)){
          cat(
            "V", Msyntax1$output_constraint[which.constraint, 2], "=list(", Msyntax1$output_constraint[which.constraint, 1], ',"+"),', sep=""
          )
          cat("\n") # go to next line
        }

        # if it's the last constraint, don't include a comma at the end, but do close the whole list
        if(which.constraint == nrow(Msyntax1$output_constraint)){
          cat(
            "V", Msyntax1$output_constraint[which.constraint, 2], "=list(", Msyntax1$output_constraint[which.constraint, 1], ',"+")', sep=""
          )
          cat("\n") # go to next line
          cat(")")
        }

      }

      sink()

      # Run and then remove the file with source code to define the constraints for MCMCpack
      source("temp1.R")
      file.remove("temp1.R")

      #list.of.lambda.constraints

      posterior.draws <- MCMCfactanal(
        x = data,
        factors = T.NFactor-1,
        lambda.constraints = list.of.lambda.constraints,
        burnin = n.burnin,
        mcmc = N.draw*n.thin,
        thin = n.thin,
        store.scores = FALSE,
        std.var = TRUE
      )

      # generate CD based on posterior.draws
      #Msyntax1$output_fixed #indicate which parameters should be fixed = 0

      #save the estimated loading parameters
      est_lambda <- array(1, c(P, T.NFactor-1, N.draw))

      #for fixed parameters, put a value of 0; for freely estimated parameters, keep it 1.
      for (which.draw in 1: N.draw){
        for (i1 in 1: nrow(Msyntax1$output_fixed)){
          est_lambda[Msyntax1$output_fixed[i1,2], Msyntax1$output_fixed[i1,1], which.draw] <- 0
        }
      }

      for (which.draw in 1: N.draw){
        count <- 1 #a count number to asist entering the parameters

        for (i1 in 1:P){
          for (j1 in 1:(T.NFactor-1)){

            if (est_lambda[i1, j1, which.draw] == 1 ){
              est_lambda[i1, j1, which.draw] <- posterior.draws[which.draw,][count]
              count <- count+1
            }

            if (i1 == P & j1 == (T.NFactor-1) ){ count <- 0 } #reset the count to 0 for the next draw

          }
        }
      }

      #save the estimated unique variances
      est_unique <- matrix(NA, nrow=N.draw, ncol=P)

      for (which.draw in 1: N.draw){
        for (i1 in P:1){
          est_unique[which.draw, i1] <- posterior.draws[which.draw, ncol(posterior.draws)- (P-i1)]
        }
      }

      #
      #get the eigen values for each draw.
      for (which.draw in 1: N.draw){
        for (which.cd2 in 1:N.CD){
          comp.data <- gen.pa.data(N, P, est_lambda[,,which.draw], est_unique[which.draw,])
          cor.comp.data <- cor(comp.data) # compute the correlation matrix
          eigs.comp.array[ , which.cd2, which.draw, T.NFactor] <- fa(cor.comp.data, nfactors=1, rotate="none", SMC=TRUE, max.iter=1, fm="pa", warnings = FALSE)$values
        }

        #decide if we want to move to the next number of factor given this parameter draw
        if(eigs.data[T.NFactor]> as.numeric(quantile(eigs.comp.array[T.NFactor, , which.draw, T.NFactor], quantile))) {
          sav_result[which.draw, T.NFactor] <- 1
        } else {
          sav_result[which.draw, T.NFactor] <- 0
        }
      }

      #decide if we want to move to the next number of factor
      if( sum(sav_result[, T.NFactor], na.rm = TRUE)>0 ) {
        T.NFactor <- T.NFactor+1
      } else break
    }
  }

  n.factors = T.NFactor-1 #the max num to be retained

  sav_result <- apply(sav_result, 2, sum)

  if (n.factors == 0){
    sav_result[1] <- 0
  }else{sav_result[1] <- N.draw}

  sav_result[is.na(sav_result)] <- 0

  #vector saving the draws suggesting not moving to the next factor
  sav_result_not <- N.draw - sav_result

  #vector saving the probabilities for each number of factors
  prob_baes <- matrix(rep(1, 1*(1+F.Max)), nrow=1)

  for (i in 0: F.Max){
    if (i == 0){
      prob_baes[(i+1)] <- ifelse(sav_result_not[(i+1)]==0, 0, 100) #prob of keeping 0 factor; either 0 or 100%.
    }

    if (i > 0){
      for (j in 1:i){
        prob_baes[(i+1)] <- prob_baes[(i+1)] * (sav_result[(j)]/N.draw)
      }
      prob_baes[(i+1)] <- prob_baes[(i+1)] *  sav_result_not[(i+1)]/N.draw
    }
  }

  # Specify the column names
  c.names <- rep(NA, ncol(prob_baes))
  for (i in 1: ncol(prob_baes)){
    c.names[i] <- paste("prob_", i-1, "_factors", sep = "")
  }

  # Convert to percentages for reporting, if requested
  if(report=="percentage"){
    prob_baes <- prob_baes*100
    c.names <- rep(NA, ncol(prob_baes))
    for (i in 1: ncol(prob_baes)){
      c.names[i] <- paste("%_", i-1, "_factors", sep = "")
    }
  }

  colnames(prob_baes) <- c.names

  return(prob_baes)
}

# Run the Example --------------------

#read in the example data for illustration
#data <- read.csv("HolzingerSwinefore_Grant-White_19tests.csv")

#run BPA using the bayes.pa function
#bayes.pa(data)


 ZHEGVD Example Program Results

 Eigenvalues
      -61.7321    -6.6195     0.0725    43.1883
 Eigenvectors
             1          2          3          4
 1      0.3903    -0.1560     2.2909    -0.1943
        0.0000    -0.0404     0.0000    -0.0690

 2     -0.1814    -0.1552    -0.5042     0.3884
        0.0114    -0.3651    -0.7120     0.0000

 3      0.0438     0.5364    -1.2701     0.0657
        0.0338     0.0000    -0.4547    -0.2095

 4     -0.2221    -0.1298     0.5706     0.2924
       -0.2272    -0.1880     1.3132    -0.0675

 Estimate of reciprocal condition number for B
        2.5E-03

 Error estimates (relative to machine precision)
 for the eigenvalues:
        2.4E+04    2.8E+03    2.3E+02    1.7E+04

 for the eigenvectors:
        4.7E+02    1.0E+03    1.0E+03    4.9E+02


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Global Average Temperature (Land + Ocean) Anomalies
# HadCRUT4 time series: ensemble medians and uncertainties:
# https://www.metoffice.gov.uk/hadobs/hadcrut4/data/current/download.html
# Absolute temp by latitude:
# https://crudata.uea.ac.uk/cru/data/temperature/
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(list = ls()) # clears workspace
library(ncdf4)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dat <-
  read.table('Data/GlobalTemp/HadCRUT4_Annual_medians.txt', skip = 20)
datD <-
  read.table('Data/GlobalTemp/HadCRUT4_Decadal_Smooth.txt', skip = 0)

colnames(datD)[c(1, 2, 11, 12)] <-
  colnames(dat)[c(1, 2, 11, 12)] <- c('Year', 'Anom', 'l95', 'u95')

pdf(
  'Figures/Supp/FracFeed-FigS-TempAnomDynamics.pdf',
  height = 3,
  width = 4
) # repeated in main text figure
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 0.8,
  cex.axis = 0.8
)
plot(
  Anom ~ Year,
  data = dat,
  las = 1,
  xlim = c(1920, 2016),
  type = 'n',
  ylab = expression("Global temperature anomaly " (degree * C))
)
# polygon(c(dat$Year,rev(dat$Year)),c(dat$l95,rev(dat$u95)),border=NA,col='grey80')
abline(h = 0, lty = 2)
lines(datD$Year, datD$Anom, col = 'red')
points(dat$Year,
       dat$Anom,
       pch = 21,
       bg = 'grey',
       type = 'o')
box(lwd = 1)
dev.off()

pdf('Output/Plots/TempAnomDynamics.pdf',
    height = 3,
    width = 4)
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 0.8,
  cex.axis = 0.8
)
plot(
  Anom ~ Year,
  data = dat,
  las = 1,
  xlim = c(1850, 2016),
  type = 'n',
  ylab = expression("Global temperature anomaly " (degree * C))
)
polygon(c(dat$Year, rev(dat$Year)),
        c(dat$l95, rev(dat$u95)),
        border = NA,
        col = 'grey80')
abline(h = 0, lty = 2)
lines(datD$Year, datD$Anom, col = 'red')
points(dat$Year,
       dat$Anom,
       pch = 21,
       bg = 'grey',
       type = 'o')
box(lwd = 1)
dev.off()

pdf(
  'Output/Plots/TempAnomDynamics_post1930.pdf',
  height = 3,
  width = 4
)
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 0.8,
  cex.axis = 0.8
)
plot(
  Anom ~ Year,
  data = dat,
  las = 1,
  xlim = c(1930, 2016),
  type = 'n',
  ylab = expression("Global temperature anomaly " (degree * C))
)
polygon(c(dat$Year, rev(dat$Year)),
        c(dat$l95, rev(dat$u95)),
        border = NA,
        col = 'grey80')
abline(h = 0, lty = 2)
lines(datD$Year, datD$Anom, col = 'red')
points(dat$Year,
       dat$Anom,
       pch = 21,
       bg = 'grey',
       type = 'o')
box(lwd = 1)
dev.off()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

nc <- nc_open('Data/GlobalTemp/HadCRUT_Absolute.nc', write = F)

lat <- ncvar_get(nc, varid = "lat")
dim(lat)
tem <- ncvar_get(nc, varid = "tem")
dim(tem)

temp.mean <- apply(tem, 2, mean, na.rm = T)
temp.sd <- apply(tem, 2, sd, na.rm = T)

pdf(
  'Figures/Supp/FracFeed-FigS-TempLatitude.pdf',
  height = 2.75,
  width = 4
)
par(
  mar = c(3, 4, 1, 1),
  mgp = c(1.8, 0.3, 0),
  tcl = -0.1,
  cex = 1,
  cex.axis = 0.8,
  las = 1
)
plot(
  lat,
  temp.mean,
  type = 'n',
  las = 1,
  xaxs = 'i',
  ylab = expression(paste("Mean temperature, ", degree, "C")),
  xlab = 'Latitude',
  xlim = c(-90, 90),
  axes = F
)
axis(2)
xat = seq(-90, 90, 30)
axis(1, at = xat)
polygon(c(lat, rev(lat)),
        c(temp.mean + temp.sd, rev(temp.mean - temp.sd)),
        col = 'grey',
        border = NA)
lines(lat, temp.mean, lwd = 2)
box(lwd = 1)
dev.off()

plot(
  lat,
  temp.mean,
  type = 'l',
  las = 1,
  xaxs = 'i',
  xlim = c(-80, 80)
)
axis(1, at = seq(-90, 90, 10))
abline(h = 0, lty = 2)
spl <- splinefun(lat, temp.mean)
curve(spl, -80, 80, add = T, col = 'red')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Kelv <- function(x) {
  273.15 + x
}

Arrhen <- function(x, A, E) {
  k = 8.6173303 * 10 ^ -5
  A * exp(-E / (k * x))
}
ArrhenX <- function(x) {
  Arrhen(x, A, E)
}
InvArrhenX <- function(x) {
  1 / Arrhen(x, A, E)
}

ProdArrhen <- function(x, A1, A2, E1, E2) {
  Arrhen(x, A1, E1) * Arrhen(x, A2, E2)
}
ProdArrhenX <- function(x) {
  ProdArrhen(x, A1, A2, E1, E2)
}

A = 1
E = 0.6
curve(ArrhenX, Kelv(-30), Kelv(40))
plot(ArrhenX, Kelv(-30), Kelv(40), log = 'xy')

Tmin <- min(temp.mean)
Tmax <- max(temp.mean)

A1 = exp(20)
E1 = 0.65 # from Brown et al. 2004 (approx.)
A2 = 0.8
E2 = 0.1

par(mfrow = c(3, 2))
A = A1
E = E1
plot(ArrhenX,
     Kelv(Tmin),
     Kelv(Tmax),
     xlab = 'Temp (K)',
     ylab = 'Mortality rate')
plot(lat, Arrhen(Kelv(temp.mean), A, E), xlab = 'Latitude', ylab = 'Mortality rate')

A = A2
E = E2
plot(ArrhenX,
     Kelv(Tmin),
     Kelv(Tmax),
     xlab = 'Temp (K)',
     ylab = 'Detection time')
plot(lat, Arrhen(Kelv(temp.mean), A, E), xlab = 'Latitude', ylab = 'Detection time')

plot(ProdArrhenX,
     Kelv(Tmin),
     Kelv(Tmax),
     xlab = 'Temp (K)',
     ylab = 'Product')
plot(lat,
     ProdArrhen(Kelv(temp.mean), A1, E1, A2, E2),
     xlab = 'Latitude',
     ylab = 'Product')

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


# A mussel pattern formation model that follows the Cahn-Hilliard model
# for phase separation. See Liu et al, PNAS 2013, 110 :11905-11910

# First setup of the model
#remove(list=ls()) # Remove all variables from memory

require("fields") # An R package to load

D    = 1;         # 1    - The diffusivity parameter
Beta = 1.89;      # 1.89 - The non-parameterical density-dependence parameter
k1   = 0.1;       # 0.1  - The non-local diffusion term

# Simulation parameters
Length=32             #  128 - The length of the simulated landscape, in meters
m=64                  #  128 - # gridcellen
dT=0.01               # 0.25 - timestep
EndTime=1000          #      - Time at which the simulation ends
Numframes=300         #      - Number of frames displayed during the entire simulation

WinWidth=7             #      - Width of the simulation window
WinHeight=5            #      - Height of the simulation window

NX=NY=m                # Setting the grid dimensions
dx=Length/NX           # The size of a grid cell in the x dimension
dy=Length/NY           # The size of a grid cell in the y dimension

# ------ Function definitions
Laplacian <- function (C, dx, dy) {

  NX=dim(C)[2]
  NY=dim(C)[1]

  dC=matrix(nrow=NY, ncol=NX, data=0)

  dC[2:(NY-1),2:(NX-1)] =
    (C[2:(NY-1),1:(NX-2)] + C[2:(NY-1),3:NX] - 2*C[2:(NY-1),2:(NX-1)])/dx/dx +
    (C[1:(NY-2),2:(NX-1)] + C[3:NY,2:(NX-1)] - 2*C[2:(NY-1),2:(NX-1)])/dy/dy

  return(dC)

}

GradientX <- function (C, dx, dy) {

  NX=dim(C)[2]
  NY=dim(C)[1]

  dC=matrix(nrow=NY, ncol=NX, data=0)

  dC[2:(NY-1),2:(NX-1)] =
    - (C[2:(NY-1),1:(NX-2)] - C[2:(NY-1),3:NX] )/dx/2

  return(dC)

}

GradientY <- function (C, dx, dy) {

  NX=dim(C)[2]
  NY=dim(C)[1]

  dC=matrix(nrow=NY, ncol=NX, data=0)

  dC[2:(NY-1),2:(NX-1)] =
    - (C[1:(NY-2),2:(NX-1)] - C[3:NY,2:(NX-1)] )/dy/2

  return(dC)

}

# Initialisation: declaring variable and setting up initial values
# All arrays of dimension m x m

C = matrix(nrow=NY,ncol=NX, data=runif(NY*NX)*1.3)
C = matrix(nrow=NY,ncol=NX, data=0)
X = matrix(nrow=15,ncol=15, data=(1:15)*4)
Y = matrix(nrow=15,ncol=15, data=(1:15)*4, byrow=TRUE)
C[X,Y]=1.3;
dC = matrix(nrow=NY,ncol=NX, data=0)
J2 = J3 = J4 = matrix(nrow=NY-2,ncol=NX-2, data=0)

RecordTimes=(0:Numframes)*EndTime/Numframes
Step=EndTime^(1/(Numframes-1))
RecordTimes=Step^(0:(Numframes-1))

AllData=array(data=0,dim=c(m,m,length(RecordTimes)))

Time  =  1        ; # Begin time
jj    =  1        ; # The counter needed for recording data during the run

# ------- Setting up the figure ------------------------------------------

## Open a graphics window (Darwin stands for a Mac computer)
if (Sys.info()["sysname"]=="Darwin"){
    quartz(width=WinWidth, height=WinHeight, title="Mussel pattern formation")
  } else
    win.graph(width = WinWidth, height = WinHeight)

par(mar=c(3, 4, 2, 6) + 0.1)

# ------------ The simulation loop ---------------------------------------

print(system.time(
while (Time<=EndTime){  # Here the time loop starts

  J0 = (C^2 - Beta*C + 1)*(3*C^2 - 2*Beta*C + 1 )

  J1X = J0 * GradientX(C,dx,dy)
  J2X = D*GradientX(J1X,dx,dy)

  J1Y = J0 * GradientY(C,dx,dy)
  J2Y = D*GradientY(J1Y,dx,dy)

  J3 = Laplacian(C,dx,dy)
  J4 = D * k1 * Laplacian(J3,dx,dy)

  dC = J2X + J2Y - J4

    # Graphic representation of the model every now and then
    if ((Time+dT/100)>=RecordTimes[jj]){   # The dT/100 is to avoid inaccuracy problems

      image.plot(C, zlim=c(0,1.4), xaxt="n", yaxt="n", useRaster=TRUE,
                 col = topo.colors(255),asp=1, bty="n",
                 legend.shrink = 0.99, legend.width = 2)
      title("Mussel density")

      mtext(text=paste("Time : ",sprintf("%1.0f",Time),
                       "of" ,sprintf("%1.0f",EndTime), "Minutes"),
                       side=1, adj=0.5, line=1.5, cex=1)

      dev.flush()
      dev.hold()

      AllData[,,jj]=C

      jj=jj+1 # Increasing the Recorder counter

    }

    C = C + dC*dT;

    # Circular boundary conditions

    C[,1:2]=C[,(NX-3):(NX-2)]
    C[1:2,]=C[(NY-3):(NY-2),]
    C[,(NX-1):NX]=C[,3:4]
    C[(NY-1):NY,]=C[3:4,]

    Time=Time+dT;  # Incrementing time by dT

    #pause

  }

))

save(file='Mussel_PDE.rda',AllData,RecordTimes)

system('say Finished')


#All ACT-R functions are defined here:

# act-r noise
noise <- function(number)
{
    random <- runif(1, min = 0.0001, max = 0.9999)
    number * log( (1 - random ) / random)
}

# function which converts time in ms to an internal representation in pulses
msecs_to_pulses <- function(msecs)
{
    pulse_counter = 0 # number of accumulated pulses
    time_counter <- 0 # passed time
    pulse <- exp_dict$tick_base # length of the initial pulse

    while (time_counter < msecs)
    {
        pulse <- exp_dict$tick_increment * pulse + noise(exp_dict$b * exp_dict$tick_increment * pulse) # generate next pulse
        pulse_counter <- pulse_counter + 1
        time_counter <- time_counter + pulse
    }

    pulse_counter
}

# function which produces time in ms based on an internal representation in pulses
pulse_to_msces <- function(pulses_input)
{

    time_counter <- 0 # passed time
    pulse_counter <- 0 # number of pulses
    pulse <- exp_dict$tick_base # length of the initial pulse

    while (pulse_counter < pulses_input)
    {
        pulse <- exp_dict$tick_increment * pulse + noise(exp_dict$b * exp_dict$tick_increment * pulse) # generate next pulse
        pulse_counter <- pulse_counter + 1
        time_counter <- time_counter + pulse
    }

    time_counter
}

encounter_add <- function(subject_setup, sample_int_pulse)
{
    tmp <- sum(!is.na(subject_setup$DecMem[sample_int_pulse, ])) + 1
    subject_setup$DecMem[sample_int_pulse, tmp] <- subject_setup$real_time
    subject_setup$real_time <- subject_setup$real_time + 100
    subject_setup
}

encounters_get <- function(subject_setup, current_row)
{
    tmp <- subject_setup$DecMem[current_row,]

    if (length(tmp[!is.na(tmp)]) == 0){
        return(NA)
    }else{
        return(tmp[!is.na(tmp)])
    }

}

chunk_activation <- function(encounters, curtime)
{
    if (curtime < min(encounters)) {
        return(NA)
    } else {
        sum((curtime - encounters[encounters<curtime])^exp_dict$decay)
    }
}

prob_calc <- function(current_activation, total_activation)
{
    dividend = sum(current_activation) / exp_dict$parm_t
    divisor = total_activation / exp_dict$parm_t

    retrieval_prob = dividend / divisor
}

blending <- function(subject_setup)
{
    total_activation <- 0
    blended_response <- 0

    for (current_row in seq(1, nrow(subject_setup$DecMem)))
    {
        amount_presentations <- sum(!is.na(subject_setup$DecMem[current_row, ]))

        if (amount_presentations > 0)
        {
            encounters <- encounters_get(subject_setup, current_row)

            current_activation <- chunk_activation(encounters, subject_setup$real_time)

            total_activation <- total_activation + current_activation # ACTIVATION OF THE DECLARATIVE MEMORY
        }
    }

    for (current_row in seq(1, nrow(subject_setup$DecMem)))
    {
        amount_presentations <- sum(!is.na(subject_setup$DecMem[current_row, ]))

        if (amount_presentations > 0)
        {

            encounters <- encounters_get(subject_setup, current_row)

            current_activation <- chunk_activation(encounters, subject_setup$real_time)

            retrieval_prob <- prob_calc(current_activation, total_activation)
            blended_response <- blended_response + (retrieval_prob * current_row)

        }
    }

    blended_response
}


# *************************************************************************
# CMI2NI: Conditional mutual inclusive information(CMI2)-based Network
# Inference method from gene expression data
# *************************************************************************
# This is matlab code for netwrk inference method CMI2NI.
# Input:
# 'data' is expression of variable,in which row is varible and column is the sample;
# 'lamda' is the parameter decide the dependence;
# 'order0' is the parameter to end the program when order=order0;
# If nargin==2,the algorithm will be terminated untill there is no change
# in network toplogy.
# Output:
# 'G' is the 0-1 network or graph after pc algorithm;
# 'Gval' is the network with strenthness of dependence;
# 'order' is the order of the pc algorithm, here is equal to order0;
# Example:
#
# Author: Xiujun Zhang.
# Version: Sept.2014.
#
# Downloaded from: http://www.comp-sysbio.org/cmi2ni/

CMI2NI <- function(data,lamda,order0=NULL){
  data = t(data) # In original implementation, data is given as pxn
  n_gene <- dim(data)[1]
  G <- matrix(1,n_gene,n_gene)
  G[lower.tri(G, diag=T)] <- 0
  G <- G+t(G)
  Gval <- G
  order <- -1
  t <- 0
  while (t == 0){
     order <- order+1
     if (!is.null(order0)){
       if (order>order0){
           order <- order-1
           return(list(G=G,Gval=Gval,order=order))
       }
     }
     res.temp <- edgereduce(G,Gval,order,data,t,lamda)
     G = res.temp$G
     Gval = res.temp$Gval
     t = res.temp$t

     if (t==0){
          print('No edge is reduced! Algorithm  finished!')
          return(list(G=G,Gval=Gval,order=order))
     } else {
          t <- 0
     }
  }
  order <- order-1 # The value of order is the last order of the algorithm
  return(list(G=G,Gval=Gval,order=order))
}

## edgereduce
edgereduce <- function(G,Gval,order,data,t,lamda){
  G0 <- G
  if (order==0){
    for (i in 1:dim(G)[1]){
        for (j in 1:dim(G)[1]){
            if (G[i,j]!=0){
                cmiv <- cmi(data[i,],data[j,])
                Gval[i,j] <- cmiv
                Gval[j,i] <- cmiv
                if (cmiv<lamda){
                    G[i,j] <- 0
                    G[j,i] <- 0
                }
            }
        }
    }
    t <- t+1
    return(list(G=G,Gval=Gval,t=t))
  }
  else {
    for (i in 1:dim(G)[1]){
      for (j in 1:dim(G)[1]){
          if (G[i,j]!=0){
              adj <- c()
              for (k in 1:dim(G)[1]){
                  if (G[i,k]!=0 & G[j,k]!=0){
                      adj <- c(adj,k)
                  }
              }
              if (length(adj)>=order){
                   if(length(adj)==1){ # Need a special case as combn does not work allow single element arguments
                     combntnslist <- as.matrix(adj)
                   }
                   else{
                     combntnslist <- t(combn(adj,order))
                   }
                   combntnsrow <- dim(combntnslist)[1]

                   cmiv <- 0
                   v1 <- data[i,]
                   v2 <- data[j,]
                   for (k in 1:combntnsrow){
                     vcs <- data[combntnslist[k,],]
                     a <- MI2(v1,v2,vcs)
                     cmiv <- max(cmiv,a)
                   }
                   Gval[i,j] <- cmiv
                   Gval[j,i] <- cmiv
                   if (cmiv<lamda){
                      G[i,j] <- 0
                      G[j,i] <- 0
                   }
                   t <- t+1
              }
          }
      }
    }
    return(list(G=G,Gval=Gval,t=t))
  }
}

## compute conditional mutual information of x and y
cmi <- function(v1,v2,vcs=NULL){
 if (is.null(vcs)){
      c1 <- (var(v1)) # removed det as this is just a scalar
      c2 <- (var(v2))
      c3 <- det(cov(t(rbind(v1,v2)))) # cov in r only gives a matrix if we give one, so must use rbind
      cmiv <- 0.5*log(c1*c2/c3)
  }
  else if (!is.null(vcs)){
      c1 <- det(cov(t(rbind(v1,vcs))))
      c2 <- det(cov(t(rbind(v2,vcs))))
      c3 <- (var(t(vcs)))
      c4 <- det(cov(t(rbind(v1,v2,vcs))))
      cmiv <- 0.5*log((c1*c2)/(c3*c4))
  }
  if (cmiv == Inf){
      cmiv <- 1.0e+010
  }
  return(cmiv)
}

# Conditional mutual inclusive information (CMI2)
MI2 <- function(x,y,z){
  r_dmi <- (cas(x,y,z) + cas(y,x,z))/2
  return(r_dmi)
}

# x and y are 1*m dimensional vector; z is n1*m dimensional.
cas <- function(x,y,z){
  # x,y,z are row vectors;
  if(is.null(dim(z))){
    n1 = 1
  }
  else{
    n1 <- dim(z)[1] # This is equal to the order
  }
  n <- n1 +2

  Cov <- var(x)
  Covm <- cov(t(rbind(x,y,z)))
  Covm1 <- cov(t(rbind(x,z)))

  InvCov <- solve(Cov)
  InvCovm <- solve(Covm)
  InvCovm1 <- solve(Covm1)

  C11 <- InvCovm1[1,1] # 1x1
  C12 <- 0 # 1x1
  C13 <- InvCovm1[1,2:(1+n1)] # 1x n1
  C23 <- InvCovm[2,3:(2+n1)]-(InvCovm[1,2] * as.numeric(1/(InvCovm[1,1]-InvCovm1[1,1]+InvCov[1,1]))) %*% (InvCovm[1,3:(2+n1)] - InvCovm1[1,2:(1+n1)]) # 1x n1
  C22 <- InvCovm[2,2]- InvCovm[1,2]^2 * (1/(InvCovm[1,1]-InvCovm1[1,1]+InvCov[1,1])) # 1x1

  C33 <- InvCovm[3:(2+n1),3:(2+n1)]- (as.numeric((1/(InvCovm[1,1]-InvCovm1[1,1]+InvCov[1,1]))) * (t(t(InvCovm[1,3:(2+n1)]-
                                          InvCovm1[1,2:(1+n1)]))%*%(InvCovm[1,3:(2+n1)]-InvCovm1[1,2:(1+n1)]))) # n1 x n1

  InvC <- rbind(c(C11,C12,C13),c(C12,C22,C23),cbind(C13,t(C23),C33))

  C0 <- Cov * (InvCovm[1,1] - InvCovm1[1,1] + InvCov[1,1])
  CS <- 0.5 * (sum(diag(InvC%*%Covm))+log(C0)-n)
  return(CS)
}


#' @name BMGL
#' @rdname  BMGL
#' @title Bivarite MGL and survival MGL copula
#' @description Density, distribution function, and random generation for the bivariate MGL/survival MGL copula with copula parameter \eqn{\delta}.
#' @param u1,u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param pars copula parameter, denoted by \eqn{\delta >0}.
#' @param n number of observations. If length(n) > 1, the length is taken to be the number required.
#' @md
#' @return
#' * \code{dcMGL.bivar}, \code{pcMGL.bivar} and \code{rcMGL.bivar} gives values of density, distribution function, and random generation for the two dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' * \code{dcMGL180.bivar}, \code{pcMGL180.bivar} and \code{rcMGL180.bivar} gives values of density, distribution function, and random generation for the two dimensional survival MGL copula with copula parameter \eqn{\delta>0}.
NULL

#' @rdname  BMGL
#' @export
#' @examples
#' # density function
#' dcMGL.bivar(u1 = 0.001, u2 = 0.999, pars = 1)
dcMGL.bivar <- function(u1, u2, pars) {
  dim <- 2
  a <- 1 / pars
  q1 <- qbeta(1 - u1, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u1, shape1 = 0.5, shape2 = a))
  q2 <- qbeta(1 - u2, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u2, shape1 = 0.5, shape2 = a))
  # if(u1 == 0|u2 == 0|q1 == Inf|q2 == Inf) dc <- 0
  if (q1 == Inf | q2 == Inf) {
    dc <- 0
  } else {
    # q <- cbind(q1, q2)
    # dc <- gamma(a)^(dim - 1)*gamma(a + dim/2)/(gamma(a + 0.5)^dim)*(q1 + 1)^(a + 0.5)*(q2 + 1)^(a + 0.5)/((q1 + q2) + 1)^(a + dim/2)
    dc <- gamma(a)^(dim - 1) / (gamma(a + 0.5)^(dim - 1)) / (gamma(a + 0.5)) * gamma(a + dim / 2) * (q1 + 1)^(a + 0.5) * (q2 + 1)^(a + 0.5) / ((q1 + q2) + 1)^(a + dim / 2)
  }
  return(dc)
}
dcMGL.bivar <- Vectorize(dcMGL.bivar)

#' @rdname BMGL
#' @export
#' @examples
#' # distribution function
#' pcMGL.bivar(u1 = c(0.6, 0.1, 0.7), u2 = c(0.3, 0.6, 0.9), pars = 5)
pcMGL.bivar <- function(u1, u2, pars) {
  a <- 1 / pars
  q1 <- qbeta(1 - u1, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u1, shape1 = 0.5, shape2 = a))
  q2 <- qbeta(1 - u2, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u2, shape1 = 0.5, shape2 = a))
  fin <- function(theta) { # rely on a
    m1 <- pracma::erfc((q1 * theta)^0.5)
    m2 <- pracma::erfc((q2 * theta)^0.5)
    out <- m1 * m2 * theta^(a - 1) * exp(-theta) / gamma(a)
    out
  }
  if (u1 == 0 | u2 == 0) {
    z <- 0
  } else if (u1 == 1 & u2 != 0) {
    z <- u2
  } else if (u1 != 0 & u2 == 1) {
    z <- u1
  } else {
    z <- as.numeric(pracma::integral(fun = fin, xmin = 0, xmax = Inf, method = "Clenshaw"))
  }
  return(z) # rely on k
}
pcMGL.bivar <- Vectorize(pcMGL.bivar)

#' @rdname BMGL
#' @export
#' @examples
#' # random generation
#' rcMGL.bivar(n = 200, pars = 0.8)
rcMGL.bivar <- function(n, pars) {
  Usim <- rcMGL.multi(n = n, pars = pars, d = 2)
  Usim
}

#' @rdname  BMGL
#' @export
#' @examples
#' dcMGL180.bivar(u1 = 0.001, u2 = 0.999, pars = 1)
dcMGL180.bivar <- function(u1, u2, pars) {
  dcMGL.bivar(1 - u1, 1 - u2, pars)
}

#' @rdname BMGL
#' @export
#' @examples
#' pcMGL180.bivar(u1 = c(0.6, 0.1, 0.7), u2 = c(0.3, 0.6, 0.9), pars = 5)
pcMGL180.bivar <- function(u1, u2, pars) {
  u1 + u2 - 1 + pcMGL.bivar(1 - u1, 1 - u2, pars)
}

#' @rdname BMGL
#' @export
#' @examples
#' rcMGL180.bivar(n = 200, pars = 0.8)
rcMGL180.bivar <- function(n, pars) {
  Usim <- rcMGL.multi(n = n, pars = pars, d = 2)
  1 - Usim
}

#' @name hBMGL
#' @rdname  hBMGL
#' @title Conditional Distribution Function of a Bivariate MGL and survival Copula
#'
#' @param u1 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param pars numeric; single number or vector of size length(u1); copula parameter > 0.
#'
#' @details
#' The h-function is defined as the conditional distribution function of a bivariate copula, i.e.,
#' \deqn{h_1(u_2|u_1,\delta) := P(U_2 \leq u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,}
#'
#' \deqn{h_2(u_1|u_2,\delta) := P(U_1 \leq u_1 | U_2 = u_2) := \partial C(u_1,u_2) / \partial u_2,}
#'
#' where \eqn{(U_1, U_2) \sim C}, and \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\delta}. For more details see Aas et al. (2009).
#' @md
#' @return hcMGL.bivar/hcMGL180.bivar returns a list with
#' * hfunc1: \eqn{\partial C(u_1,u_2) / \partial u_1,}
#' * hfunc2: \eqn{\partial C(u_1,u_2) / \partial u_2,}
#' @references
#' Zhengxiao Li, Jan Beirlant, Liang Yang. A new class of copula regression models for modelling multivariate heavy-tailed data. 2021, arXiv:2108.05511.
NULL

#' @rdname hBMGL
#' @export
#' @examples
#' hcMGL.bivar(u1 = c(0.1, 0.001, 0.3), u2 = c(0, 0.9999, 0.88), pars = 2)
hcMGL.bivar <- function(u1, u2, pars) {
  a <- 1 / pars
  # another method
  index1 <- u1 == 0 & u2 != 0
  index2 <- u1 != 0 & u2 == 0
  index3 <- u1 == 0 & u2 == 0
  q1 <- qbeta(1 - u1, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u1, shape1 = 0.5, shape2 = a))
  q2 <- qbeta(1 - u2, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u2, shape1 = 0.5, shape2 = a))
  z1 <- q2 / (q1 + q2 + 1)
  z2 <- q1 / (q1 + q2 + 1)
  z1[index1] <- 0.0000000001
  z2[index1] <- 1
  z1[index2] <- 1
  z2[index2] <- 0.0000000001
  z1[index3] <- 0.5
  z2[index3] <- 0.5

  hfunc1 <- 1 - pbeta(z1, shape1 = 0.5, shape2 = a + 0.5) # Pr(U_2 <= u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,
  hfunc2 <- 1 - pbeta(z2, shape1 = 0.5, shape2 = a + 0.5) # C(u1|u2)
  list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}

#' @rdname hBMGL
#' @export
#' @examples
#' hcMGL180.bivar(u1 = c(0.1, 0.001, 0.3), u2 = c(0, 0.9999, 0.88), pars = 2)
hcMGL180.bivar <- function(u1, u2, pars) {
  hfunc1 <- 1 - hcMGL.bivar(u1 = 1 - u1, u2 = 1 - u2, pars = pars[1])$hfunc1
  hfunc2 <- 1 - hcMGL.bivar(u1 = 1 - u1, u2 = 1 - u2, pars = pars[1])$hfunc2
  out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
  out
}