executeDBScan <- function(dataSetTransformed, base, definitions, executionStatus) {

  # loading packages
  loadRankingPackages()
  library(dbscan)

  # loading functions
  source(here("R/functions", "coverage.r"))
  source(here("R/functions", "utils.r"))
  source(here("R/functions", "chart.r"))

  # generating a random folder name
  folderName <- randomName()
  folderName <- paste("D", executionStatus$BaseSelected, folderName, sep="_")
  createPath(here("R/results", executionStatus$Tecnique, folderName))

  executionStatus$IdExecution <- folderName

  # CONSTANTS
  EPS <- executionStatus$params$tecnique$eps
  MIN_PTS <- executionStatus$params$tecnique$MinPts
  numberOfAttributes <- length(as.array(names(dataSetTransformed)))

  # execução do dbscan nos dados
  dbs <- dbscan(dataSetTransformed[,2:numberOfAttributes], eps = EPS, MinPts = MIN_PTS)

  # cluster of ideal system
  get_cluster <- head(dbs$cluster,1)

  # recuperando os sistemas no mesmo cluster
  systems_candidates <- dataSetTransformed[dbs$cluster==get_cluster,]

  executionStatus$AmountOfRecomendedSystems <- nrow(systems_candidates)

  if(nrow(systems_candidates) < executionStatus$amountOfCandidatesRecomendation)
    closest_systems_candidates <- systems_candidates[0:nrow(systems_candidates),]
  else
    closest_systems_candidates <- systems_candidates[0:executionStatus$amountOfCandidatesRecomendation,]

  executionStatus <- calculateCoverageStatus(closest_systems_candidates, executionStatus, folderName)

  executionStatus
}


#'@title Characterize a given time series' behavior over a given interval
#'
#'@description Determine whether or not a given time series is increasing, decreasing, or constant
#'             over a given interval for a specified change threshold
#'
#'@usage  tsData.intervalChar <- getIntervalCharacterization(tsData,startPos,endPos,changeThreshold)
#'
#'@details Most time series are non-constant even over short intervals.  Therefore, use the \code{changeThreshold}
#'         parameter to specify the percent change that can be tolerated before considering a change meaningful.
#'         Essentially, specify the percent change you're willing to ignore when characterizing a time series over an interval.
#'         If the percent change for each difference is less than or equal to \code{changeThreshold} over the specified interval,
#'         the time series is considered constant over that interval.  Otherwise, the time series is considered either "increasing",
#'         "decreasing", or "eventually constant". This will be determined by the magnitude of the percent change between the first
#'         and last elements in the interval.
#'
#'@param tsData       A time series object.
#'@param startPos      The index of the first time series element to evaluate.
#'@param endPos        The index of the last time series element to evaluate.
#'@param changeThreshold A value between 0 and 1 (inclusive) serving as an upper bound for the percent change
#'                       you're willing to tolerate from one element to the next.
#'
#'@return A string characterizing the time series over the given interval for the specified change threshold.
#'        The return values are: "INCREASNG","DECREASING", "CONSTANT", "EVENTUALLY CONSTANT"
#'
#'@export

getIntervalCharacterization <- function(tsData, startPos, endPos, changeThreshold)
{

	nhoodDf <- getNeighborhoodDf(tsData[startPos:endPos])

	firstValue <- nhoodDf$CURRENT_VALUE[1]
	lastValue  <- nhoodDf$CURRENT_VALUE[nrow(nhoodDf)]

	retVal <- NULL

	if (all(nhoodDf$PCT_CHANGE[-1] <= changeThreshold))
		retVal <- "CONSTANT"
	else if (abs(firstValue-lastValue)/firstValue <= changeThreshold)
		retVal <- "EVENTUALLY CONSTANT"
	else if (sign(lastValue-firstValue) == 1)
		retVal <- "INCREASING"
	else
		retVal <- "DECREASING"

	return (retVal)
}


# GET & SET WD

getwd()
setwd('/content/LoanTest/LoanTest/LoanTest')

#Read from CSV

test<-read.csv('test.csv',header=TRUE,sep=',')
train<-read.csv('train.csv',header=TRUE,sep=',')

#Statistics

install.packages('psych',dep=TRUE)
install.packages('Hmisc',dep=TRUE)
install.packages('e1071', dep=TRUE)

library(psych)
library(Hmisc)
describe(train)
describe(test)
names(train)
names(test)
summary(train)
summary(test)

# /* MASTER DATA PREP START */

#Missing Value Check & Str Check - TRAIN

str(train$UniqueID)
str(train$ltv)
str(train$branch_id)
str(train$State_ID)
str(train$supplier_id)
str(train$manufacturer_id)
str(train$Current_pincode_ID)
names(train)
str(train$Age)
str(train$Employment.Type)
str(Aadhar_flag)
str(train$MobileNo_Avl_Flag)
str(Acct.Age.Num)
str(Credit.History.Length.Num)
train$branch_id<-as.factor(train$branch_id)
train$State_ID<-as.factor(train$State_ID)
train$supplier_id<-as.factor(train$supplier_id)
train$manufacturer_id<-as.factor(train$manufacturer_id)
train$Current_pincode_ID<-as.factor(train$Current_pincode_ID)
sum(is.na(train$Employment.Type))
mode(train$Employment.Type)

attach(train)

MobileNo_Avl_Flag<-as.factor(MobileNo_Avl_Flag)
Aadhar_flag<-as.factor(Aadhar_flag)
PAN_flag<-as.factor(PAN_flag)
VoterID_flag<-as.factor(VoterID_flag)
Driving_flag<-as.factor(Driving_flag)
Passport_flag<-as.factor(Passport_flag)

#attach(test)
#Missing Value Check & Str Check - TEST

str(test$UniqueID)
str(test$ltv)
str(test$branch_id)
str(test$State_ID)
str(test$supplier_id)
str(test$manufacturer_id)
str(test$Current_pincode_ID)
names(test)
str(test$Age)
str(test$Employment.Type)
str(Aadhar_flag)
str(test$MobileNo_Avl_Flag)
str(Acct.Age.Num)
str(Credit.History.Length.Num)
test$branch_id<-as.factor(test$branch_id)
test$State_ID<-as.factor(test$State_ID)
test$supplier_id<-as.factor(test$supplier_id)
test$manufacturer_id<-as.factor(test$manufacturer_id)
test$Current_pincode_ID<-as.factor(test$Current_pincode_ID)
sum(is.na(test$Employment.Type))
test$MobileNo_Avl_Flag<-as.factor(test$MobileNo_Avl_Flag)
test$Aadhar_flag<-as.factor(test$Aadhar_flag)
test$PAN_flag<-as.factor(test$PAN_flag)
test$VoterID_flag<-as.factor(test$VoterID_flag)
test$Driving_flag<-as.factor(test$Driving_flag)
test$Passport_flag<-as.factor(test$Passport_flag)

# Data Transformation - TRAIN

train$Scaled_Disbursed<-log(train$disbursed_amount)
train$Scaled_AssetCost<-log(train$asset_cost)
train$ScaledLTV<-train$ltv/10
train$Scaled_Primary_Num_Accts<-sqrt(train$PRI.NO.OF.ACCTS)
train$Scaled_Primary_Active_Accts<-sqrt(train$PRI.ACTIVE.ACCTS)
train$Scaled_Primary_Overdue_Accts<-sqrt(train$PRI.OVERDUE.ACCTS)
train$Scaled_Primary_Curr_Bal<-(train$PRI.CURRENT.BALANCE)+1
train$New_Scaled_Primary_Curr_Bal<-log(train$Scaled_Primary_Curr_Bal)
train$Scaled_Primary_Sanct_Amt<-(train$PRI.SANCTIONED.AMOUNT)+1
train$New_Scaled_Primary_Sanct_Amt<-log(train$Scaled_Primary_Sanct_Amt)
train$Scaled_Primary_Disbursed_Amt<-(train$PRI.DISBURSED.AMOUNT)+1
train$New_Scaled_Primary_Disbursed_Amt<-log(train$Scaled_Primary_Disbursed_Amt)
train$Scaled_Secondary_Num_Accts<-sqrt(train$SEC.NO.OF.ACCTS)
train$Scaled_Secondary_Active_Accts<-sqrt(train$SEC.ACTIVE.ACCTS)
train$Scaled_Secondary_Overdue_Accts<-sqrt(train$SEC.OVERDUE.ACCTS)
train$Scaled_Secondary_Curr_Bal<-(train$SEC.CURRENT.BALANCE)+1
train$New_Scaled_Secondary_Curr_Bal<-log(train$Scaled_Secondary_Curr_Bal)
train$Scaled_Secondary_Sanct_Amt<-(train$SEC.SANCTIONED.AMOUNT)+1
train$New_Scaled_Secondary_Sanct_Amt<-log(train$Scaled_Secondary_Sanct_Amt)
train$Scaled_Secondary_Disbursed_Amt<-(train$SEC.DISBURSED.AMOUNT)+1
train$New_Scaled_Secondary_Disbursed_Amt<-log(train$Scaled_Secondary_Disbursed_Amt)
train$Scaled_Primary_Installment_Amount<-(train$PRIMARY.INSTAL.AMT)+1
train$New_Scaled_Primary_Installment_Amount<-log(train$Scaled_Primary_Installment_Amount)
train$Scaled_Secondary_Installment_Amount<-(train$SEC.INSTAL.AMT)+1
train$New_Scaled_Secondary_Installment_Amount<-log(train$Scaled_Secondary_Installment_Amount)
train$Scaled_New_Accts_in_6_Mo<-sqrt(train$NEW.ACCTS.IN.LAST.SIX.MONTHS)
train$Scaled_Delinquent_Accts_in_7_Mo<-sqrt(train$DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS)
sum(is.na(train$New_Scaled_Primary_Curr_Bal))
train$New_Scaled_Primary_Curr_Bal<-ifelse(is.na(train$New_Scaled_Primary_Curr_Bal),0,train$New_Scaled_Primary_Curr_Bal)
sum(is.na(train$New_Scaled_Secondary_Curr_Bal))
train$New_Scaled_Secondary_Curr_Bal<-ifelse(is.na(train$New_Scaled_Secondary_Curr_Bal),0,train$New_Scaled_Secondary_Curr_Bal)
write.csv(train, file="Train_interim.csv")

# Data Transformation - TEST

test$Scaled_Disbursed<-log(test$disbursed_amount)
test$Scaled_AssetCost<-log(test$asset_cost)
test$ScaledLTV<-test$ltv/10
test$Scaled_Primary_Num_Accts<-sqrt(test$PRI.NO.OF.ACCTS)
test$Scaled_Primary_Active_Accts<-sqrt(test$PRI.ACTIVE.ACCTS)
test$Scaled_Primary_Overdue_Accts<-sqrt(test$PRI.OVERDUE.ACCTS)
test$Scaled_Primary_Curr_Bal<-(test$PRI.CURRENT.BALANCE)+1
test$New_Scaled_Primary_Curr_Bal<-log(test$Scaled_Primary_Curr_Bal)
test$Scaled_Primary_Sanct_Amt<-(test$PRI.SANCTIONED.AMOUNT)+1
test$New_Scaled_Primary_Sanct_Amt<-log(test$Scaled_Primary_Sanct_Amt)
test$Scaled_Primary_Disbursed_Amt<-(test$PRI.DISBURSED.AMOUNT)+1
test$New_Scaled_Primary_Disbursed_Amt<-log(test$Scaled_Primary_Disbursed_Amt)
test$Scaled_Secondary_Num_Accts<-sqrt(test$SEC.NO.OF.ACCTS)
test$Scaled_Secondary_Active_Accts<-sqrt(test$SEC.ACTIVE.ACCTS)
test$Scaled_Secondary_Overdue_Accts<-sqrt(test$SEC.OVERDUE.ACCTS)
test$Scaled_Secondary_Curr_Bal<-(test$SEC.CURRENT.BALANCE)+1
test$New_Scaled_Secondary_Curr_Bal<-log(test$Scaled_Secondary_Curr_Bal)
test$Scaled_Secondary_Sanct_Amt<-(test$SEC.SANCTIONED.AMOUNT)+1
test$New_Scaled_Secondary_Sanct_Amt<-log(test$Scaled_Secondary_Sanct_Amt)
test$Scaled_Secondary_Disbursed_Amt<-(test$SEC.DISBURSED.AMOUNT)+1
test$New_Scaled_Secondary_Disbursed_Amt<-log(test$Scaled_Secondary_Disbursed_Amt)
test$Scaled_Primary_Installment_Amount<-(test$PRIMARY.INSTAL.AMT)+1
test$New_Scaled_Primary_Installment_Amount<-log(test$Scaled_Primary_Installment_Amount)
test$Scaled_Secondary_Installment_Amount<-(test$SEC.INSTAL.AMT)+1
test$New_Scaled_Secondary_Installment_Amount<-log(test$Scaled_Secondary_Installment_Amount)
test$Scaled_New_Accts_in_6_Mo<-sqrt(test$NEW.ACCTS.IN.LAST.SIX.MONTHS)
test$Scaled_Delinquent_Accts_in_7_Mo<-sqrt(test$DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS)
sum(is.na(test$New_Scaled_Primary_Curr_Bal))
test$New_Scaled_Primary_Curr_Bal<-ifelse(is.na(test$New_Scaled_Primary_Curr_Bal),0,test$New_Scaled_Primary_Curr_Bal)
sum(is.na(test$New_Scaled_Secondary_Curr_Bal))
test$New_Scaled_Secondary_Curr_Bal<-ifelse(is.na(test$New_Scaled_Secondary_Curr_Bal),0,test$New_Scaled_Secondary_Curr_Bal)
sum(is.na(test$New_Scaled_Primary_Sanct_Amt))
test$New_Scaled_Primary_Sanct_Amt<-ifelse(is.na(test$New_Scaled_Primary_Sanct_Amt),0,test$New_Scaled_Primary_Sanct_Amt)

sum(is.na(train$Scaled_New_Primary_Curr_Bal))
names(train)
train$Scaled_New_Primary_Curr_Bal<-ifelse(is.na(train$Scaled_New_Primary_Curr_Bal),0,train$Scaled_New_Primary_Curr_Bal)
sum(is.na(train$New_Scaled_Secondary_Curr_Bal))

# /* MASTER DATA PREP END */

# Check for Significant Variables by running GLM - 78.2%

LogReg<-glm(loan_default~Scaled_Disbursed+Scaled_AssetCost+ScaledLTV+Scaled_Primary_Num_Accts+
              Scaled_Primary_Active_Accts+Scaled_Primary_Overdue_Accts+
              New_Scaled_Primary_Sanct_Amt+New_Scaled_Primary_Disbursed_Amt+Scaled_Secondary_Num_Accts+
              Scaled_Secondary_Active_Accts+Scaled_Secondary_Overdue_Accts+
              New_Scaled_Secondary_Sanct_Amt+New_Scaled_Secondary_Disbursed_Amt+New_Scaled_Primary_Installment_Amount+
              New_Scaled_Secondary_Installment_Amount+Age+Employment.Type+State_ID+MobileNo_Avl_Flag+Aadhar_flag+
              PAN_flag+VoterID_flag+Driving_flag+Passport_flag+PERFORM_CNS.SCORE+Acct.Age.Num+Credit.History.Length.Num+
              NO.OF_INQUIRIES+NEW.ACCTS.IN.LAST.SIX.MONTHS+DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS,data=train,family='binomial')
plot(LogReg)

train$YPredict<-predict.glm(LogReg,train,type='response')
View(train)
train$Loan_Status_Predicted<-ifelse(train$YPredict>=0.5,1,0)
table(train$Loan_Status_Predicted)

#Confusion Matrix - GLM - 78.2%

table(train$Loan_Status_Predicted,train$loan_default)

library(e1071)
SVcL <- svm(loan_default~Scaled_Disbursed+Scaled_AssetCost+ScaledLTV+Scaled_Primary_Num_Accts+
             Scaled_Primary_Active_Accts+Scaled_Primary_Overdue_Accts+
             New_Scaled_Primary_Sanct_Amt+New_Scaled_Primary_Disbursed_Amt+Scaled_Secondary_Num_Accts+
             Scaled_Secondary_Active_Accts+Scaled_Secondary_Overdue_Accts+
             New_Scaled_Secondary_Sanct_Amt+New_Scaled_Secondary_Disbursed_Amt+New_Scaled_Primary_Installment_Amount+
             New_Scaled_Secondary_Installment_Amount+Age+Employment.Type+State_ID+MobileNo_Avl_Flag+Aadhar_flag+
             PAN_flag+VoterID_flag+Driving_flag+Passport_flag+PERFORM_CNS.SCORE+Acct.Age.Num+Credit.History.Length.Num+
             NO.OF_INQUIRIES+NEW.ACCTS.IN.LAST.SIX.MONTHS+DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS,data=train,kernel=("radial"))

			 train$svmradialPreds <- predict(SVcL,train)
cm_SVcL <- table(train$svmradialPreds, train$loan_default)
Accuracy_svmRadial_train <- sum(diag(cm_SVcL))/sum(cm_SVcL)
Accuracy_svmRadial_train #1 for Trial on 180320192311
sensitivity_svmRadial_train <- cm_SVcL[1,1] / (cm_SVcL[1,1] + cm_SVcL[2,1])
sensitivity_svmRadial_train #1 for Trial on 180320192311
Specificity_svmRadial_train <- cm_SVcL[2,2] / (cm_SVcL[2,2] + cm_SVcL[1,2])
Specificity_svmRadial_train #1 for Trial on 180320192311

#Juxtapose on Test

test$Predict_SVC_Loan_Default<-predict(SVcL,test)
write.csv(test, file ="Final_Test_Preds.csv")


library(sf)
library(purrr) # for flatten
library(ggplot2)

ozbig <- read_sf("data/gadm36_AUS_shp/gadm36_AUS_1.shp")
oz <- thin(ozbig)
# oz = ozbig

# Each oz$geometry[[i]][[j]][[1]] is a polygon
ozgeo = oz$geometry

f = function(l){
  l = l %>% flatten() %>% flatten()
  for(i in 1:length(l)){
    l[[i]] = data.frame(l[[i]])
    colnames(l[[i]]) = c('long', 'lat')
    l[[i]]$order = 1:nrow(l[[i]])
    l[[i]]$group = i
  }
  do.call(rbind, l)
}

ozplus = f(ozgeo)
ozplus %>% ggplot(aes(x = long, y = lat, group = group)) + geom_polygon()


#' Optimal Leader/Mentor Matching
#'
#' Implementes the algorithm described in Valente and Davis (1999)
#'
#' @template graph_template
#' @param n Number of leaders
#' @param cmode Passed to \code{\link{dgr}}.
#' @param lead.ties.method Passed to \code{\link{rank}}
#' @param geodist.args Passed to \code{\link{approx_geodesic}}.
#'
#' @details The algorithm works as follows:
#' \enumerate{
#'   \item Find the top \code{n} individuals ranking them by \code{dgr(graph, cmode)}.
#'   The rank is computed by the function \code{\link{rank}}. Denote this set \code{M}.
#'   \item Compute the geodesic matrix.
#'   \item For each \code{v in V} do:
#'
#'   \enumerate{
#'     \item Find the mentor \code{m in M} such that is closest to \code{v}
#'     \item Were there a tie, choose the mentor that minimizes the average
#'     path length from \code{v}'s direct neighbors to \code{m}.
#'     \item If there are no paths to any member of \code{M}, or all have the
#'     same average path length to \code{v}'s neighbors, then assign one
#'     randomly.
#'   }
#' }
#'
#' @return An object of class \code{diffnet_mentor} and \code{data.frame} with the following columns:
#' \item{name}{Character. Labels of the vertices}
#' \item{degree}{Numeric. Degree of each vertex in the graph}
#' \item{iselader}{Logical. \code{TRUE} when the vertex was picked as a leader.}
#' \item{match}{Character. The corresponding matched leader.}
#'
#' The object also contains the following attributes:
#'
#' \item{nleaders}{Integer scalar. The resulting number of leaders (could be greater than \code{n})}.
#' \item{graph}{The original graph used to run the algorithm.}
#'
#' @references
#' Valente, T. W., & Davis, R. L. (1999). Accelerating the Diffusion of
#' Innovations Using Opinion Leaders. The ANNALS of the American Academy of
#' Political and Social Science, 566(1), 55–67.
#' \doi{10.1177/000271629956600105}
#' @examples
#' # A simple example ----------------------------------------------------------
#' set.seed(1231)
#' graph <- rgraph_ws(n=50, k = 4, p = .5)
#'
#' # Looking for 3 mentors
#' ans <- mentor_matching(graph, n = 3)
#'
#' head(ans)
#' table(ans$match) # We actually got 9 b/c of ties
#'
#' # Visualizing the mentor network
#' plot(ans)
#'
#' @export
mentor_matching <- function(
  graph,
  n,
  cmode            = "indegree",
  lead.ties.method = "average",
  geodist.args     = list()
) {

  cls <- class(graph)

  if (any(c("dgCMatrix", "matrix", "array") %in% cls)) {
    # Adding labels in case there aren't any
    if (!length(rownames(graph))) {
      warning("-graph- as no labels (rownames). We'll add some from 1 to n.")
      dimnames(graph) <- list(1:nnodes(graph), 1:nnodes(graph))
    }
  }

  if (any(c("dgCMatrix", "matrix") %in% cls)) {

    # Matrix method
    .mentor_matching(graph, n, cmode, lead.ties.method, geodist.args)

  } else if ("list" %in% cls) {

    # List method
    lapply(graph, .mentor_matching, n = n,
           cmode = cmode, lead.ties.method = lead.ties.method,
           geodist.args = geodist.args)

  } else if ("array" %in% cls) {

    # Array method
    apply(graph, 3, .mentor_matching, n = n,
          cmode = cmode, lead.ties.method = lead.ties.method,
          geodist.args = geodist.args)

  } else if ("diffnet" %in% cls) {

    # diffnet method
    g <- graph$graph
    g <- lapply(g, `dimnames<-`, value = list(nodes(graph), nodes(graph)))
    lapply(g, .mentor_matching, n = n,
           cmode = cmode, lead.ties.method = lead.ties.method,
           geodist.args = geodist.args)

  } else stopifnot_graph(graph)

}

.mentor_matching <- function(
  graph,
  n,
  cmode            = "indegree",
  lead.ties.method = "average",
  geodist.args     = list()
) {

  # Step 1. Find the pcent with highest
  d   <- dgr(graph, cmode = cmode)
  r   <- -rank(d, ties.method = lead.ties.method)
  r   <- as.integer(as.factor(r))
  top <- which(r <= n)

  # Step 2: Match each individual with their closest one
  G   <- do.call(
    approx_geodist,
    c(list(graph = as.matrix(graph)), geodist.args)
  )

  ans <- sapply(1:nnodes(graph), function(i) {
    x <- which(G[i,top] == min(G[i,top]))

    # If there are any ties, then solve them by taking a look at i's
    # neighbors
    if (length(x) > 1) {

      # Picking neighbors
      j <- which(graph[i,-top] != 0)

      # If all of them are top
      if (!length(j))
        return(sample(top, size = 1))

      # Average pathlength per top
      j <- sapply(top, function(h) {
        mean(G[j,h])
      })

      # Choose the min
      top[which.min(j)]

    } else top[x]
  })

  # Mentors should be assigned to them selfs
  ans[top] <- top

  # Returning
  structure(
    data.frame(
      name     = nodes(graph),
      degree   = d,
      isleader = 1:nnodes(graph) %in% top,
      match    = nodes(graph)[ans],
      stringsAsFactors = FALSE
    ),
    class    = c("diffnet_mentor", "data.frame"),
    nleaders = length(top),
    graph    = graph
  )

}

#' @export
#' @rdname mentor_matching
leader_matching <- mentor_matching

#' @export
#' @param x An object of class \code{diffnet_mentor}.
#' @template plotting_template
#' @param lead.cols Character vector of length \code{attr(x,"nleaders")}. Colors
#' to be applied to each group. (see details)
#' @param vshapes Character scalar of length 2. Shapes to identify leaders (mentors)
#' and followers respectively.
#' @param add.legend Logical scalar. When \code{TRUE} generates a legend to distinguish
#' between leaders and followers.
#' @param y Ignored.
#' @param ... Further arguments passed to \code{\link[igraph:plot.igraph]{plot.igraph}}
#' @param main Character scalar. Passed to \code{\link[graphics:title]{title}}
#' @rdname mentor_matching
plot.diffnet_mentor <- function(
  x,
  y            = NULL,
  vertex.size  = "degree",
  minmax.relative.size = getOption("diffnet.minmax.relative.size", c(0.01, 0.04)),
  lead.cols    = grDevices::topo.colors(attr(x, "nleaders")),
  vshapes      = c(Leader="square", Follower="circle"),
  add.legend   = TRUE,
  main         = "Mentoring Network",
  ...) {

  igraph.args <- list(...)
  oldpar <- graphics::par(no.readonly = TRUE)
  on.exit(graphics::par(oldpar))
  graphics::par(xpd = NA)

  set_igraph_plotting_defaults("igraph.args")

  # Creating igraph obj
  ig <- cbind(
    as.character(x[["name"]]),
    as.character(x[["match"]])
  )

  ig <- edgelist_to_adjmat(ig)
  ig <- ig[x[["name"]],][,x[["name"]]]
  ig <- igraph::graph_from_adjacency_matrix(ig, weighted = NULL)

  # Creating plot
  graphics::plot.new()
  graphics::plot.window(xlim = c(-1,1), ylim = c(-1,1))

  igraph::V(ig)$shape <- vshapes[2-x[["isleader"]]]

  igraph.args$vertex.size <- rescale_vertex_igraph(
    compute_vertex_size(ig, vertex.size),
    minmax.relative.size = minmax.relative.size
  )

  igraph.args$vertex.color <- lead.cols[as.integer(factor(x[["match"]]))]

  do.call(igraph::plot.igraph, c(list(x = ig), igraph.args))

  if (add.legend) {

    # Checking names
    if (!length(names(vshapes)))
      names(vshapes) <- c("Leader", "Follower")

    A<-B<-1
    ig <- igraph::make_graph(~A,B)
    igraph::V(ig)$name  <- names(vshapes)
    igraph::V(ig)$color <- "gray"
    igraph::V(ig)$label.color <- "black"
    igraph::V(ig)$shape <- vshapes
    igraph::V(ig)$size  <- 2
    plot(ig, layout = rbind(c(-.4, -1.3), c(.15, -1.3)), add=TRUE,
         vertex.size = 5, rescale=FALSE, vertex.label.dist = 1, vertex.label.degree=0)

  }

  title(main=main)

  # Returning
  invisible(x)

}


clusterFraction <- function(kvec){
## Given a K-means object return a labeling that includes
##  the cluster number and fraction of elements within
##  that cluster
##
## Args:
##   kvec: a k-means object or vector of cluster labels
##
## Return:
##   cs: a vector of length ncol(kvec$centers) formatted
##          e.g. "C1 0.45".  That is Cluster 1, 45% of total.

require(foreach)

if(class(kvec) == "kmeans"){
    labs <- kvec$cluster
    } else {
        labs <- kvec
    }

cs <- paste(paste0("C",1:max(labs)," "),
   foreach(i =1:max(labs),.combine=c)%do%{(sprintf("%.2g",sum(labs==i)/length(labs)))})

return(cs)
}


chart_3 <- function(incarceration_data){
 state_prop_black <- incarceration_data %>%
    filter(year == 2018) %>%
    select(state, black_jail_pop, total_jail_pop) %>%
    na.omit() %>%
      group_by(state) %>%
        summarise(Proportion = mean(black_jail_pop/total_jail_pop, na.rm = TRUE))
 us <- map_data("state")
  statedf <- data.frame(state = state.abb, region = tolower(state.name))
  state_prop_black <- state_prop_black %>%
    left_join(statedf)
  ggplot() +
    geom_map(data = us, map = us, aes(x = long, y = lat, map_id = region)) +
    geom_map(data = state_prop_black, map = us, aes(fill = Proportion, map_id = region)) +
    coord_map("albers", lat0 = 39, lat1 = 45) +
    labs(title = "Percentage of Jail Population that are Black in each State", x = "Longitude", y = "Latitutde" ) +
    theme_minimal()

}


# Load packages
library(tidytuesdayR)
library(tidyverse)
library(showtext)
library(patchwork)
library(ggtext)
library(ggflags)
library(countrycode)

# add fonts
font_add_google("Poppins", "Poppins")
font_add_google("Bitter", "Bitter")
font_add_google("Merienda", "Merienda")
showtext_auto()

# import tidytuesday data
tuesdata <- tidytuesdayR::tt_load(2021, week = 43)
pumpkins <- tuesdata$pumpkins

# clean data
pumpkins_clean <- pumpkins %>%
  separate(id, c("Year", "Type"), remove = FALSE) %>%
  filter(Type == "P" & place != "EXH" & weight_lbs != "") %>%
  filter(!country %in% c("United States", "Canada", "New Zealand", "Australia", "Japan")) %>%
  mutate(weight_lbs = as.numeric(gsub(",", "",  weight_lbs)),
         est_weight = as.numeric(gsub(",", "",  est_weight)),
         weight_kg = as.numeric(weight_lbs)*0.453592,
         est_weight_kg = as.numeric(est_weight)*0.453592,
         Year = as.numeric(Year),
         place = if_else(!is.na(place), as.numeric(place), as.double(NA)),
         type_decode = "Giant Pumpkin") %>%
  arrange(desc(place)) %>%
  #sample_n(nrow(.)) %>%
  rowid_to_column()

# Maximum Pumpkins Weight per year and GPC site each year
pumpkins_highest_persite <- pumpkins_clean %>%
  group_by(gpc_site, Year) %>%
  summarise(max_insite = max(weight_kg), na.rm = TRUE) %>%
  filter(!is.na(max_insite))

# Average Pumpkins Weight per GPC site from 2013 to 2021
pumpkins_average_persite <- pumpkins_clean %>%
  group_by(gpc_site) %>%
  summarise(mean_insite = mean(weight_kg, na.rm = TRUE))

# Number of particpations, keep only GPC sites with at least 6 participation over the last 9 years
nb_participation <- pumpkins_highest_persite %>%
  arrange(gpc_site, Year) %>%
  summarise(n_year = n()) %>%
  filter(n_year >= 6)

# Combine all df
pumpkins_highest_persite <-  pumpkins_highest_persite %>%
  inner_join(nb_participation, by =  "gpc_site") %>%
  inner_join(pumpkins_average_persite, by =  "gpc_site") %>%
  arrange(desc(mean_insite)) %>%
  filter(gpc_site != "Central Market Giant Pumpkin Weigh-off")

# Label each GPC site on Y axis
labs <- pumpkins_highest_persite %>%
  distinct(gpc_site, mean_insite) %>%
  rowid_to_column()

pumpkins_highest_persite <- pumpkins_highest_persite %>%
  inner_join(labs, by = "gpc_site")

# Add some meaningful text
pumpkins.top <- pumpkins_highest_persite %>%
  ungroup() %>%
  top_n(., 1, max_insite) %>%
  mutate(weight_kg = round(max_insite, 2),
         rowid = fct_reorder(as.character(rowid), mean_insite.x, max),
         label = glue::glue("Pumpkin from the Guinness Book of Records
in Italy: weighs {weight_kg} kg
it was presented at the Festa dello Zuccone in the province of Pisa."))

df_labs <-
  tibble(
    gpc = fct_reorder(labs$gpc_site, labs$mean_insite, max),
    rowid =  fct_reorder(as.character(labs$rowid), labs$mean_insite, max),
    country = case_when(gpc == "Europameisterschaft im Kurbiswiegen" ~ "Germany",
                        gpc == "Dutch Giant Vegetable Championship" ~ "The Netherlands",
                        gpc == "Early Weigh-off Ludwigsburg" ~ "Germany",
                        gpc == "Gartenbauschule Langenlois" ~ "Austria",
                        gpc == "Campionato dello Zuccone" ~ "Italy",
                        gpc == "XXL-Kuerbis-Wiegemeisterschaft auf dem Krewelshof" ~ "Germany",
                        gpc == "Le Potager Extraordinaire" ~ "France",
                        gpc == "Festa della zucca di sale" ~ "Italy",
                        gpc == "Schweizer Meisterschaft im Kurbiswagen" ~ "	Switzerland",
                        gpc == "Tharinger Meisterschaft" ~ "Germany",
                        gpc == "Concurso Calabazas Gigantes de Valtierra" ~ "Spain",
                        gpc == "Slovenian Weigh-off" ~ "Slovenia",
                        gpc == "Austrian Weigh-off" ~ "Austria",
                        gpc == "Royal Victoria Country Park" ~ "United Kingdom",
                        gpc == "Wiegemeisterschaft Berlin/Brandenburg" ~ "Germany",
                        gpc == "Pesa la Zucca! Foiano" ~ "Italy",
                        gpc == "Saechsische Meisterschaft im Kurbiswiegen" ~ "Germany",
                        gpc == "Finnish Weigh-off" ~ "Finland")
  )

# Country flags
flags <- df_labs %>%
  distinct(country) %>%
  pull(country)

flags_code <- countrycode(flags, 'country.name', 'iso2c') %>%
  as_tibble() %>%
  rename(flag = value) %>%
  mutate(flag = str_to_lower(flag))

as_tibble(flags) %>%
  bind_cols(flags_code) -> names

df_labs <- df_labs %>%
  left_join(names, by = c("country" = "value"))

# Create heatmap
ggplot(data= pumpkins_highest_persite, aes(Year, fct_reorder(as.character(rowid), mean_insite.x, max))) +
  # heatmap
  geom_tile(aes(fill= max_insite)) +
  # fill color, orange
  scale_fill_gradient(low="white", high="#f8cd24") +
  # add flag of each country where festival happen
  geom_flag(
    data = df_labs,
    aes(x = 2012, y = rowid, country = flag), size = 10
  ) +
  # Customize axis text on Y axis
  geom_text(
    data = df_labs,
    aes(x = 2021.8, y = rowid, label = gpc,
        color = gpc, color = after_scale(darken(sequential_hcl(n = 18, h = c(0, 90), c = c(80, NA, 30), l = c(30, 90), power = c(0.2, 2), register = ),.2))),
    hjust = 0, size = 4.9, family = "Merienda", fontface = "italic", lineheight = 1.50
  ) +
  # Add annotations and curves
  geom_richtext(
    data = pumpkins.top,
    aes(x=Year-1, y=11.5, label = label, hjust = 0.5, family = "Bitter"),
    color = "#b8321a",
    fill = NA,
    label.color = NA
  ) +
  geom_curve(
    data = pumpkins.top,
    aes(
      x = Year-1.6, xend = Year,
      y = 12.3, yend = 14
    ),
    color = "black",
    size = 1.5,
    curvature = -.35
  ) +
  geom_richtext(
    data = pumpkins.top,
    aes(x=2016, y=17, label = "Previous record was hold by **Mathias Willemijns** (Belgium)
who made grown a giant pumpkin of 1,190.49 kg",
        hjust = 1, family = "Bitter"),
    color = "#b8321a",
    fill = NA,
    label.color = NA
  ) +
  geom_curve(
    data = pumpkins.top,
    aes(
      x = 2014.5, xend = 2016.15,
      y = 16.5, yend = 18
    ),
    color = "black",
    size = 1.5,
    curvature = .75
  ) +
  geom_richtext(
    data = pumpkins.top,
    aes(x=2021.8, y=19, label = "Europe GPC Festivals
ranked by Pumpkins avg weights presented from 2013 to 2021",
        hjust = 0, family = "Bitter"),
    color = "#b8321a",
    fill = NA,
    label.color = NA
  ) +
  # Customize axis scales
  scale_x_continuous(limits =c(NA, 2026.5), breaks = seq(2013, 2021, by = 1), position = "top") +
  scale_color_discrete(guide = "none") +
  # Guide for colorbar
  guides(fill = guide_colorbar(barheight = unit(2.6, units = "mm"),
                               barwidth = unit(160, units = "mm"),
                               direction = "horizontal",
                               title = "Maximum Pumpkins Weight (kg) presented per GPC festival over each year",
                               ticks.colour = "grey20",
                               title.position = "top",
                               label.position = "top",
                               title.hjust = 0.5)) +
  # black theme
  theme_void() +
  coord_cartesian(clip = "off", expand = FALSE) +
  # add title/subtitles and caption
  labs(title = "Where to go in Europe to see Giant Pumpkin Festivals ?
",
       subtitle = "The Great Pumpkin Commonwealth's (GPC) mission cultivates the hobby of growing giant pumpkins throughout the world !
They organize yearly festivals across Europe, find the most amazing to visit near you!

",
       caption = "Visualization by Guillaume Abgrall • Data from BigPumpkins.com") +
  # Customize theme further
  theme(
    plot.title = element_markdown(family = "Bitter"),
    plot.subtitle = element_markdown(family = "Bitter"),
    plot.caption = element_text(family = "Bitter", size = "8", hjust=0.98),
    axis.text.x = element_text(family = "Poppins", size = "15pt", vjust=1.5, face = "italic"),
    axis.text.y = element_blank(),
    plot.margin = margin(10, 25, 10, 25),
    legend.margin = margin(10, 200, 25, -150),
    legend.position = "bottom",
    legend.title = element_text(family = "Bitter")
  )

# Save plot
path <- here::here("pumpkins_heatmap")
ggsave(glue::glue("{path}.pdf"), width = 16.5, height = 12, device = cairo_pdf)
pdftools::pdf_convert(pdf = glue::glue("{path}.pdf"),
                      filenames = glue::glue("{path}.png"),
                      format = "png", dpi = 300)


#'  essentially the same as ecdf, but over-writes the max value with the next largest quantile

	quantile_estimate = function(x) {
		i = which( is.finite( x) )
		pr = ecdf(x[i]) ( x[i] )
		ix = which( pr ==1 )
		if ( !{ length(ix) %in% c(0, length(x)) } )  pr[ix] = max( pr[-ix] )
		x[i] = pr
		return(x)
	}


library(bit64)
library(data.table)
library(dplyr)
library(ggplot2)
library(stringr)
library(tidyr)

# Return and export batch size dependent mean processing time (unit: 1e-8 sec).
# Unavailable / unobserved batch sizes are interpolated via a linear fit.
exportBatchSizeDependentMeanProcessingTime <- function(parsedData, filename = F, theFun = mean, mark = F, beta = 256, minN = 50) {
    meanE8.all <- parsedData %>%
        group_by(vecsize) %>%
        summarise(meanE8 = theFun(clocks) * clockDuration * 1e8, n = n()) %>%
        filter(n > minN) %>%
        select(vecsize, meanE8)
    # Use linear fit for vector sizes that have not been observed.
    e8.fit <- lm(meanE8 ~ vecsize, data = meanE8.all)
    e8.pred <- data.frame(meanE8 = predict(e8.fit, data.frame(vecsize = setdiff(0:beta, meanE8.all$vecsize))), vecsize = setdiff(0:beta, meanE8.all$vecsize))
    if (mark) {
        e8.join <- rbind(meanE8.all %>% mutate(type = "Meas"), e8.pred %>% mutate(type = "fit")) %>% arrange(vecsize)
    } else {
        e8.join <- rbind(meanE8.all, e8.pred) %>% arrange(vecsize)
    }
    if (is.character(filename)) {
        write.table(e8.join, file = filename, row.names = F, col.names = F, sep = ",")
    }
    return(e8.join)
}

# Convert bitrate [bps] and packet size [B] to packet interarrival time [s].
rate2iat <- function(theRate, packetSize = 64) {
    return((theRate / 8 / packetSize) ^ -1)
}

# Convert rate in Mbps to interarrival time in multiples of 1e-8sec (10ns).
rate2e8iat <- function(therate) {
    return((84 * 8) / (therate * 1e6) * 1e8)
}


# title: "Chapter 4. Clustering and classification"
# author: "Tuure Parviainen"
# date: "November 29, 2017"

# meta http://hdr.undp.org/en/content/human-development-index-hdi
# Info http://hdr.undp.org/sites/default/files/hdr2015_technical_notes.pdf

require("easypackages") # for loading and installing many packages at one time
packages_to_load <- c("dplyr", "tidyverse", "ggplot2", "GGally")
packages(packages_to_load, prompt = TRUE) # lock'n'load install/load

setwd(dirname(rstudioapi::getActiveDocumentContext()$path)) # to set

hd <- read.csv("http://s3.amazonaws.com/assets.datacamp.com/production/course_2218/datasets/human_development.csv", stringsAsFactors = F)
glimpse(hd)
gii <- read.csv("http://s3.amazonaws.com/assets.datacamp.com/production/course_2218/datasets/gender_inequality.csv", stringsAsFactors = F, na.strings = "..")
glimpse(gii)

hdnames <- c("HDI.rank", "country", "HDI", "LE","edu", "edu.mean", "GNI","GNI.HDI.rank")
colnames(hd) <- hdnames

giinames <- c("GII.rank", "country", "GII", "MMratio", "ABrate", "rep.par", "sec.edu.F", "sec.edu.M", "LFP.F", "LFP.M")
colnames(gii)<- giinames

gii <- gii %>%  mutate(edu.FM.ratio = sec.edu.F / sec.edu.M)
gii <- gii %>%  mutate(LFP.FM.ratio = LFP.F / LFP.M)

human <- inner_join(hd, gii, by = "country")

write.csv(human, file = "data/human.csv")

summary(human)
dim(human)

my_fn <- function(data, mapping, ...){
  p <- ggplot(data = data, mapping = mapping) +
    geom_point() +
    geom_smooth(method=loess, fill="red", color="red", ...) +
    geom_smooth(method=lm, fill="blue", color="blue", ...)
  p
}
g = ggpairs(human,columns = c(1,3:6,8:19), lower = list(continuous = my_fn))
g


# Works in C:\Program Files\R\R-4.0.2\bin\x64

##### Load packages
library(tidyverse)
library(dplyr)
library(ggplot2)
library(nlme)
library(gridExtra)
library(viridis)

##### load data
setwd('~/StabilityScaleUp')
varpart_All_prod <- read.csv('varpart_All_prod.csv')
varpart_All_prod$year_trt <- factor(varpart_All_prod$year_trt)
varpart_All_prod$trt <- factor(varpart_All_prod$trt)
head(varpart_All_prod)

varpart_All_LRR_prod <- read.csv('varpart_All_LRR_prod.csv')
varpart_All_LRR_prod$year_trt <- factor(varpart_All_LRR_prod$year_trt)
head(varpart_All_LRR_prod)

###########################################
# correlation between richness and other local diversity indices #
###########################################

cor.test(varpart_All_prod$avg_richness2, varpart_All_prod$avg_evenness_Sh)
cor.test(varpart_All_prod$avg_richness2, varpart_All_prod$avg_invsimpsons2)
cor.test(varpart_All_prod$avg_richness2, varpart_All_prod$avg_shannons)

###########################################
###### figure MAT MAP              ########
###########################################

jpeg('FigureS1.jpg', width = 4, height = 4, units='in', res=300)
qplot(TEMP_VAR_v2/100, MAP_VAR_v2, data = varpart_All_prod, xlab='Temperature seasonality (°C)', ylab='Precipitation seasonality (mm)', alpha = I(0)) + theme_bw() + geom_point(size = 2)
dev.off()
system('open FigureS1.jpg')

###########################################
###### fertilization impact on diversity  ########
###########################################

# richness
gls1 <- gls(avg_richness2 ~ trt * year_trt, method='ML', data = varpart_All_prod)
gls2 <- gls(avg_richness2 ~ trt * year_trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

#beta
gls1 <- gls(beta_invsimpsons ~ trt * year_trt, method='ML', data = varpart_All_prod)
gls2 <- gls(beta_invsimpsons ~ trt * year_trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

###########################################
###### fertilization impact on stability  ########
###########################################

# alpha stability
gls1 <- gls(log_alpha_stab_prod ~ trt * year_trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_alpha_stab_prod ~ trt * year_trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

# gamma stability
gls1 <- gls(log_gamma_stab_prod ~ trt * year_trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_gamma_stab_prod ~ trt * year_trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

###########################################
###### figure treatment effect on diversity and stability           ########
###########################################

pdf('FigureS2.pdf', width = 8, height = 8, useDingbats=FALSE)
grid.arrange(
ggplot(varpart_All_prod, aes(year_trt, avg_richness2, fill=trt)) + xlab('Post treatment year') + ylab('species richness (m-2)') + theme_bw() + geom_boxplot(alpha=0.6) + geom_point(aes(fill=trt), size=2, shape = 21, position = position_jitterdodge()) + scale_fill_manual(values=c('#ffffff', '#999999')) + scale_color_manual(values=c('#ffffff', '#999999')) + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')),
ggplot(varpart_All_prod, aes(year_trt, beta_invsimpsons, fill=trt)) + xlab('Post treatment year') + ylab('beta diversity (abundance-based)') + theme_bw() + geom_boxplot(alpha=0.6) + geom_point(aes(fill=trt), size=2, shape = 21, position = position_jitterdodge()) + scale_fill_manual(values=c('#ffffff', '#999999')) + scale_color_manual(values=c('#ffffff', '#999999')) + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')),
ggplot(varpart_All_prod, aes(year_trt, log_alpha_stab_prod, fill=trt)) + xlab('Post treatment year') + ylab('ln (alpha stability)') + theme_bw() + geom_boxplot(alpha=0.6) + geom_point(aes(fill=trt), size=2, shape = 21, position = position_jitterdodge()) + scale_fill_manual(values=c('#ffffff', '#999999')) + scale_color_manual(values=c('#ffffff', '#999999')) + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')),
ggplot(varpart_All_prod, aes(year_trt, log_gamma_stab_prod, fill=trt)) + xlab('Post treatment year') + ylab('ln (gamma stability)') + theme_bw() + geom_boxplot(alpha=0.6) + geom_point(aes(fill=trt), size=2, shape = 21, position = position_jitterdodge()) + scale_fill_manual(values=c('#ffffff', '#999999')) + scale_color_manual(values=c('#ffffff', '#999999')) + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')),
nrow=2)
dev.off()
system('open FigureS2.pdf')

###########################################
###### figure mean/sd           ########
###########################################

pdf('FigureS3.pdf', width = 8, height = 3, useDingbats=FALSE)
grid.arrange(
qplot(avg_richness2, log(temp_mean), col=year_trt, data = varpart_All_prod, xlab=expression('Species richness' ~ ('m'^-2)), ylab='Temporal mean of productivity', alpha = I(0)) + theme_bw() + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_richness2, log(temp_sd), col=year_trt, data = varpart_All_prod, xlab=expression('Species richness' ~ ('m'^-2)), ylab='Temporal sd of productivity', alpha = I(0)) + theme_bw() + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
ncol=2)
dev.off()
system('open FigureS3.pdf')

gls1 <- gls(log(temp_mean) ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log(temp_mean) ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(log(temp_sd) ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log(temp_sd) ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

###########################################
###### analyses and figures LRR    ########
###########################################

pdf('FigureS9.pdf', width = 4, height = 6, useDingbats=FALSE)
grid.arrange(
qplot(LRR_avg_richness, LRR_alpha_stab_prod, col=year_trt, data = varpart_All_LRR_prod, xlab=expression('Changes in species richness' ~ ('m'^-2)), ylab='Changes in alpha stability', alpha = I(0)) + theme_bw() + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + scale_color_viridis(discrete=TRUE),
qplot(LRR_beta_invsimpsons, LRR_gamma_stab_prod, col=year_trt, data = varpart_All_LRR_prod, xlab='Changes in beta diversity (abundance-based)', ylab='Changes in gamma stability', alpha = I(0)) + theme_bw() + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + scale_color_viridis(discrete=TRUE),
ncol=1)
dev.off()
system('open FigureS9.pdf')

# richness
gls1 <- gls(LRR_alpha_stab_prod ~ LRR_avg_richness * year_trt, method='ML', data = varpart_All_LRR_prod)
gls2 <- gls(LRR_alpha_stab_prod ~ LRR_avg_richness * year_trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_LRR_prod)
anova(gls1, gls2)
anova(gls2)

# beta
gls1 <- gls(LRR_gamma_stab_prod ~ LRR_beta_invsimpsons * year_trt, method='ML', data = varpart_All_LRR_prod)
gls2 <- gls(LRR_gamma_stab_prod ~ LRR_beta_invsimpsons * year_trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_LRR_prod)
anova(gls1, gls2)
anova(gls2)

###########################################
###### analyses and figures control vs NPK      ########
###########################################

pdf('Figure2.pdf', width = 8, height = 6, useDingbats=FALSE)
grid.arrange(
qplot(avg_richness2, log_alpha_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Species richness (m-2)', ylab='Log (alpha stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(beta_invsimpsons, log_spatial_asynch_prod, col=year_trt, data = varpart_All_prod, xlab='Beta diversity (abundance-based)', ylab='Log (spatial asynchrony)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_richness2, log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Species richness (m-2)', ylab='Log (gamma stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(beta_invsimpsons, log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Beta diversity (abundance-based)', ylab='Log (gamma stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + facet_wrap('trt') + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + scale_color_viridis(discrete=TRUE),
ncol=2)
dev.off()
system('open Figure2.pdf')

pdf('FigureS4.pdf', width = 8, height = 6, useDingbats=FALSE)
grid.arrange(
qplot(avg_richness2, res_log_alpha_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Species richness (m-2)', ylab='Log (alpha stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(beta_invsimpsons, res_log_spatial_asynch_prod, col=year_trt, data = varpart_All_prod, xlab='Beta diversity (abundance-based)', ylab='Log (spatial asynchrony)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_richness2, res_log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Species richness (m-2)', ylab='Log (gamma stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(beta_invsimpsons, res_log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Beta diversity (abundance-based)', ylab='Log (gamma stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + facet_wrap('trt') + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + scale_color_viridis(discrete=TRUE),
ncol=2)
dev.off()
system('open FigureS4.pdf')

pdf('FigureS5.pdf', width = 12, height = 6, useDingbats=FALSE)
grid.arrange(
qplot(avg_invsimpsons2, log_alpha_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Inverse Simpson', ylab='Log (alpha stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_shannons, log_alpha_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Shannon', ylab='Log (alpha stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_evenness_Sh, log_alpha_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Species evenness', ylab='Log (alpha stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_invsimpsons2, res_log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Inverse Simpson', ylab='Log (gamma stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_shannons, log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Shannon', ylab='Log (gamma stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_evenness_Sh, log_gamma_stab_prod, col=year_trt, data = varpart_All_prod, xlab='Species evenness', ylab='Log (alpha stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
ncol=3)
dev.off()
system('open FigureS5.pdf')

pdf('FigureS8.pdf', width = 5, height = 6, useDingbats=FALSE)
grid.arrange(
qplot(avg_richness2, log_spp_stab_cover, col=year_trt, data = varpart_All_prod, xlab=expression('Species richness' ~ ('m'^-2)), ylab='Log (species stability)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + scale_x_continuous(breaks=c(0,1,2,3,4,5), labels=c('1','2','4','8','16','32')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
qplot(avg_richness2, log_spp_asynch_cover, col=year_trt, data = varpart_All_prod, xlab=expression('Species richness' ~ ('m'^-2)), ylab='Log (species asynchrony)', alpha = I(0)) + theme_bw() + scale_y_continuous(breaks=c(0,1,2,3,4,5), labels=c('0','1','2','3','4','5')) + geom_point(size = 1, alpha = I(0.3), shape=16) + geom_smooth(method=lm, se=F) + facet_wrap('trt') + scale_color_viridis(discrete=TRUE),
ncol=1)
dev.off()
system('open FigureS8.pdf')

########################################
# stats
########################################

# richness
gls1 <- gls(log_alpha_stab_prod ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_alpha_stab_prod ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(log_spp_stab_cover ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_spp_stab_cover ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(log_spp_asynch_cover ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_spp_asynch_cover ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(log_gamma_stab_prod ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_gamma_stab_prod ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

# abundance-based multiplicative beta
gls1 <- gls(log_spatial_asynch_prod ~ beta_invsimpsons * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_spatial_asynch_prod ~ beta_invsimpsons * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(log_gamma_stab_prod ~ beta_invsimpsons * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(log_gamma_stab_prod ~ beta_invsimpsons * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

########################################
# stats with env
########################################

# richness
gls1 <- gls(res_log_alpha_stab_prod ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_alpha_stab_prod ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(res_log_gamma_stab_prod ~ avg_richness2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_gamma_stab_prod ~ avg_richness2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

# abundance-based multiplicative beta
gls1 <- gls(res_log_spatial_asynch_prod ~ beta_invsimpsons * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_spatial_asynch_prod ~ beta_invsimpsons * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(res_log_gamma_stab_prod ~ beta_invsimpsons * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_gamma_stab_prod ~ beta_invsimpsons * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

########################################
# stats for other local diversity indices
########################################

# Simpson
gls1 <- gls(res_log_alpha_stab_prod ~ avg_invsimpsons2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_alpha_stab_prod ~ avg_invsimpsons2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(res_log_gamma_stab_prod ~ avg_invsimpsons2 * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_gamma_stab_prod ~ avg_invsimpsons2 * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

# Shannon
gls1 <- gls(res_log_alpha_stab_prod ~ avg_shannons * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_alpha_stab_prod ~ avg_shannons * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(res_log_gamma_stab_prod ~ avg_shannons * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_gamma_stab_prod ~ avg_shannons * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

# evenness
gls1 <- gls(res_log_alpha_stab_prod ~ avg_evenness_Sh * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_alpha_stab_prod ~ avg_evenness_Sh * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)

gls1 <- gls(res_log_gamma_stab_prod ~ avg_evenness_Sh * year_trt * trt, method='ML', data = varpart_All_prod)
gls2 <- gls(res_log_gamma_stab_prod ~ avg_evenness_Sh * year_trt * trt, correlation = corAR1(form=~1), method='ML', data = varpart_All_prod)
anova(gls1, gls2)
anova(gls2)


################################################################################
#    **************************** R companion for **************************
#
# Kenny, D. A., Kashy, D. A., & Cook, W. L. (2006). Dyadic data analysis.
# New York: Guilford Press.
#
# written by Avi Kluger: avik@savion.huji.ac.il
#
#                              CHAPTER 8 -- SRM
#
################################################################################
rm(list = ls())                               # Clean the Global Environment
cat ("\014")                                  # Clean the R console
if (is.null(dev.list()) == FALSE) dev.off()   # Clean Plots

Table8.4 <-  "NA  8 5 10
               7 NA 7  6
               8  7 NA 5
               4  5  0 NA"

Table8.4_df <- read.table(textConnection(Table8.4))

# https://cran.r-project.org/web/packages/TripleR/TripleR.pdf
if (!require("TripleR")) install.packages("TripleR");
suppressPackageStartupMessages(library(TripleR))

Table8.4_long_df <- matrix2long(Table8.4_df)

fitTable8.4 <- RR(value ~ actor.id*partner.id, data = Table8.4_long_df)
fitTable8.4


library(ggplot2)
tashu <- na.omit(read.csv('tashu.csv', header = TRUE))

top_path <- data.frame(table(tashu $ RENT_STATION, tashu $ RETURN_STATION))
top_path <- top_path[order(top_path $ Freq, decreasing = T),]
top_path <- head(top_path, n = 20)
top_path

top_path $ Var1 <- as.factor(top_path $ Var1)
top_path $ Var2 <- as.factor(top_path $ Var2)
top_path $ size <- with(top_path, as.numeric(Freq) / 3000)
top_path

ggplot(top_path, aes(Var1, Var2)) + geom_point(shape = 19, size = top_path $ size)


library(tidyverse)
library(sqldf)
library(eeptools)
library(Rcpp, "1.0.7")
library(reshape2)
library(viridis)
library(hrbrthemes)
library(lubridate)
library(reshape2)
library(maps)

# lab 8
df = read.csv("/Users/Grim/Documents/GitHub/Masters-Classes-L-O/Data Visualisation/data/OlympicGames.csv", sep= ',' , header=T )
df = read.csv("/Users/maksdrzezdzon/Documents/GitHub/Masters-Classes-L-O/Data Visualisation/data/OlympicGames.csv", sep = ",", header = T)

df

# 5. Visualisation Exercises
# Please answer the following questions. Use a visualisation to support the answer for each
# question. Experiment with the different types of charts and options ggplot offers. Please
# place the visualisations underneath each question.

# 1) What country has won most Silver medals since 2000? (2 marks)
# 2) How is the gender balance amongst the United States gold medalist? (2 marks)
# 3) What are the best sports for Sweden, USA, Austria and Switzerland? (2 marks)
# 4) Who has the most total medals? (2 marks)
# 5) What is the variation and spread of ages amongst gold and silver medalists? (2 marks)

mapdata = map_data("world")
mapdata
# 1) What country has won most Silver medals since 2000?
df_year_2000 = with(df, df[(Year >= 2000),])

df_year_2000_tmp = sqldf('select Year, count(Medal) as Medal, Country from df_year_2000 where Medal == "silver" group by Country')
names(df_year_2000_tmp)[3] = "region"
df_year_2000_tmp
silver_medals = right_join(mapdata, df_year_2000_tmp, by="region")
silver_medals_sum = df_year_2000_tmp = sqldf('select count(Medal) as Medal from df_year_2000 where Medal == "silver"')

# ToDo add labels for countries

map1 = ggplot(silver_medals, aes( x = silver_medals$long, y = silver_medals$lat, group=group, fill = as.numeric(Medal))) +
  geom_polygon(color = "white") + labs(title="What country has won most Silver medals since 2000?", fill="Silver Medals count won since since year 2000")

map1

map1 = ggplot(silver_medals, aes( x = silver_medals$long, y = silver_medals$lat, group=group)) +
  geom_polygon(aes(fill = Medal), color = "black") + labs(title="What country has won most Silver medals since 2000?", fill="Silver Medals count won since since year 2000")

map1

# 5) What is the variation and spread of ages among gold and silver medalists?
tmp_df = df

tmp_df$DOB = year(strptime("11-11-2021", format = "%d-%m-%Y")) - year(strptime(tmp_df$DOB, format = "%d-%m-%Y"))
names(tmp_df)[1] = "Age"
tmp_df
medal_age = tmp_df %>% drop_na()
medal_age

medal_age_df = sqldf('select Athlete_Age, Medal from medal_age where Medal != "bronze"')
medal_age_df

plot = ggplot(data = medal_age_df, aes(Athlete_Age, Medal, fill=as.factor(Athlete_Age))) +
  geom_col(position="dodge") + labs(x="Medal Name", y="Athlete Age",
           title="Q5 What is the variation and spread of ages among gold and silver medalists?", fill="Athlete Age Range") + coord_flip()
plot

#names(medal_age)[1] = "region"
#names(medal_age)
#medal_age = right_join(mapdata, medal_age, by="region")


attach(mtcars)
plot(wt, mpg, type='n')

menor3 <- mtcars[which(wt < 3), ]
menor34 <- mtcars[which(wt >= 3 & wt <= 4), ]
menor4 <- mtcars[which(wt > 4), ]

points(menor3$wt, menor3$mpg, col='blue', pch=19)
points(menor34$wt, menor34$mpg, col='green', pch=19)
points(menor4$wt, menor4$mpg, col='red', pch=19)

detach(mtcars)


## simulate EWAS with induced changes between cases and controls
## set proportion of differences cell-type specific vs universal
## compare 3 models
## run as chunks

runEWAS<-function(row,pheno, status){

	modelLM<-lm(row ~ status * pheno$Cell.type + pheno$CCDNAmAge + pheno$Sex + pheno$Tissue.Centre)
	nullLM<-lm(row ~ status + pheno$Cell.type + pheno$CCDNAmAge + pheno$Sex + pheno$Tissue.Centre)

	data<-cbind(row,status, pheno)
	modelMLM<-lmer(row ~ status * Cell.type + CCDNAmAge + Sex +  + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)
	nullMLM<-lmer(row ~ status + Cell.type + CCDNAmAge + Sex +  + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)

	p.df <- pdata.frame(data.frame("meth" = row, "phenotype" = status, "age" = pheno$CCDNAmAge, "sex" = pheno$Sex, "cell.type" = pheno$Cell.type, "brain.bank" = pheno$Tissue.Centre, "id" = pheno$Indidivual.ID), index = c("id", "cell.type"), drop.index = F)

	modelp <- plm(meth ~ phenotype * cell.type + age + sex  + brain.bank, data = p.df, model = "pooling")
	nullCRR <- plm(meth ~ phenotype + cell.type + age + sex  + brain.bank, data = p.df, model = "pooling")
	# compute Stata like df-adjustment
	G <- length(unique(p.df$id))
	N <- length(p.df$id)
	dfa <- (G/(G - 1)) * (N - 1)/modelp$df.residual

	# display with cluster VCE and df-adjustment
	firm_c_vcov <- dfa * vcovHC(modelp, type = "HC0", cluster = "group", adjust = T)
	modelCRR<-coeftest(modelp, vcov = firm_c_vcov)

	return(c(summary(modelLM)$coefficients["status1", 4], anova(modelLM, nullLM)[2,6],
	summary(modelMLM)$coefficients["status1", 5], anova(modelMLM, nullMLM)[2,8],
	 modelCRR["phenotype1",4],waldtest(modelp, nullCRR, vcov = firm_c_vcov, test = "F")[2,4]))
}

estlambda<-function(pvals){
	z = qnorm(pvals / 2)
	## calculates lambda
	lambda = round(median(z^2) / 0.454, 3)
	return(lambda)
}

library(lme4)
library(lmerTest)
library(plm)
library(lmtest)
#library(GenABEL)
library(doParallel)

args<-commandArgs(trailingOnly = TRUE)
source(args[1])
nChunk<-args[2]
setwd(dataDir)

load(normData)

## remove total samples and cell types with less than 10 samples
pheno<-pheno[which(pheno$Cell.type != "Total"),]
nSample<-table(pheno$Cell.type)
pheno<-pheno[pheno$Cell.type %in% names(nSample[which(nSample > 9)]),]

celltypenormbeta<-celltypenormbeta[,pheno$Basename]

nCores<-detectCores()
cl <- makeCluster(nCores-1)
registerDoParallel(cl)
clusterExport(cl, list("runEWAS", "lmer", "pdata.frame", "plm", "vcovHC", "coeftest", "waldtest"))

cellTypes<-unique(pheno$Cell.type)

## use chunks to save intermitant results in case script does not complete
nSim<-10

nSig.options<-c(10,100,1000)
propCS.options<-seq(0,1,0.1)
sigEffect<-0.05

sumSim<-matrix(data = NA, nrow = nSim*length(nSig.options)*length(propCS.options), ncol = 2+(6*6))
colnames(sumSim)<-c("nProbes", "nCTspecific", paste("LM_ME", c("TotSig", "nTruePos", "nFalsePos","nTruePosCS", "nFalsePosCS", "lambda"), sep = "_"),
paste("LM_Int", c("TotSig", "nTruePos", "nFalsePos", "nTruePosCS", "nFalsePosCS", "lambda"), sep = "_"),
paste("MLM_ME", c("TotSig", "nTruePos", "nFalsePos", "nTruePosCS", "nFalsePosCS", "lambda"), sep = "_"),
paste("MLM_Int", c("TotSig", "nTruePos", "nFalsePos","nTruePosCS", "nFalsePosCS",  "lambda"), sep = "_"),
paste("CRR_ME", c("TotSig", "nTruePos", "nFalsePos", "nTruePosCS", "nFalsePosCS", "lambda"), sep = "_"),
paste("CRR_Int", c("TotSig", "nTruePos", "nFalsePos", "nTruePosCS", "nFalsePosCS", "lambda"), sep = "_"))

rowNum<-1
for(simNum in 1:nSim){
	## randomly select samples to be cases, fix so numbers per brain bank match actual
	status<-rep(0,nrow(pheno))
	for(centre in unique(pheno$Tissue.Centre)){
		ids<-unique(pheno$Indidivual.ID[which(pheno$Tissue.Centre == centre)])
		cases<-sample(ids, floor(length(ids)/2))
		status[pheno$Indidivual.ID %in% cases]<-1
	}
	status<-as.factor(status)

	## First run the null EWAS for this simulation
	outtab.null<-foreach(i=1:nrow(celltypenormbeta), .combine = "rbind") %dopar% runEWAS(celltypenormbeta[i,], pheno, status)
	## Second only need to retest sites affects are induced at as non significiant probes are unaltered
	for(nSig in nSig.options){
		for(propCS in propCS.options){
			sumSim[rowNum,1]<-nSig
			sumSim[rowNum,2]<-floor(nSig*propCS)
			## randomly select significant probes
			sigProbes<-sample(1:nrow(celltypenormbeta), nSig)

			## create matrix with effects to add to sample profiles
			diffs<-rnorm(nrow(pheno)*nSig, sigEffect, 0.005) ## sample effects for each sample
			diffs<-matrix(data = diffs, nrow = nSig, byrow = TRUE)
			diffs[,which(status == 0)]<-0

			## make some of these effects cell type specific
			if(propCS > 0){
				ctSpecific<-sample(1:nSig, floor(nSig*propCS))
				for(each in ctSpecific){
					# randomly select cell type to be significant in
					selectCT<-sample(cellTypes, 1)
					## set other cell types to have no effects
					diffs[each, !pheno$Cell.type %in% selectCT]<-0
				}
				ctSpecific<-sigProbes[ctSpecific]
			} else {
				ctSpecific<-NULL
			}

			## create matrix of betas with induced effects
			testbetas<-celltypenormbeta[sigProbes,]+diffs

			outtab.sig<-foreach(i=1:nrow(testbetas), .combine = "rbind") %dopar% runEWAS(testbetas[i,], pheno, status)

			## merge signif results with null results to generate summary statistics
			outtab.sim<-outtab.null
			outtab.sim[sigProbes,]<-outtab.sig

			sumSim[rowNum,2+seq(1,6*6, 6)]<-colSums(outtab.sim < 9e-8)
			sumSim[rowNum,3+seq(1,6*6, 6)]<-colSums(outtab.sim[sigProbes,] < 9e-8)
			sumSim[rowNum,4+seq(1,6*6, 6)]<-colSums(outtab.sim[-sigProbes,] < 9e-8)
			## handle quirk of R converting 1 row matrix to vector!!
			if(length(ctSpecific) > 2){
				sumSim[rowNum,5+seq(1,6*6, 6)]<-colSums(outtab.sim[ctSpecific,] < 9e-8)
				sumSim[rowNum,6+seq(1,6*6, 6)]<-colSums(outtab.sim[-ctSpecific,] < 9e-8)
			} else {
				if(length(ctSpecific) == 1){
					sumSim[rowNum,5+seq(1,6*6, 6)]<-as.numeric(outtab.sim[ctSpecific,] < 9e-8)
					sumSim[rowNum,6+seq(1,6*6, 6)]<-colSums(outtab.sim[-ctSpecific,] < 9e-8)
				} else{
					sumSim[rowNum,5+seq(1,6*6, 6)]<-NA
					sumSim[rowNum,6+seq(1,6*6, 6)]<-NA
				}
			}

			sumSim[rowNum,7+seq(1,6*6, 6)]<-apply(outtab.sim, 2, estlambda)
			rowNum<-rowNum+1
		}
	}
}

save(sumSim, file = paste0("nSigSimulateTrueEffects_Chunk", nChunk, ".rdata"))


# lhl.R

# Church two step breakpoint algorithm, from Church et al, 1994.

lhl_old <- function(r_times){

  # initial values
  # s1 <- 0 # start
  s2 <- 0 # stop
  t1 <- 0 # first low rate duration
  t2 <- 0 # high rate duration
  t3 <- 0 # second low rate duration
  r1 <- 0 # first low rate
  r2 <- 0 # high rate
  r3 <- 0 # second low rate
  index_s1 <- 0 # index to get start (inner for loop)
  index_s2 <- 0 # index to get stop (outer for loop)
  algorithm_s1 <- 0 # as above, indexed by index_s1
  algorithm_s2 <- 0
  end_trial <- 180
  nr <- length(r_times) # number of responses
  r <- nr/180 # get overall response rate

  # 'if' conditional states that trials must have more than 3 responses
  if (nr > 3) {

    # loop through response times, except the last
    # then choose best t1 (inner for loop),
    # then get best s2 estimate (outer for loop)

    for (i in 1:(nr - 1)) {

      s2[i] <- r_times[i + 1]
      t3[i] <- end_trial - s2[i]

      if (t3[i] <= 0) {
        r3[i] <- 0 # necessary to avoid division by 0
        t3[i] <- 0
      } else {
        r3[i] <- sum(r_times > s2[i])/t3[i]
      }

      for (j in seq_along(s2)) { # loop through putative s2 and choose t1

        t1[j] <- r_times[j] # This seems wrong! j = 1, 2, 3..., not the values of s2
        r1[j] <- sum(r_times <= t1[j])/t1[j]
        t2[j] <- s2[i] - t1[j] # high-rate duration

        if (t2[j] == 0) {
          r2[j] <- 0 # necessary to avoid division by 0
        } else {
          r2[j] <- sum(r_times > t1[j] & r_times <= s2[i])/t2[j]
        }

        algorithm_s1[j] <- t1[j]*(r - r1[j]) + t2[j]*(r2[j] - r) + t3[i]*(r - r3[i])
        index_s1 <- which(algorithm_s1 == max(algorithm_s1,na.rm = T))
        # some times two indexes with same algorithm value
        # get the first of them
        if(length(index_s1) > 1){
          index_s1 <- min(index_s1)
        }

      } # end inner loop (get s1 value)

      algorithm_s2[i] <- t1[index_s1]*(r - r1[index_s1]) + t2[i]*(r2[i] - r) + t3[i]*(r - r3[i])

    } # end outer for loop (get s2 value after s1)

    index_s2 <- which(algorithm_s2 == max(algorithm_s2, na.rm = T))

    if (length(index_s2) > 1) {
      index_s2 <- min(index_s2)
    }

    start <- t1[index_s1]
    stop <- s2[index_s2]
    mid <- (start + stop)/2
    low_rate_1 <- sum(r_times <= start)/start
    low_rate_2 <- sum(r_times > stop)/(end_trial - stop)
    spread <- stop - start

    high_rate <- sum(r_times > start & r_times <= stop)/spread

    bpts <-
      data.frame(start = start,
                 stop = stop,
                 mid = mid,
                 spread = spread,
                 high_rate = high_rate,
                 r1 = low_rate_1,
                 r3 = low_rate_2)

    bpts
  } # end if

}


# /////////////////////////////////////////////////////////////////////////
#
## Data Analysis Code
#   Anova, Tukey, Pollen Limitation, Breeding System, and T-Tests
#
# /////////////////////////////////////////////////////////////////////////

#load plant data
library(readxl)
data <- read_excel("Supporting_Information_S6.xlsx")

#subset plant data for different species

#Camser #plant_data <- subset(data, species=="Camser")
#Cirery #plant_data <- subset(data, species=="Cirery")
#Diacar #plant_data <- subset(data, species=="Diacar")
#Helnum #plant_data <- subset(data, species=="Helnum")
#Hypper #plant_data <- subset(data, species=="Hypper")
#Lotcor #plant_data <- subset(data, species=="Lotcor")
#Scacol #plant_data <- subset(data, species=="Scacol")
#Sonarv #plant_data <- subset(data, species=="Sonarv")
#Troeur #plant_data <- subset(data, species=="Troeur")

#remove notes column and then NA's
View(plant_data)
plant_data$notes<-NULL
Plant_data<-na.omit(plant_data)

#subset data into different treatments
sup<-subset(Plant_data,treat=="supplement")
con<-subset(Plant_data,treat=="open")
bag<-subset(Plant_data,treat=="bag")

#ANOVA and Tukey
d<-aov(ratio~treat,data=Plant_data)
summary(d)
TukeyHSD(d)

#Effect Size of autogomy
log(mean((sup$ratio)+0.5))-log(mean((bag$ratio)+0.5))

#Effect size of pollen limitation
log(mean((sup$ratio)+0.5))-log(mean((con$ratio)+0.5))

#breeding system t-test
t.test(sup$ratio, bag$ratio)

#Pollen Lim t-test
t.test(sup$ratio, con$ratio)


# Heatmap from https://flowingdata.com/2010/01/21/how-to-make-a-heatmap-a-quick-and-easy-solution/

nba <- read.csv("http://datasets.flowingdata.com/ppg2008.csv", sep = ",")

nba <- read.csv("~/Documents/ppg2008.csv", sep = ";")

row.names(nba) <- nba$Name
nba <- nba[, 2:20]
nba_matrix <- data.matrix(nba)

nba_heatmap <- heatmap(nba_matrix, Rowv = NA, Colv = NA, col = cm.colors(256), scale = "column", margins = c(5, 10))

nba_heatmap <- heatmap(nba_matrix, Rowv = NA, Colv = NA, col = heat.colors(256), scale = "column", margins = c(5, 10))

# Traffic light, red, orange, green
nba_heatmap <- heatmap(nba_matrix,
                       Rowv = NA,
                       Colv = NA,
                       col = c("#cc3232", "#e7b416", "#2dc937"),
                       scale = "column",
                       margins = c(5, 10))
# Traffic light, red, green, orange
nba_heatmap <- heatmap(nba_matrix,
                       Rowv = NA,
                       Colv = NA,
                       col = c("#cc3232", "#2dc937", "#e7b416"),
                       scale = "column",
                       margins = c(5, 10))

mypalette <- RColorBrewer::brewer.pal(3, "Blues")

nba_heatmap <- heatmap(nba_matrix,
                       Rowv = NA,
                       Colv = NA,
                       col = mypalette,
                       scale = "column",
                       margins = c(5, 10))

# TBA, using ggplot2
# https://learnr.wordpress.com/2010/01/26/ggplot2-quick-heatmap-plotting/


library(ggplot2)
library(reshape2)
library(naturalsort)
library(wesanderson)  # colour palettes based on Wes Anderson movies
library(RColorBrewer)
Sys.setlocale("LC_ALL","fr_CA.UTF-8")  # set locale to french, for french date axis ?

raw.cases <- read.csv("cases.csv")
raw.cases$date <- as.Date(raw.cases$date)

# for the data from the Montreal Gazette (pre-March 14), in some cases I couldn't figure out the location
#   for these cases, in the .csv, I indicated the region as 'non indique'
#   By contrast, when Sante Quebec is unsure about the location of a case, they say it's "À déterminé"
#   The plot is more succinct if it only has one label that indicates uncertainty about location,
#    so I'm going to collapse these two together and use "À déterminé" in the Gazette data as well
raw.cases[raw.cases$region == 'non indiqué','region'] <- 'À déterminer'

# before March 14 (data from the Montreal Gazette), I only have counts of new cases.
# Calculate a cumulative total for each day
preMarch14 <- raw.cases[raw.cases$date < as.Date("2020-03-14"), ]
preMarch14.wide <- dcast(preMarch14,date ~ region,fun.aggregate=length,value.var="new")

cases.wide <- preMarch14.wide[preMarch14.wide$date == as.Date("2020-02-28"),]
for(date in as.list(seq(as.Date("2020-02-29"), as.Date("2020-03-13"), by="1 day"))){
  if(any(preMarch14.wide$date == date)){
    new.date <- preMarch14.wide[preMarch14.wide$date == date,-c(1)] + cases.wide[cases.wide$date == date-1,-c(1)]
  }else {
    new.date <-cases.wide[cases.wide$date == date-1,]
  }
  new.date$date <- date
  cases.wide <- rbind(cases.wide,new.date)
}
cases <- melt(cases.wide,id.vars="date",value.name ="cumulative",variable.name="region" )

# add data from after March 13 (from https://www.quebec.ca/sante/problemes-de-sante/a-z/coronavirus-2019/)
cases <- rbind(cases,raw.cases[raw.cases$date > as.Date("2020-03-13"),c("date","region","cumulative")])

# change region order for barplot
cases <- cases[naturalorder(cases$region),]
cases$region <- factor(as.character(cases$region))

nRegions <- length(levels(cases$region))
blues_fun <- colorRampPalette(brewer.pal(9,"Blues")) # https://stackoverflow.com/questions/16922988/interpolating-a-sequential-brewer-palette-as-a-legend-for-ggplot2

# plot cumulative cases
p <- ggplot(cases,aes(x=date,y=cumulative,fill=region)) + geom_bar(stat="identity") + ggtitle("COVID-19 au Québec")
p <- p + ylab("Cas confirmés") + xlab("Date")
#p <- p + scale_fill_manual(values = wes_palette("Darjeeling1", nRegions, type = "continuous"))
p <- p + scale_fill_manual("Région",values=blues_fun(nRegions))
p
ggsave("covid_19_au_quebec_cumulative.png",p,height=4,width=7)

# from cumulativate cases dataframe, get new cases for each day
## I'm trying to do this while still keeping track of what regions the cases are from. Can't get this to work.
#new.cases <- cases
#new.cases.wide <- dcast(new.cases,date ~ region,fun.aggregate=sum,value.var="cumulative")
#for(date in as.list(seq( max(cases$date),  min(cases$date)+1, by="-1 day"))){
#  print(date)
#  new.cases.wide[new.cases.wide$date == date,-c(1)] <- new.cases.wide[new.cases.wide$date == date,-c(1)] - new.cases.wide[new.cases.wide$date == date-1,-c(1)]
#}
#new.cases <- melt(new.cases.wide,id.vars="date",value.name ="new",variable.name="region" )

# plot new cases each day
#p <- ggplot(new.cases,aes(x=date,y=new,fill=region)) + geom_bar(stat="identity") + ggtitle("COVID-19 au Québec")
#p <- p + ylab("Nouveau cas confirmés") + xlab("Date")
#p <- p + scale_fill_manual("Région",values=blues_fun(nRegions))
#p
#ggsave("covid_19_au_quebec_nouveau.png",p,height=3.5,width=7)

# from cumulativate cases dataframe (cases), get new cases for each day by taking the derivative
new.cases <- aggregate(cumulative ~ date,cases,FUN=sum)   # get sum over regions
new.cases$new <- c(new.cases$cumulative[1],diff(new.cases$cumulative, lag=1))   # take derivative

# moving average function - from https://stackoverflow.com/a/4862334/765287
ma <- function(x, n = 7){filter(x, rep(1 / n, n), sides = 1,method="convolution")}

# calculate 7-day moving average, like in these New York Times plots (https://www.nytimes.com/interactive/2020/03/19/world/coronavirus-flatten-the-curve-countries.html)
new.cases$ma <- ma(new.cases$new)
new.cases[is.na(new.cases$ma),"ma"] <- 0    # filter function puts NAs at start of vector, replace these with zeros
new.cases$ma
new.cases$ma_type <- "7-day average"

# plot new cases each day
p <- ggplot(new.cases,aes(x=date,y=new)) + geom_bar(stat="identity",aes(alpha=I(0.3))) + ggtitle("COVID-19 au Québec")
p <- p + geom_line(aes(y=ma,colour=ma_type)) + scale_colour_manual(values=c("#2171B5"))
p <- p + ylab("Nouveau cas confirmés") + xlab("Date") + labs(colour = "")
p
ggsave("covid_19_au_quebec_nouveau.png",p,height=4,width=7)


# Gamlss estimation of gene noise for each gene for COVID19

library(edgeR)
library(gamlss)
library(gtools)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("COVID19_RNAseq.Rdat")

################################################################################
# Functions for GAMLSS analysis
# gNBI.RS - the Rigby and Stasinopoulos algorithm for GAMLSS
gNBI.RS = function(dat, f1, f2){
  res = tryCatch(
    gamlss::gamlss(f1, sigma.fo = f2, data = dat, family = NBI(), method = RS(), n.cyc = 500),
  warning = function(w) NULL, error = function(e) NULL)
  res
}

# gNBI.CG -  the Cole and Green algorithm for GAMLSS
gNBI.CG = function(dat, f1, f2){
  res = tryCatch(
    gamlss::gamlss(f1, sigma.fo = f2, data = dat, family = NBI(), method = CG(), n.cyc = 500),
  warning = function(w) NULL, error = function(e) NULL)
  res
}

# Gamlss estimation of gene noise for each gene for COVID19
gene_noise_COVID <- mclapply(seq(nrow(DGE_RNAcounts$counts)), function(i) {

    cat(i, "\r")

    # COVID - data.frame
    # y - RNA counts
    # x - fixed effect factor (COVID19 mild/severe)
    # ofs - offset log(library size x normalization factor), see edgeR
    # Sex - gender
    # age - age
    # rnd - Sex:age interaction was used as random effect

    COVID = data.frame(y = DGE_RNAcounts$counts[i,],
      x = factor(DGE_RNAcounts$samples$stage),
      ofs = DGE_RNAcounts$samples$offset,
      Sex = DGE_RNAcounts$samples$Sex,
      age = DGE_RNAcounts$samples$age
    )
    COVID$age[is.na(COVID$age)] = median(COVID$age[!is.na(COVID$age)])
    COVID$age = quantcut(COVID$age, q=10)
    COVID$rnd = paste0(COVID$Sex, ":", COVID$age)

    # f1 - gamlss formula for mu
    f1 = formula(y ~ x + random(factor(rnd)) + offset(ofs) )
    # f2 - gamlss formula for sigma
    f2 = formula(y ~ x + random(factor(rnd)))

    # gamlss model
    # m0 - model for mu and sigma with x fixed factor effects: COVID stage and random factor effects rnd: Sex:age
    sink("/dev/null")

    m0 = gNBI.RS(COVID, f1, f2)

    if(is.null(m0)) { m0 = gNBI.CG(COVID, f1, f2)  }

    sink()

    # results:
    # mu_mild - mean gene expression for mild COVID19
    # mu_severe - mean gene expression for severe COVID19
    # bcv_mild - biological coefficient of variation of gene expression for mild COVID19
    # bcv_severe - biological coefficient of variation of gene expression for severe COVID19
    # p_mu - significance of COVID19 effect (mild vs severe) on mean gene expression
    # p_bcv - significance of COVID19 effect (mild vs severe) on gene expression noise (bcv - biological coefficient of variation)

    res = data.frame(mu_mild = NA, mu_severe = NA, bcv_mild = NA, bcv_severe = NA, p_mu = NA, p_bcv=NA)

    if(!is.null(m0)) {
      sink("/dev/null")
        m0s = summary(m0, "qr", save = T)
        mu = exp(cumsum(m0s$mu.coef.table[,1]))*1e06
        bcv = sqrt(exp(cumsum(m0s$sigma.coef.table[,1])))
        p_mu = m0s$mu.coef.table[2,4]
        p_bcv = m0s$sigma.coef.table[2,4]
        res = data.frame(mu_mild = mu[[1]], mu_severe = mu[[2]],
            bcv_mild = bcv[[1]], bcv_severe = bcv[[2]],
            p_mu = p_mu, p_bcv=p_bcv)
      sink()
    }

    res

}, mc.cores = 4 )

gene_noise_COVID <- do.call(rbind, gene_noise_COVID)
rm(f1, f2, gNBI.CG, gNBI.RS)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("COVID19_gene_noise_Figure6A.Rdat")


valoreAtteso <- 2.81

n <- 5

domanda1 <- 4

domanda2 <- 4

risposta1 <- 1 - (ppois(domanda1, valoreAtteso) ^ n);

risposta2 <- 1- ppois(domanda2*n, valoreAtteso*n);

print(risposta1)

print(risposta2)


# ALL FUNCTIONS DEALING WITH INITIALIZING MODEL COMPUTATION

initialize_posterior <- function(grid_theta, grid_epsilon, max_observation, feature_number){
  posterior <- expand_grid(theta = grid_theta,
                              epsilon = grid_epsilon)
  # not sure when do we really need the non-log one, save some $$$
  posterior$unnormalized_log_posterior <- NA_real_
  posterior$log_posterior <- NA_real_
  posterior$posterior <- NA_real_

  posterior <- lapply(seq(1, max_observation, 1),
                            function(x){
                              lapply(seq(1, feature_number, 1),
                                     function(y){
                                       posterior
                                     })
                            })
  return(posterior)
}

initialize_z_given_theta <- function(grid_theta, grid_epsilon, max_observation, feature_number){
  z_given_theta <- expand_grid(theta = grid_theta,
                                  epsilon = grid_epsilon)

  z_given_theta$lp_z_y_ONE <- NA_real_
  z_given_theta$lp_z_y_ZERO <-  NA_real_
  z_given_theta$lp_z_given_theta <- NA_real_

  z_given_theta <- lapply(seq(1, max_observation, 1),
                                function(x){
                                  lapply(seq(1, feature_number, 1),
                                         function(y){
                                           z_given_theta
                                         })
                                })
  return(z_given_theta)

}

# model data frame, includes observations
initialize_model <- function(eig_from_world, max_observation, n_features) {

    model <- tibble(t = rep(NA,max_observation),
                    stimulus_idx = rep(NA,max_observation),
                    EIG = rep(NA,max_observation),
                    EIG_from_world = rep(eig_from_world,max_observation),
                    p_look_away = rep(NA,max_observation),
                    look_away = rep(NA,max_observation))

  # initialize columns for observations
  model[,paste("f", 1:n_features, sep="")] <- NA

  return(model)
}

# data f for keep track of actual observations
initialize_m_observation <- function(feature_number, max_observation, stimuli_sequence){

  m_observation <- matrix(ncol = feature_number,
                          nrow = max_observation)
  colnames(m_observation) <- grep("V",names(stimuli_sequence), value = TRUE)
  return(m_observation)
}

# helper function that gets you a df with features as columns and all possible
# combinations
get_possible_observations <- function(n_features) {
  feature_list <- list()

  for (i in 1:n_features) {
    feature_list[[i]] <- c(FALSE, TRUE)
  }

  expand.grid(feature_list) %>%
    tibble() %>%
    rename_with(~gsub("Var", "V", .x)) # fix random naming thing
}

noisy_observation_feature <- function(
  feature,
  n_sample,
  epsilon
){
  real_features <- rep(feature, n_sample)
  noisy <- rbernoulli(p = epsilon, n = n_sample)
  return(ifelse(noisy, as.logical(1-real_features), real_features))

}

noisy_observation_creature <- function(
  creature,
  n_sample = 1,
  epsilon
){
  sapply(creature, function(y){noisy_observation_feature(
    feature = y,
    n_sample = n_sample,
    epsilon = epsilon
  )})

}

generate_creature_sequence <- function(
  block_length,
  deviant_positions, # takes a vector,
  total_feature,
  feature_theta,
  feature_number,
  dissimilar_ratio
){

  background_theta <- make_creature(total_feature = total_feature,
                                    feature_theta = feature_theta,
                                    feature_number = feature_number)

  deviant_theta <- make_dissimilar_creature(creature = background_theta,
                                            dissimilar_ratio = dissimilar_ratio)

  background <- make_individual_creature(background_theta)
  deviant <- make_individual_creature(deviant_theta)

  block_list <- replicate(block_length, background, simplify = FALSE)

  if (length(deviant_positions) > 0){
    block_list[deviant_positions] <- replicate(length(deviant_positions),
                                               deviant,
                                               simplify = FALSE)
  }

  # putting everything in a tibble dataframe
  tidy_creature_sequence <- bind_rows(lapply(block_list,
                                             function(x) x %>% as_tibble_row(.name_repair = make.names)))

  # renaming columns
  rename_column <- function(x){paste0("V", x)}
  tidy_column_names <- lapply(1:total_feature, rename_column)
  colnames(tidy_creature_sequence) <- tidy_column_names

  tidy_creature_sequence <- tidy_creature_sequence %>%
    mutate(trial_number = row_number(),
           trial_type = case_when(
             trial_number %in% deviant_positions ~ "deviant",
             TRUE ~ "background"
           ))

  return(tidy_creature_sequence)

}


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Coauthor networks: data preparation
# Note: analysis done in Python, see folder 2019-09-24-coauthor-networkx
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Set up
source('2020-08-31-jsa-type-v2/00-init/var.R')
source('2020-08-31-jsa-type-v2/subset.R')

# Parameters
dir_base <- "C:\\Users\\ejysoh\\Dropbox\\msc-thesis\\research\\"
dir_plot <- paste0(dir_base, "_figures\\_ch3\\_ch3-coauth\\")
theme <- theme_minimal() + theme(text = element_text(size=13))
date_cutoff <- 2019

# Read/wrangle data
df <- get_df()

df_syn <- df[
    duplicated == FALSE & date <= date_cutoff &
    status %in% c("Valid species", "Synonym"),
    c("idx", "date", "status")
]

df <- df[
    duplicated == FALSE &
    status %in% c("Valid species", "Synonym"),
    c("full.name.of.describer", "idx", "date")
]

df$date <- as.integer(df$date)
df <- df[date <= date_cutoff]
df <- df[order(date)]

df$date.decade <- paste0(substr(as.character(df$date), 1, 3), "0s")
df$coauth <- "Did not coauthor"
df[grepl("; ", full.name.of.describer)]$coauth <- "Coauthor"
table(df$coauth)

df_full <- df

# Count number of describers
df <- df %>% separate_rows(full.name.of.describer, sep="; ")
df_authors <- df <- data.table(unique(df))

# Get authors inside / outside network (new)
df_author_max_date <- df[, list(max=max(date)), by="full.name.of.describer"]
df_authors <- dcast(df_authors, full.name.of.describer ~ coauth)
df_authors <- merge(
    df_authors, df_author_max_date, by="full.name.of.describer", all.x=T, all.y=T
)
names(df_authors) <- c("full.name", "coauth", "no.coauth", "max.date")
dim(df_authors)
df_authors[coauth > 0] # coauthored (in network)
df_authors[coauth == 0] # did not coauthor
df_authors[coauth == 0 & max.date >= 2000] # did not coauthor and still active

df <- df[, list(.N), by=c('idx', 'date.decade', 'date', 'coauth')]
df <- df[order(date.decade)]
df$N <- as.character(df$N)

# Create dataset for coauth
df_did_not_coauth <- df[N == 1]  # for coauth analysis
df_coauth <- df[N >= 2] # for coauth analysis

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Number of co-authoring describers
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Number of co-authoring describers"))

dim(df[N>=2])

table(df$N)
prop.table(table(df$N)) * 100

dim(df)
prop.table(table(df$N %in% c(2,3,4)))*100

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - % of synonyms
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

syn_summary <- df_syn[, .N, by="status"]
syn_summary[status == "Synonym"]$N / sum(syn_summary$N)

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - % of author who coauthored
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

nw <- get_describer_network()

auth_coauth <- unique(c(nw[!is.na(p2)]$p1, nw[!is.na(p2)]$p2))

auth_did_not_coauth <- unique(nw[is.na(p2)]$p1)

auth_did_not_coauth <- unique(
    auth_did_not_coauth[!auth_did_not_coauth %in% auth_coauth]
)

any(auth_did_not_coauth %in% auth_coauth) # check

(length(auth_coauth) + length(auth_did_not_coauth))

length(auth_did_not_coauth) /
    (length(auth_coauth) + length(auth_did_not_coauth)) * 100

length(auth_did_not_coauth)

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Mean year of publication for co-authors
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

df_bp <- rbind(df_coauth, df_did_not_coauth)
df_bp$date <- as.integer(df_bp$date)
df_bp$coauth <- factor(df_bp$coauth, levels=c("Coauthor", "Did not coauthor"))
df_bp[,
    list(
        mean=mean(date),
        se=sd(date)/sqrt(.N), n=.N,
        median=quantile(date, .5),
        q25=quantile(date, .25),
        q75=quantile(date, .75)
        ),
    by=coauth]

qqPlot(df_coauth$date)
qqPlot(df_did_not_coauth$date)

shapiro.test(df_coauth$date)
shapiro.test(df_did_not_coauth$date)

res <- wilcox.test(
    df_coauth$date, df_did_not_coauth$date,
    alternative = "two.sided"
)

res
res$p.value

# Plot
plot_bp <- ggplot(df_bp) +
    geom_boxplot(aes(y=date, x=as.character(coauth))) +
    theme +
    ylab("Year of description\n") +
    theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
    scale_fill_manual(name="", values=c("grey80", "grey40"))

# plot_bp

# ggsave(
#     paste0(dir_plot, 'fig-X.png'), plot_bp, units="cm",
#     width=15, height=10, dpi=300
# )

# res <- bartlett.test(df_coauth$date, df_did_not_coauth$date)
# res

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Percentage of describers across years
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Percentage of describers across years"))

calc_median <- function(x){
  return(c(y = -0.1, label = length(x)))
  # experiment with the multiplier to find the perfect position
}

x_scale <- unique(df$date.decade)
x_scale_tf <- rep(c(TRUE, FALSE), round(length(x_scale)/2, 0))
x_scale[x_scale_tf == FALSE] <- ""

plot_auth_decade1 <- ggplot(data = df, aes(x=date.decade, fill=N)) +
        geom_bar(position = "fill") +
        xlab("\nDecade") +
        ylab("Percentage of species with \nnumber of describers (%)\n") +
        theme + scale_fill_grey() +
        scale_x_discrete(labels = x_scale) +
        scale_y_continuous(labels = function(x) x*100)

plot_auth_decade2 <- ggplot(data=df, aes(x=date.decade, fill=N)) +
        geom_bar(stat = 'count') +
        xlab("\nDecade") +
        ylab("Number of species with \nnumber of describers\n") +
        theme + scale_fill_grey() +
        scale_x_discrete(labels = x_scale)

cfile <- paste0(dir_plot, 'fig-1a.png')
ggsave(cfile, plot_auth_decade1, units="cm", width=20, height=7.5, dpi=300)
cfile <- paste0(dir_plot, 'fig-1b.png')
ggsave(cfile, plot_auth_decade2, units="cm", width=20, height=7.5, dpi=300)

dim(df_full[date.decade=="1820s"])
df_full[date.decade=="1820s"]
df_full[date.decade=="1820s" & grepl("Amédée", full.name.of.describer), .N]
df_full[date.decade=="1820s", .N]
df_full[date.decade=="1820s", .N, by="coauth"]

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Write data
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@