rm(list=ls())
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(stats)
library(tibble)
library(reshape)

# set dataset

## In manuscript and edited xlsx sheets i refer to 1x as 2x

dataset <- "Singhal"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS")) %>%
  mutate_if(is.numeric,round,2)
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF")) %>%
  mutate_if(is.numeric,round,2)

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10
mLBF[7:10] <- mLBF[7:10]/2

# Transform datasets - stack two comparisons, and add column for bf and gl
# Each dataset one hypothesis

B <- mLBF %>%
  select(c("Locus","supportType","AIvSA","AIvSI","SAvSI","TvS")) %>%
  melt(id=c("Locus","supportType"))

G <- mLGL %>%
  select(c("Locus","supportType","AIvSA","AIvSI","SAvSI","TvS")) %>%
  melt(id=c("Locus","supportType"))

# Smoosh together again
all <- bind_rows(B,G)

# Originally ran with threshold of dGLS being 0.5, 2x = 1, 4x=2
# trying again with 2, 2x=4, 4x=8

all.e <- left_join(G,B,by=c("Locus","variable"), suffix = c(".g", ".b"))
all.exp <- all.e %>% dplyr::rename(BF = value.b,GL = value.g) %>% select(-c("supportType.b","supportType.g"))

all.2x <- all.exp %>% group_by(variable) %>%
  filter(between(BF,-15,15) |
           between(GL,-6,6)) # "significance levels (5,2) 5 + 5x 2
all.1x <- all.exp %>% group_by(variable) %>%
  filter(between(BF,-10,10) |
           between(GL,-4,4)) # "significance levels (5,2) 5 + 5x 1
all.0x <- all.exp %>% group_by(variable) %>%
  filter(between(BF,-5,5) |
           between(GL,-2,2)) # "significance levels (5,2) 5 + 5x 1

# get percentiles

all.50l <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0),quantile(all.exp$GL, 0.5)) |
           between(BF,quantile(all.exp$BF,0),quantile(all.exp$BF, 0.5)))

all.50h <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.5),quantile(all.exp$GL, 1)) |
           between(BF,quantile(all.exp$BF,0.5),quantile(all.exp$BF, 1)))

all.50m <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.25),quantile(all.exp$GL, 0.75)) |
           between(BF,quantile(all.exp$BF,0.25),quantile(all.exp$BF, 0.75)))

all.60m <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.2),quantile(all.exp$GL, 0.8)) |
           between(BF,quantile(all.exp$BF,0.2),quantile(all.exp$BF, 0.8)))

all.80m <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.1),quantile(all.exp$GL, 0.9)) |
           between(BF,quantile(all.exp$BF,0.1),quantile(all.exp$BF, 0.9)))

#  filter(between(GL,quantile(all.exp$GL, 0.25),quantile(all.exp$GL, 0.75))) # Middle 50% of distribution

# Filter based on only one threshold
#all.short.b <- all.exp %>% group_by(variable) %>%
#  filter(between(BF,-20,20)) # "significance levels (5,0.5) x 4
#all.shorter.b <- all.exp %>% group_by(variable) %>%
#  filter(between(BF,-10,10))  # "significance levels (5,0.5) x 2
#all.short.g <- all.exp %>% group_by(variable) %>%
#  filter(between(GL,-2,2)) # "significance levels (5,0.5) x 4
#all.shorter.g <- all.exp %>% group_by(variable) %>%
#  filter(between(GL,-4,4)) # "significance levels (5,0.5) x 2
#all.mid.b <- all.exp %>% group_by(variable) %>%
#  filter(between(BF,quantile(all.exp$BF, 0.25),quantile(all.exp$BF, 0.75)))  # Middle 50% of distribution
#all.mid.g <- all.exp %>% group_by(variable) %>%
#  filter(between(GL,quantile(all.exp$GL, 0.25),quantile(all.exp$GL, 0.75))) # Middle 50% of distribution

# Testing total number of loci - 1/3 of total loci
# filter(variable != 'TvS') %>%
#all.exp <- all.e %>% dplyr::rename(BF = value.b,GL = value.g) %>% select(-c("supportType.b","supportType.g"))
#all.short <- all.exp %>% group_by(variable) %>%
#  filter(between(BF,-20,20)) %>%
#  filter(between(GL,-2,2)) # "significance levels (5,0.5) x 4
#all.shorter <- all.exp %>% group_by(variable) %>%
#  filter(between(BF,-10,10)) %>%
#  filter(between(GL,-1,1)) # "significance levels (5,0.5) x 2
#nl <- 30
#all.exp <- all.exp %>% group_by(variable) %>%  sample_n(nl)
#all.short <- all.short %>%  group_by(variable) %>%sample_n(nl)
#all.shorter <- all.shorter %>% group_by(variable) %>%sample_n(nl)
#
##proof of concept that Im getting the mid two quantiles
#h <- "AIvSA"
#datf <- all.exp[all.exp$variable==h,]
#d.b <- datf$BF
#d.g <- datf$GL
#b <- IQR.outliers(datf,d.b)
#g <- IQR.outliers(datf,d.g)
#quantile(d.b)[1]
#quantile(d.b)[5]
#quantile(d.b)[2]
#quantile(d.b)[4]
#quantile(datf$BF, 0.25)
#quantile(datf$BF, 0.75)

##################################################################################################
## Test correlation across all hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation

emptyFrame <- function(h,s){
  c.d <- data.frame("test"=c("emp.spearman","emp.pearson"),
                    "sample"=c(s,s),
                    "hypothesis"=c(h,h),
                    "Correlation"=c(NA,NA),
                    "emp"=c(NA,NA),
                    "p0.975"=c(NA,NA),
                    "p0.95"=c(NA,NA),
                    "p0.05"=c(NA,NA),
                    "p0.025"=c(NA,NA))
  return(c.d)
}

corTest <- function(d,h,s){

  # Create two datasets, one to add permutation columns to, one to pull from. because that's how I coded it?
  a <- d %>% filter(variable == h)
  perms <- d %>% filter(variable == h)
  nloci <- length(a$Locus)
  maxB <- max(a$BF)
  minB <- min(a$BF)
  maxG <- max(a$GL)
  minG <- min(a$GL)
  #print(length(a$Locus))

  # Safety check for if a subset of data has too few observations
  if(length(a$Locus) < 5){
    c.d <- emptyFrame(h,s)
    return(c.d)
  }

  # Define which column numbers to test for correlation

  b <- match('BF',names(a))
  g <- match('GL',names(a))

  # Permute BF values in 1,000 seperate columns, could permute BF or GL doesnt matter.

  for (n in 1:1000) {
    newcolname1 <- paste('BF',n,sep='')
    perms[, newcolname1] <- sample(a[[b]], replace = FALSE)
    #newcolname2 <- paste('GL',n,sep='')
    #null[, newcolname2] <- sample(a[[g]], replace = FALSE)
  }

  # Create new dataset to add null rank coefficients to

  assign('null', setNames(data.frame(1:1000), "replicate"))

  # Add bf gl

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1.s <- cor(perms[,'GL'],perms[,colname1],method="spearman")
    null[n,'null.spearman'] <- cc1.s
    cc1.p <- cor(perms[,'GL'],perms[,colname1],method="pearson")
    null[n,'null.pearson'] <- cc1.p
  }

  # Dataframe for emp scores
  emp <- data.frame(TestType=character(),
                    corr.eff=integer(),
                    p=integer(),
                    p0.975=integer(),
                    p0.95=integer(),
                    p0.05=integer(),
                    p0.025=integer(),stringsAsFactors=FALSE)

  # Designate which row is for which test

  emp[1,'TestType'] <- 'emp.spearman'
  emp[2,'TestType'] <- 'emp.pearson'

  # Calculate correlation stats from emperical data,  add to df

  e.s <- cor(a[[b]],a[[g]],method="spearman")
  e.p <- cor(a[[b]],a[[g]],method="pearson")

  emp[1,'corr.eff'] <- e.s
  emp[2,'corr.eff'] <- e.p

  # Calculate 2 sided p values

  p.s <- sum(abs(null$null.spearman) >= abs(e.s)) / length(null$null.spearman)
  p.p <- sum(abs(null$null.pearson) >= abs(e.s)) / length(null$null.pearson)

  emp[1,'p'] <- p.s
  emp[2,'p'] <- p.p

  # Add rows for quantile cut offs

  emp[1,'p0.025'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[1,'p0.975'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[1,'p0.05'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[1,'p0.95'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[2]]
  emp[2,'p0.025'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[2,'p0.975'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[2,'p0.05'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[2,'p0.95'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[2]]

  # Add significance yes/no and other data

  corr.data <- emp %>%
    mutate_if(is.numeric,round,2) %>%
    add_column(Hypothesis = h, .after = "TestType") %>%
    add_column(Sample = s, .after = "TestType") %>%
    add_column(Loci = nloci, .after = "p") %>%
    add_column(minG = minG, .after = "Loci")%>%
    add_column(maxG = maxG, .after = "Loci")%>%
    add_column(minB = minB, .after = "Loci")%>%
    add_column(maxB = maxB, .after = "Loci")

  return(corr.data)
}

tvs <- corTest(all.exp,"TvS","all")
aivsa <- corTest(all.exp,"AIvSA","all")
aivsi <- corTest(all.exp,"AIvSI","all")
savsi <- corTest(all.exp,"SAvSI","all")

tvs.1x <- corTest(all.1x,"TvS","sig1x")
aivsa.1x <- corTest(all.1x,"AIvSA","sig1x")
aivsi.1x <- corTest(all.1x,"AIvSI","sig1x")
savsi.1x <- corTest(all.1x,"SAvSI","sig1x")

tvs.2x <- corTest(all.2x,"TvS","sig2x")
aivsa.2x <- corTest(all.2x,"AIvSA","sig2x")
aivsi.2x <- corTest(all.2x,"AIvSI","sig2x")
savsi.2x <- corTest(all.2x,"SAvSI","sig2x")

tvs.50m <- corTest(all.50m,"TvS","sig50m")
aivsa.50m <- corTest(all.50m,"AIvSA","sig50m")
aivsi.50m <- corTest(all.50m,"AIvSI","sig50m")
savsi.50m <- corTest(all.50m,"SAvSI","sig50m")

tvs.60m <- corTest(all.60m,"TvS","sig60m")
aivsa.60m <- corTest(all.60m,"AIvSA","sig60m")
aivsi.60m <- corTest(all.60m,"AIvSI","sig60m")
savsi.60m <- corTest(all.60m,"SAvSI","sig60m")

tvs.80m <- corTest(all.80m,"TvS","sig80m")
aivsa.80m <- corTest(all.80m,"AIvSA","sig80m")
aivsi.80m <- corTest(all.80m,"AIvSI","sig80m")
savsi.80m <- corTest(all.80m,"SAvSI","sig80m")

tvs.0x <- corTest(all.0x,"TvS","0x")
aivsa.0x <- corTest(all.0x,"AIvSA","0x")
aivsi.0x <- corTest(all.0x,"AIvSI","0x")
savsi.0x <- corTest(all.0x,"SAvSI","0x")

tvs.50l <- corTest(all.50l,"TvS","50l")
aivsa.50l <- corTest(all.50l,"AIvSA","50l")
aivsi.50l <- corTest(all.50l,"AIvSI","50l")
savsi.50l <- corTest(all.50l,"SAvSI","50l")

tvs.50h <- corTest(all.50h,"TvS","50h")
aivsa.50h <- corTest(all.50h,"AIvSA","50h")
aivsi.50h <- corTest(all.50h,"AIvSI","50h")
savsi.50h <- corTest(all.50h,"SAvSI","50h")

## Filter by only one value threshold
#tvs.ser.b <- corTest(all.shorter.b,"TvS","sigx2.b")
#aivsa.ser.b <- corTest(all.shorter.b,"AIvSA","sigx2.b")
#aivsi.ser.b <- corTest(all.shorter.b,"AIvSI","sigx2.b")
#savsi.ser.b <- corTest(all.shorter.b,"SAvSI","sigx2.b")
#
#tvs.s.b <- corTest(all.short.b,"TvS","sigx4.b")
#aivsa.s.b <- corTest(all.short.b,"AIvSA","sigx4.b")
#aivsi.s.b <- corTest(all.short.b,"AIvSI","sigx4.b")
#savsi.s.b <- corTest(all.short.b,"SAvSI","sigx4.b")
#
#tvs.ser.g <- corTest(all.shorter.g,"TvS","sigx2.g")
#aivsa.ser.g <- corTest(all.shorter.g,"AIvSA","sigx2.g")
#aivsi.ser.g <- corTest(all.shorter.g,"AIvSI","sigx2.g")
#savsi.ser.g <- corTest(all.shorter.g,"SAvSI","sigx2.g")
#
#tvs.s.g <- corTest(all.short.g,"TvS","sigx4.g")
#aivsa.s.g <- corTest(all.short.g,"AIvSA","sigx4.g")
#aivsi.s.g <- corTest(all.short.g,"AIvSI","sigx4.g")
#savsi.s.g <- corTest(all.short.g,"SAvSI","sigx4.g")
#
#tvs.m.b <- corTest(all.mid.b,"TvS","mid50.b")
#aivsa.m.b <- corTest(all.mid.b,"AIvSA","mid50.b")
#aivsi.m.b <- corTest(all.mid.b,"AIvSI","mid50.b")
#savsi.m.b <- corTest(all.mid.b,"SAvSI","mid50.b")
#
#tvs.m.g <- corTest(all.mid.g,"TvS","mid50.g")
#aivsa.m.g <- corTest(all.mid.g,"AIvSA","mid50.g")
#aivsi.m.g <- corTest(all.mid.g,"AIvSI","mid50.g")
#savsi.m.g <- corTest(all.mid.g,"SAvSI","mid50.g")

results <- bind_rows(tvs,aivsa,aivsi,savsi,
                     tvs.80m,aivsa.80m,aivsi.80m,savsi.80m,
                     tvs.60m,aivsa.60m,aivsi.60m,savsi.60m,
                     tvs.50m,aivsa.50m,aivsi.50m,savsi.50m,
                     tvs.50l,aivsa.50l,aivsi.50l,savsi.50l,
                     tvs.50h,aivsa.50h,aivsi.50h,savsi.50h,
                     tvs.2x,aivsa.2x,aivsi.2x,savsi.2x,
                     tvs.1x,aivsa.1x,aivsi.1x,savsi.1x,
                     tvs.0x,aivsa.0x,aivsi.0x,savsi.0x) %>% filter(TestType == "emp.spearman")

##  Filter by only one value threshold
#results <- bind_rows(tvs,aivsa,aivsi,savsi,
#                     tvs.ser,aivsa.ser,aivsi.ser,savsi.ser,
#                     tvs.s,aivsa.s,aivsi.s,savsi.s,
#                     tvs.ser.b,aivsa.ser.b,aivsi.ser.b,savsi.ser.b,
#                     tvs.s.b,aivsa.s.b,aivsi.s.b,savsi.s.b,
#                     tvs.ser.g,aivsa.ser.g,aivsi.ser.g,savsi.ser.g,
#                     tvs.s.g,aivsa.s.g,aivsi.s.g,savsi.s.g,
#                     tvs.m.g,aivsa.m.g,aivsi.m.g,savsi.m.g,
#                     tvs.m.b,aivsa.m.b,aivsi.m.b,savsi.m.b) %>% filter(TestType == "emp.spearman")
#
#
#results <- bind_rows(tvs,aivsa,aivsi,savsi,
#                     tvs.ser,aivsa.ser,aivsi.ser,savsi.ser,
#                     tvs.s,aivsa.s,aivsi.s,savsi.s) %>% filter(TestType == "emp.spearman")

#results30a <- results
#results30b <- results
#results30c <- results

#results <- bind_rows(results30a, results30b, results30c)

#library(xlsx)

#fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_correlationSubsampled3.xlsx",sep='')

#write.xlsx2(as.data.frame(results), file=fname, sheetName="Subsample", row.names=FALSE)

# output excel sheet

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_correlation_redo.xlsx",sep='')

write.xlsx2(as.data.frame(results), file=fname, sheetName="ALL", row.names=FALSE)


##
## Network stats
## -------------
##
## Assortativity on zhubo for all networks
##
source("init.r")

library(igraph)
library(data.table)
library(dplyr)
library(ggplot2)

#################################################################################
## Make social networks for each village
##
# get unique households as vertices
# households = unique(subset(hh.all, select=c(Ego.HH, Ego.VillageID, Ego.zhubo1)))
households = hh %>%
  dplyr::select(Ego.HH=HH, Ego.VillageID=VillageID, Ego.zhubo1=zhubo1)

nodes.zhubo = households$Ego.zhubo1 + 1

# individual gifts
dat = subset(hh.dyads, TotalGifts.ind > 0, select=c(Ego.HH, Alter.HH))
g.gift = graph.data.frame(dat, vertices=households, directed=T)        # turn relevant subset into a graph object
adj.gift = get.adjacency( g.gift, sparse=F )                           # create adjaceny matrix

# farm working
dat = subset(hh.dyads, HelpObserved > 0, select=c(Ego.HH, Alter.HH, HelpInstances))
dat$weight = dat$HelpInstances
g.farm = graph.data.frame(dat, vertices=households, directed=T)        # turn relevant subset into a graph object
adj.farm = get.adjacency( g.farm, sparse=F )                           # create adjaceny matrix

# partners
dat = subset(hh.dyads, AnySpousesInAlter > 0, select=c(Ego.HH, Alter.HH))
g.spouse = graph.data.frame(dat, vertices=households, directed=F)      # turn relevant subset into a graph object
g.spouse = simplify(g.spouse)                                          # remove multiple edges (>1 edge between a given pair of nodes)
adj.spouse = get.adjacency( g.spouse, sparse=F )                       # create adjaceny matrix

# kids
dat = subset(hh.dyads, TotalChildrenInAlter > 0, select=c(Ego.HH, Alter.HH))
g.kids = graph.data.frame(dat, vertices=households, directed=F)        # turn relevant subset into a graph object
g.kids = simplify(g.kids)                                              # remove multiple edges (>1 edge between a given pair of nodes)
adj.kids = get.adjacency( g.kids, sparse=F )                           # create adjaceny matrix

# distance between households
dat = subset(hh.dyads, Distance > 0 & !is.na(Distance), select=c(Ego.HH, Alter.HH, Distance))  # keep only pairs of households for which we know the distance between them
dat$weight = dat$Distance
#dat = na.omit(dat)
g.dist = graph.data.frame(dat, vertices=households, directed=F)
g.dist = simplify(g.dist)

#################################################################################
## Assortativity on zhubo
##
round( assortativity.nominal(g.farm,    types=nodes.zhubo, directed=T), 3)
round( assortativity.nominal(g.gift,    types=nodes.zhubo, directed=T), 3)
round( assortativity.nominal(g.spouse,  types=nodes.zhubo, directed=F), 3)
round( assortativity.nominal(g.kids,    types=nodes.zhubo, directed=F), 3)

net_names = c("Farm help", "Gifts", "Partners", "Children")

obs.recip = data.frame(Network = net_names,

                       reciprocity = c(reciprocity(g.farm),
                                       reciprocity(g.gift),
                                       reciprocity(g.spouse),
                                       reciprocity(g.kids)),

                       assortment  = c(assortativity.nominal(g.farm,    types=nodes.zhubo, directed=T),
                                       assortativity.nominal(g.gift,    types=nodes.zhubo, directed=T),
                                       assortativity.nominal(g.spouse,  types=nodes.zhubo, directed=F),
                                       assortativity.nominal(g.kids,    types=nodes.zhubo, directed=F)))

#################################################################################
## simulate random behaviour in networks
##
#' Title
#'
#' @param n.egos
#' @param n.alters
#' @param ties A vector containing each node's out-degree
#' @param labels A list of labels, one for each ego (use `nodes.zhubo`)
#' @param n.sims
#'
#' @return
#' @export
#'
#' @examples
neutral.network.sim = function(n.egos, n.alters, ties, labels, n.sims=1000) {
  require(igraph)

  ## debug ###
  # n.egos = sim.gifts.dat$n_ego; n.alters = sim.gifts.dat$n_alter; ties=sim.gifts.dat$ties; n.sims=10
  # labels=nodes.zhubo
  ###

  # blank.matrix = matrix(0, n.alters - n.egos, n.alters)  # blank matrix to tag onto end (since iGraph needs symmetrical matrix to generate graphs)

  # set up dataframes for results and edges
  recip = data_frame(i=integer(0), reciprocity=numeric(0), assortment=numeric(0))
  nodes = data_frame(id=1:length(labels))

  for (i in 1:n.sims) {
    # gifts.rnd = matrix(0, n.egos, n.alters)
    edgelist = data_frame(ego=integer(0), alter=integer(0))
    egos = c()
    alters = c()

    # each row (giver) can give at least one, up to `n.ties` gifts/helps
    for (j in 1:n.egos) {
      recipients = sample(1:n.alters, ties[j], replace=F)  # choose ties[j] number of recipients
      # gifts.rnd[j, recipients] = 1  # add an edge

      egos = c(egos,
               rep(j, ifelse(length(recipients) > length(ego), length(recipients), 1)))

      alters = c(alters, recipients)
      # edgelist = add_row(edgelist, ego=j, alter=recipients)
    }

    edgelist = add_row(edgelist, ego=egos, alter=alters)

    # make symmetrical matrix
    # gifts.rnd = rbind(gifts.rnd, blank.matrix)
    # generate the graph from adj matrix
    # g.tmp = graph.adjacency(gifts.rnd, mode="directed", diag=F)

    g.tmp = graph.data.frame(edgelist, vertices=nodes, directed=T)

    # save results
    recip = add_row(recip, i=i, reciprocity=reciprocity(g.tmp), assortment=assortativity.nominal(g.tmp, types=labels, directed=T))
  }

  return(recip)
}

#################################################################################
## Simulate random networks
##
# helper function to get numbers of egos and alters in a network, as well as a list of each ego's number of ties
# e.g. filter_str="TotalGifts.ind > 0"
net_struct = function(filter_str=""){
  dat = hh.dyads %>%
    filter_(filter_str) %>%
    dplyr::select(Ego.HH, Alter.HH)

  edges = dat %>%
    group_by(Ego.HH) %>%
    dplyr::summarise(ties = n())

  nodes = dat %>%
    summarise(n_ego   = length(unique(Ego.HH)),
              n_alter = length(unique(Alter.HH)))

  return(list(
    n_ego = nodes$n_ego,
    n_alter = nodes$n_alter,
    ties = edges$ties
  ))
}

# gifts
sim.gifts.dat = net_struct("TotalGifts.ind > 0")
sim.gifts = neutral.network.sim(sim.gifts.dat$n_ego, sim.gifts.dat$n_alter, sim.gifts.dat$ties, nodes.zhubo)
sim.gifts$Network = "Gifts"

# farm help
sim.farm.dat = net_struct("HelpObserved > 0")
sim.farm = neutral.network.sim(sim.farm.dat$n_ego, sim.farm.dat$n_alter, sim.farm.dat$ties, nodes.zhubo)
sim.farm$Network = "Farm help"

# spouses
sim.spouse.dat = net_struct("AnySpousesInAlter > 0")
sim.spouse = neutral.network.sim(sim.spouse.dat$n_ego, sim.spouse.dat$n_alter, sim.spouse.dat$ties, nodes.zhubo)
sim.spouse$Network = "Partners"

# kids
sim.kids.dat = net_struct("TotalChildrenInAlter > 0")
sim.kids = neutral.network.sim(sim.kids.dat$n_ego, sim.kids.dat$n_alter, sim.kids.dat$ties, nodes.zhubo)
sim.kids$Network = "Children"

# bosh them all together
sim.nets = dplyr::bind_rows(sim.gifts, sim.farm, sim.spouse, sim.kids)

sim.nets$Network = factor(sim.nets$Network, levels=net_names)

#################################################################################
## plot assortativities
##
##
ggplot(sim.nets, aes(x=factor(Network), y=assortment)) +
  geom_boxplot() +
  geom_point(data=obs.recip, aes(x=factor(Network), y=assortment), fill="red", colour="red", shape=23, size=3) +

  geom_blank(data=obs.recip) +
  #ylim(c(0, round(max(obs.recip$Value), 1))) +  # extend y-axis so observed reciprocities will appear
  ylab("Simulated/observed reciprocity") +
  xlab("Network") +
  common_theme

ggsave(file.path(plots.dir, "assortment.png"), width=10, height=10, units="cm")
ggsave(file.path(plots.dir, "assortment.pdf"), width=10, height=10, units="cm")

#################################################################################
## Community detection
##
#' Function returning detected communities and a sub-graph containing only nodes that belong to communities containing > 1 node
#'
#' @param g graph, The graph you want to detect clusters for.
#' @param g.fg communities, The output of some_clustering_algorithm(g)
#' @return A list containing the subset of communities and a graph containing the subset of nodes
#'
reduce_communities = function(g, g.fg) {
  # re-run community detection
  #g.fg  = fastgreedy.community(g)
  #spouse.fg.sub = spouse.fg[ sizes(spouse.fg) > 1 ]  # list of households per cluster (where >1 HH in each cluster)

  # get list of households in a cluster by themselves
  solo_houses = unlist( g.fg[ sizes(g.fg) == 1 ] )

  # subset cluster memberhips to keep only nodes clusters containing > 1 house
  mem = membership(g.fg)
  mem = mem[ !V(g)$name %in% solo_houses ]

  # get communities for each of the remaining houses
  # this line of code is from igraph:::communities -- the output of this is passed to the 'mark.groups' parameter in plot()
  com = igraph:::groups.default(list(membership = mem))

  g.sub = induced_subgraph(graph=g, !V(g)$name %in% solo_houses)

  return( list(
    com.reduced = com,
    membership = mem,
    g.sub = g.sub
  ))
}

##
## Plot detected communities for all villages
##
# plotting options
node_size = 4
edge_width = 1

#zhu_colours = c("black", "red")      # zhu houses will be red
zhu_shapes = c("circle", "square")   # zhu houses will be squares
#l <- layout.fruchterman.reingold(all, niter=100)

village_ids = unique(hh.dyads$Ego.VillageID)

for (village in village_ids)
{
  # subset graphs to keep only current village
  g.farm.v2   = induced_subgraph(graph=g.farm,   which(V(g.farm)$Ego.VillageID==village))
  g.gift.v2   = induced_subgraph(graph=g.gift,   which(V(g.gift)$Ego.VillageID==village))
  g.kids.v2   = induced_subgraph(graph=g.kids,   which(V(g.kids)$Ego.VillageID==village))
  g.spouse.v2 = induced_subgraph(graph=g.spouse, which(V(g.spouse)$Ego.VillageID==village))

  # get communities with > 1 house in each graph
  reduced.farm   = reduce_communities(g.farm.v2,   cluster_edge_betweenness(g.farm.v2))
  reduced.gift   = reduce_communities(g.gift.v2,   cluster_edge_betweenness(g.gift.v2))
  reduced.kids   = reduce_communities(g.kids.v2,   fastgreedy.community(g.kids.v2))
  reduced.spouse = reduce_communities(g.spouse.v2, fastgreedy.community(g.spouse.v2))

  #png(file=paste0("clusters - village ", village, ".png"), height=30, width=30, units="cm", res=300)
  pdf(file=file.path(plots.dir, paste0("clusters - village ", village, ".pdf")), height=12, width=12)
  par(mfrow=c(2,2))

  plot(reduced.farm$g.sub, #margin=-0.1,
       vertex.label=NA, vertex.size=node_size, vertex.shape=zhu_shapes[V(reduced.farm$g.sub)$Ego.zhubo1 + 1],
       #vertex.color=zhu_colours[V(reduced.farm$g.sub)$Ego.zhubo1 + 1],
       vertex.color=reduced.farm$membership,
       edge.width=edge_width, edge.arrow.size=0.5, edge.arrow.width=0.5  # make the edges a bit prettier
       #mark.groups = reduced.farm$com.reduced, mark.expand = 20
       )
  #title("Farm labour", adj=0)
  title("(a)", adj=0)

  plot(reduced.gift$g.sub, #margin=-0.1,
       vertex.label=NA, vertex.size=node_size, vertex.shape=zhu_shapes[V(reduced.gift$g.sub)$Ego.zhubo1 + 1],
       #vertex.color=zhu_colours[V(reduced.gift$g.sub)$Ego.zhubo1 + 1],
       vertex.color=reduced.gift$membership,
       edge.width=edge_width, edge.arrow.size=0.5, edge.arrow.width=0.5  # make the edges a bit prettier
       #mark.groups = reduced.gift$com.reduced, mark.expand = 20
       )
  #title("Gifts", adj=0)
  title("(b)", adj=0)

  # library(dplyr)
  # unlist(reduced.gift$com.reduced) %>% as_data_frame() %>% summarise(n())

  plot(reduced.spouse$g.sub, #margin=-0.1,
       vertex.label=NA, vertex.size=node_size, vertex.shape=zhu_shapes[V(g.spouse)$Ego.zhubo1 + 1],
       #vertex.color=zhu_colours[V(g.spouse)$Ego.zhubo1 + 1],
       vertex.color=reduced.spouse$membership,
       edge.width=edge_width, edge.arrow.size=0.5, edge.arrow.width=0.5  # make the edges a bit prettier
       #mark.groups = reduced.spouse$com.reduced, mark.expand = 20
       )
  #title("Partners", adj=0)
  title("(c)", adj=0)

  plot(reduced.kids$g.sub, #margin=-0.1,
       vertex.label=NA, vertex.size=node_size, vertex.shape=zhu_shapes[V(reduced.kids$g.sub)$Ego.zhubo1 + 1],
       #vertex.color=zhu_colours[V(reduced.kids$g.sub)$Ego.zhubo1 + 1],
       vertex.color=reduced.kids$membership,
       edge.width=edge_width, edge.arrow.size=0.5, edge.arrow.width=0.5  # make the edges a bit prettier
       #mark.groups = reduced.kids$com.reduced, mark.expand = 20
       )
  #title("Children", adj=0)
  title("(d)", adj=0)

  dev.off()
  par(mfrow=c(1,1))

  print(paste0("Printed village ", village))
}


# originally made to produce maps of Saffir-Simpson index for all Atlantic hurricanes in HURDAT
# TODO: add basemap to png
# TODO: export tif
# args are: 1) input GIS vector points, 2) map units per pixel side (spatial resolution)
# example use: Rscript --vanilla $0 AL132003.shp 0.5

# load prereqs
library(methods) # this is only required when running with Rscript
library(maptools)
library(akima)
# get user args
args <- commandArgs(trailingOnly = TRUE)
# load points
d <- readShapePoints(args[1])
# get name of layer without file extension - assumes a period then a file extension then end of line
# needed for plot title, png filename
layerName <- unlist(strsplit(basename(args[1]),"\\."))[1]
# numeric fields are numeric
# TODO loop over user arg list of fields
d$lon <- as.numeric(as.character(d$lon))
d$lat <- as.numeric(as.character(d$lat))
d$sshws <- as.numeric(as.character(d$sshws))
# cubic spline using akima package
# note that map units are used as the spatial res, and that BBOX is used for grid
# user arg is for a multiple of the map units, eg 2 to coarse, 0.5 to make finer
pixelDivisor <- as.numeric(args[2])
d.li <- interp(d$lon,d$lat,d$sshws, xo=seq(bbox(d)[1,1],bbox(d)[1,2], length=abs(bbox(d)[1,1] - bbox(d)[1,2])/pixelDivisor),yo=seq(bbox(d)[2,1],bbox(d)[2,2], length=abs(bbox(d)[2,1] - bbox(d)[2,2]/pixelDivisor)),linear=FALSE,extrap=TRUE)
# enforce min (0) and max (particular to the HURDAT points)
# first find the SSHWS max
maxsshws <- max(d$sshws)
# now enforce 0 min and SSHWS max on trend grid
maxsshws <- max(d$sshws); d.li$z <- round(replace(replace(d.li$z,d.li$z>maxsshws,maxsshws),d.li$z<0,0))
# visual
png(paste("/tmp/",layerName,".png",sep=''))
image(d.li)
title(main=paste(layerName, ", "," Linear Interpolation from Akima",sep=''))
contour(d.li,labcex=1,add=T,nlevels=maxsshws)
points(d$lon,d$lat)
dev.off()


# Custom Math
# Paul Sztorc
# Written in R (v 3.1.1) using Rstudio (v 0.98.1028)

# A collection of relatively basic functions.

AsMatrix <- function(Vec) {
  # Takes a vector and transforms it into a 1 column matrix
  return(matrix(Vec,nrow=length(Vec)))
}

# Vector <- c(3,4,5)
# > Vector
# [1] 3 4 5
# > AsMatrix(Vector)
#       [,1]
# [1,]    3
# [2,]    4
# [3,]    5

MeanNA <- function(Vec) {
  # Replaces NA instances with their mean instead
  m <- mean(Vec, na.rm = TRUE)
  Vec[is.na(Vec)] <- m
  return(Vec)
}

# > MeanNA(c(3,4,6,7,8))
# [1] 3 4 6 7 8

# > MeanNA(c(3,NA,6,7,8))
# [1] 3 6 6 7 8

# > MeanNA(c(0,0,0,1,NA))
# [1] 0.00 0.00 0.00 1.00 0.25

# > MeanNA(c(0,0,NA,1,NA))
# [1] 0.0000000 0.0000000 0.3333333 1.0000000 0.3333333

GetWeight <- function(Vec,AddMean=FALSE) {
  # Takes a Vector, absolute value, then proportional linear deviance from 0.
  new <- abs(Vec)
  if(AddMean==1) new  <- new + mean(new)
  if(sum(new)==0) new <- new + 1
  new <- new/sum(new)
  return(new)
}

# > GetWeight(c(1,1,1,1))
# [1] 0.25 0.25 0.25 0.25
# > GetWeight(c(10,10,10,10))
# [1] 0.25 0.25 0.25 0.25
# > GetWeight(c(4,5,6,7))
# [1] 0.1818182 0.2272727 0.2727273 0.3181818
# > GetWeight(c(4,5,6,7),TRUE)
# [1] 0.2159091 0.2386364 0.2613636 0.2840909

Catch <- function(X,Tolerance=0) {
  # x is the ConoutRAW numeric, Tolerance is the length of the midpoint corresponding to .5
  # The purpose here is to handle rounding for Binary Decisions (Scaled Decisions use weighted median)

  if(X<(.5-(Tolerance/2))) return(0)
  else if(X>(.5+(Tolerance/2))) return(1)
  else return(.5)

}

# > Catch(.4)
# [1] 0
# > Catch(.5)
# [1] 0.5
# > Catch(.6)
# [1] 1
# > Catch(.6,Tolerance=.1)
# [1] 1
# > Catch(.6,Tolerance=.2)
# [1] 0.5

weighted.median <- function(x, w, na.rm=TRUE, ties=NULL) {
  # Thanks to https://stat.ethz.ch/pipermail/r-help/2002-February/018614.html
  if (missing(w))
    w <- rep(1, length(x));

  # Remove values that are NA's
  if (na.rm == TRUE) {
    keep <- !(is.na(x) | is.na(w));
    x <- x[keep];
    w <- w[keep];
  } else if (any(is.na(x)))
    return(NA);

  # Assert that the weights are all non-negative.
  if (any(w < 0))
    stop("Some of the weights are negative; one can only have positive
         weights.");

  # Remove values with weight zero. This will:
  #  1) take care of the case when all weights are zero,
  #  2) make sure that possible tied values are next to each others, and
  #  3) it will most likely speed up the sorting.
  n <- length(w);
  keep <- (w > 0);
  nkeep <- sum(keep);
  if (nkeep < n) {
    x <- x[keep];
    w <- w[keep];
    n <- nkeep;
  }

  # Are any weights Inf? Then treat them with equal weight and all others
  # with weight zero.
  wInfs <- is.infinite(w);
  if (any(wInfs)) {
    x <- x[wInfs];
    n <- length(x);
    w <- rep(1, n);
  }

  # Are there any values left to calculate the weighted median of?
  if (n == 0)
    return(NA);

  # Order the values and order the weights accordingly
  ord <- order(x);
  x <- x[ord];
  w <- w[ord];

  wcum <- cumsum(w);
  wsum <- wcum[n];
  wmid <- wsum / 2;

  # Find the position where the sum of the weights of the elements such that
  # x[i] < x[k] is less or equal than half the sum of all weights.
  # (these two lines could probably be optimized for speed).
  lows <- (wcum <= wmid);
  k  <- sum(lows);

  # Two special cases where all the weight are at the first or the
  # last value:
  if (k == 0) return(x[1]);
  if (k == n) return(x[n]);

  # At this point we know that:
  #  1) at most half the total weight is in the set x[1:k],
  #  2) that the set x[(k+2):n] contains less than half the total weight
  # The question is whether x[(k+1):n] contains *more* than
  # half the total weight (try x=c(1,2,3), w=c(1,1,1)). If it is then
  # we can be sure that x[k+1] is the weighted median we are looking
  # for, otherwise it is any function of x[k:(k+1)].

  wlow  <- wcum[k];    # the weight of x[1:k]
  whigh <- wsum - wlow;  # the weight of x[(k+1):n]
  if (whigh > wmid)
    return(x[k+1]);

  if (is.null(ties) || ties == "weighted") {  # Default!
    (wlow*x[k] + whigh*x[k+1]) / wsum;
  } else if (ties == "max") {
    x[k+1];
  } else if (ties == "min") {
    x[k];
  } else if (ties == "mean") {
    (x[k]+x[k+1])/2;
  } else if (ties == "both") {
    c(x[k], x[k+1]);
  }
}

# > weighted.median(x=c(3,4,5),w=c(.2,.2,.6))
# [1] 5
# > weighted.median(x=c(3,4,5),w=c(.2,.2,.5))
# [1] 5
# > weighted.median(x=c(3,4,5),w=c(.2,.2,.4))
# [1] 4.5

Rescale <- function(UnscaledMatrix, ScalingData) {
  # Forces a matrix of raw (user-supplied) information (for example, # of House Seats, or DJIA) to conform to svd-appropriate range.
  # Practically, this is done by subtracting min and dividing by scaled-range (which itself is max-min).

  # Calulate multiplicative factors
  InvSpan = ( 1/ ( ScalingData["Max",] - ScalingData["Min",]) )

  #Recenter
  OutMatrix <- sweep(UnscaledMatrix, 2, ScalingData["Min",])

  #Rescale
  NaIndex <- is.na(OutMatrix) #NA-Preempt
  OutMatrix[NaIndex] <- 0
  OutMatrix <- OutMatrix %*% diag(InvSpan)
  OutMatrix[NaIndex] <- NA #Restore NA's

  #Relabel
  row.names(OutMatrix) <- row.names(UnscaledMatrix)
  colnames(OutMatrix) <- colnames(UnscaledMatrix)

  return(OutMatrix)
}

# Scales <- matrix( data=c( 0,    0,    0,    0,      1,          1,
#                           0,    0,    0,    0,      0,       8000,
#                           1,    1,    1,    1,    435,     20000 ), nrow=3, byrow=TRUE)
#
# colnames(Scales) <- c("C1.1", "C2.1", "C3.0", "C4.0", "C5.233", "C6.1602759")
# row.names(Scales) <- c("Scaled", "Min", "Max")
#
# Scales
#
# M <- matrix( data=c(
#       1,    1,    0,    0,    233,   16027.59,
#       1,    0,    0,    0,    199,         NA,
#       1,    1,    0,    0,    233,   16027.59,
#       1,    1,    1,    0,    250,         NA,
#       0,    0,    1,    1,    435,    8001.00,
#       0,    0,    1,    1,    435,   19999.00),
#   nrow=6,byrow=TRUE)
#
# colnames(M) <- c("C1.1", "C2.1", "C3.0", "C4.0", "C5.233", "C6.1602759")
# row.names(M) <- paste("Voter",1:6)
#
# Rescale(M,Scales)
#
# C1.1 C2.1 C3.0 C4.0    C5.233   C6.1602759
# Voter 1    1    1    0    0 0.5356322 6.689658e-01
# Voter 2    1    0    0    0 0.4574713           NA
# Voter 3    1    1    0    0 0.5356322 6.689658e-01
# Voter 4    1    1    1    0 0.5747126           NA
# Voter 5    0    0    1    1 1.0000000 8.333333e-05
# Voter 6    0    0    1    1 1.0000000 9.999167e-01

Influence  <- function(Weight) {
  # Takes a normalized Vector (one that sums to 1), and computes relative strength of the indicators.
  # this is because by-default the conformity of each Author and Judge is expressed relatively.

  Expected <- rep(1/length(Weight),length(Weight))
  return( Weight / Expected)
}

# > Influence(c(.25,.25,.25,.25))
# [1] 1 1 1 1
# > Influence(c(.3,.3,.4))
# [1] 0.9 0.9 1.2
# > Influence(c(.99,.0025,.0025,.0025,.0025))
# [1] 4.9500 0.0125 0.0125 0.0125 0.0125

ReWeight <- function(Vec,exclude=is.na(Vec)) {
  # Get the relative influence of numbers, treat NA as influence-less

  if(!identical(Vec,abs(Vec))) {
    print("Warning: Expected all positive.")
  }

  # force well-behaved
  Out <- abs(Vec)
  Out[exclude] <- 0

  # division by zero error
  if(sum(Out)==0) Out <- Out + 1

  # Reweight
  Out <- Out/sum(Out)

  return(Out)
}

# > ReWeight(c(1,1,1,1))
# [1] 0.25 0.25 0.25 0.25
# > ReWeight(c(NA,1,NA,1))
# [1] 0.0 0.5 0.0 0.5
# > ReWeight(c(2,4,6,12))
# [1] 0.08333333 0.16666667 0.25000000 0.50000000
# > ReWeight(c(2,4,NA,12))
# [1] 0.1111111 0.2222222 0.0000000 0.6666667

ReverseMatrix <- function(Mat) {
  #Inverts a binary matrix
  return((Mat-1)*-1)
}

# M <- matrix(
#   nrow=3,
#   byrow=TRUE,
#   data=c(
#     0,0,1,
#     1,1,0,
#     0,0,0))
#
#       [,1] [,2] [,3]
# [1,]    0    0    1
# [2,]    1    1    0
# [3,]    0    0    0
# > ReverseMatrix(M)
#       [,1] [,2] [,3]
# [1,]    1    1    0
# [2,]    0    0    1
# [3,]    1    1    1

WeightedPrinComp <- function(X, Weights, Verbose=FALSE) {
  # Takes Matrix X and vector of row-weights "Weights"
  # Manually computes the statistical procedure known as Principal Components Analysis (PCA)
  # This version of the procedure is so basic, that it can also be thought of as merely a singular-value decomposition on a weighted covariance matrix.

  if(missing(Weights)) {
    Weights <- ReWeight(rep(1,nrow(X)))
  }

  if(length(Weights)!=nrow(X)) {
    print("Error: Weights must be equal to nrow(X)")
    return(NULL)
  }

  wCVM <- cov.wt(x=X, wt=Weights) # Weighted Covariance Matrix

  # http://en.wikipedia.org/wiki/Singular_value_decomposition
  L <- svd(wCVM$cov)$u[,1]                                           # extract first Loading (first column of U matrix)
  S <- as.vector( scale(X, center=wCVM$center, scale=FALSE) %*% L)   # manually calculate the first Score, using the input matrix, covariance matrix, and first loading
  # (center subtracts the weight-adjusted-means from X's columns)
  # (scale=FALSE means that no scaling is done)
  # %*% is matrix multiplication

  if(Verbose) {
    Ls <- svd(wCVM$cov)$u # the entire u matrix
    Ss <- scale(X, center=wCVM$center, scale=FALSE) %*% Ls # all of the scores
    print("Loadings: ")
    print(Ls)
    print(" ")
    print("Scores:")
    print(Ss)
    print(" ")
  }

  Out <- list("Scores"=S,"Loadings"=L)
  return(Out)
}

# M <- matrix(
#   nrow=3,
#   byrow=TRUE,
#   data=c(
#     0,0,1,
#     1,1,0,
#     0,0,0))
#
# M2 <- cbind(M,c(.7,.5,.2))

# > WeightedPrinComp(M)
# $Scores
# [1]  0.7251092 -0.9905177  0.2654084
# $Loadings
# [1] -0.6279630 -0.6279630  0.4597008
#
#
# > WeightedPrinComp(M,c(.33333,.33333,.33333))
# $Scores
# [1]  0.7251092 -0.9905177  0.2654084
# $Loadings
# [1] -0.6279630 -0.6279630  0.4597008
#
# > WeightedPrinComp(M,c(.1,.1,.8))
# $Scores
# [1]  0.2762801 -1.2732354  0.1246194
# $Loadings
# [1] -0.6989274 -0.6989274  0.1516607
#
# > WeightedPrinComp(M2)
# $Scores
# [1]  0.7385624 -0.9866042  0.2480418
# $Loadings
# [1] -0.62428014 -0.62428014  0.46733010  0.04638101
#
# > WeightedPrinComp(M2,c(.1,.1,.8))
# $Scores
# [1]  0.1269693 -1.2954637  0.1460618
# $Loadings
# [1] -0.69461121 -0.69461121  0.06807931 -0.17434371


Data <- matrix(Data,8,16,byrow=TRUE)
par(mai=c(0,0,0,0))
plot(c(0,16),c(0,8),type="n",axes=FALSE,ann=FALSE)
min <- 0

for ( i in 1:16) {
	for (j in 1:8 ) {
		if ( log(Data[9-j,17-i]) != log(2) && log(Data[9-j,17-i]) != log(0) && log((Data[9-j,17-i])) < min) {
			min =  log((Data[9-j,17-i]))
		}
	}
}

max <- min

for ( i in 1:16) {
	for (j in 1:8 ) {
		if ( log(Data[9-j,17-i]) != log(2) && log(Data[9-j,17-i]) != log(0) && log((Data[9-j,17-i])) > max) {
			max =  log((Data[9-j,17-i]))
		}
	}
}

for ( i in 1:16) {
	for (j in 1:8 ) {
		if ( Data[9-j,17-i] == 2 ) {
			polygon(c(17-i-1,17-i-1,17-i,17-i),c(j-1,j,j,j-1),col=rgb(0,0,0,maxColorValue=255),border="black")
		} else if ( Data[9-j,17-i] == 0 ) {
			polygon(c(17-i-1,17-i-1,17-i,17-i),c(j-1,j,j,j-1),col=rgb(255,255,255,maxColorValue=255),border="black")
		} else if ( min == max ) {
			polygon(c(17-i-1,17-i-1,17-i,17-i),c(j-1,j,j,j-1),col=rgb(255, 0, 0 ,maxColorValue=255),border="black")
		} else {
			polygon(c(17-i-1,17-i-1,17-i,17-i),c(j-1,j,j,j-1),col=rgb(255, 250*( (log(Data[9-j,17-i])-max)*(1/(min-max)) ), 250*( (log(Data[9-j,17-i])-max)*(1/(min-max)) ),maxColorValue=255),border="black")
		}

	}
}

polygon(c(0.25,0.25,0.75,0.75),c(2.25,2.75,2.75,2.25),col=rgb(175,175,0,maxColorValue=255),border=NA)
polygon(c(15.25,15.25,15.75,15.75),c(4.25,4.75,4.75,4.25),col=rgb(175,175,0,maxColorValue=255),border=NA)

polygon(c(pos1[1]+0.25,pos1[1]+0.25,pos1[1]+0.75,pos1[1]+0.75),c(pos1[2]+0.25,pos1[2]+0.75,pos1[2]+0.75,pos1[2]+0.25),col=rgb(0,200,200,maxColorValue=255),border=NA)
polygon(c(pos2[1]+0.25,pos2[1]+0.25,pos2[1]+0.75,pos2[1]+0.75),c(pos2[2]+0.25,pos2[2]+0.75,pos2[2]+0.75,pos2[2]+0.25),col=rgb(50,0,0,maxColorValue=255),border=NA)

polygon(c(2.35,2.5,2.65),c(7.35,7.65,7.35),col=rgb(0,200,0,maxColorValue=255),border=NA)
polygon(c(5.35,5.5,5.65),c(5.35,5.65,5.35),col=rgb(0,200,0,maxColorValue=255),border=NA)
polygon(c(4.35,4.5,4.65),c(3.35,3.65,3.35),col=rgb(0,200,0,maxColorValue=255),border=NA)
polygon(c(6.35,6.5,6.65),c(0.35,0.65,0.35),col=rgb(0,200,0,maxColorValue=255),border=NA)
polygon(c(11.35,11.5,11.65),c(6.35,6.65,6.35),col=rgb(0,200,0,maxColorValue=255),border=NA)
polygon(c(11.35,11.5,11.65),c(4.35,4.65,4.35),col=rgb(0,200,0,maxColorValue=255),border=NA)
polygon(c(10.35,10.5,10.65),c(2.35,2.65,2.35),col=rgb(0,200,0,maxColorValue=255),border=NA)

dev.off()


mstft <- function(x) {
  n <- length(x)
  s <- attr(x, "win:sum")
  if (is.null(s))
    s <- n
  s <- 2.0 / s
  no2 <- n / 2
  no2p1 <- no2 + 1
  s * abs(fft(x))[1:no2p1]
}

mstftdb <- function(x) {
  20 * log10(mstft(x) + 1)
}


#Affiche le diagramme des 20 plus grandes occurrences des données csv des products chargés
plotP <- function(path) {
	data = read.csv(path)
pnames=data[,1]
pnum=data[,2]

infNum = 0
if(length(pnum)>20){
	infNum = (length(pnum) - 20)
}

infName = 0
if(length(pnum)>20){
	infName = (length(pnames) - 20)
}

y = pnum[infNum:length(pnum)]
x = pnames[infName:length(pnames)]
names(y)=x
label = paste("All data ",length(pnum)," | SD: ",sd(pnum)," |  Avg: ",mean(pnum))
barplot(y, col=rgb(0.0,0.0,1,1), xlab=label, ylab="occurrences", main="Products occurrences" , ylim=c(0,floor(max(y)/10) *10 + 10) )
}

#Affiche le diagramme des 20 plus grandes occurrences des données csv des features chargés
plotF <- function(path) {
data = read.csv(path)
pnames=data[,1]
pnum=data[,2]
infNum = 0
if(length(pnum)>20){
	infNum = (length(pnum) - 20)
}

infName = 0
if(length(pnum)>20){
	infName = (length(pnames) - 20)
}
y = pnum[infNum:length(pnum)]
x = pnames[infName:length(pnames)]
names(y)=x
label =paste("All data ",length(pnum)," | SD: ",sd(pnum)," |  Avg: ",mean(pnum));
barplot(y, col=rgb(0.0,0.0,1,1), xlab=label, ylab="occurrences", main="Features occurrences" , ylim=c(0,floor(max(y)/10) *10 + 10) )
}

loadPcmStat <- function(path) {
	csvData = d=read.csv(file=path,sep=',',header=F)
	n<-csvData[,1]
	nbl<-csvData[,2]
	nbc<-csvData[,3]
	tm<-csvData[,4]
	pcms<- n[3:length(n)]
	nbLigne <- nbl[3:length(nbl)]
	nbCol <- nbc[3:length(nbc)]
	tailles <- tm[3:length(tm)]

	matr <- matrix(c(nbLigne,nbCol,tailles),nrow=length(nbLigne),3)
csvData
}


# Assignment 3: Using Data
#
# Before you get started:
# - Set your working directory to "source file location" using the Session menu
# - Run the following line of code to delete all variables in your workspace
#     (This will make it easier to test your script)
rm(list = ls())

### Built in R Data ###########################################################

# In this section, you'll work with the variable `Titanic`, a data set which is
# built into the R environment.
# This data set actually loads in a format called a *table*
# See https://cran.r-project.org/web/packages/data.table/data.table.pdf
# Use the `is.data.frame()` function to test if it is a table.
is.data.frame(Titanic)

# Create a variable `titanic_df` by converting `Titanic` into a data frame;
# you can use the `data.frame()` function or `as.data.frame()`
titanic_df <- data.frame(Titanic, stringsAsFactors = FALSE)

# It's important to understand the _meaning_ of each column before analyzing it
# Using comments below, describe what information is stored in each column
# For categorical variables, list all possible values
# Class: [1st, 2nd, 3rd, Crew]
# Sex: [Either 'Male' or 'Female']
# Age: [Either 'Adult' or 'Child']
# Survived: [Either 'Yes' or 'No']
# Freq: [The number of people in each categorical variable]

# Create a variable `children` that is a data frame containing only the rows
# from `titanic_df` with information about children on the Titanic
# Hints:
# - Filter rows using a vector of boolean values (like vector filtering)
# - See chapter 10.2.3
children <- titanic_df[titanic_df$Age == "Child", ]

# Create a variable `num_children` that is the total number of children.
# Hint: Remember the `sum()` function!
num_children <- sum(titanic_df$Freq)

# Create a variable `most_lost` that is the *row* from `titanic_df` with the
# largest absolute number of losses (people who did not survive)
# You can use multiple lines of code if you find that helpful
# to create this variable
# Hint: Filter for those who did not survive, then look for the row
who_did_not_survive <- titanic_df[titanic_df$Survived == "No", ]
most_lost <- who_did_not_survive[who_did_not_survive$Freq ==
                                   max(who_did_not_survive$Freq), ]

# Define a function called `survival_rate()` that takes in two arguments which
# must be in *the following order*:
# - a ticket class (e.g., "1st", "2nd"), and
# - the dataframe itself (it's good practice to explicitly pass in data frames)

# This function should return a sentence that states the *survival rate*
# (# survived / # in group) of adult men and "women and children" in that
# ticketing class.
# It should read (for example):
# >"Of Crew class, 87% of women and children survived and 22% of men survived."
#
# This is a complicated function! We recommend the following approach:
# - Filter for all rows representing the given ticketing class and save the
#   new data frame to a variable
# - Using this data frame, filter for all rows representing Adult Males
# - Find the total number of men and total number of male survivors to
#   calculate the survival rate
# - Likewise, use the data frame to filter for all Children and Adult Females
# - Perform the above calculation for this group as well
#
# Other approaches are also acceptable, please comment to explain what you do!
survival_rate <- function(ticket_class, data_frame) {
  #new overall data frame of given ticketing class
  given_class <- data_frame$Class == ticket_class
  #new data frame of adult males in given ticketing class
  adult_males_in_class <- given_class$Age == "Adult" & given_class$Sex == "Male"
  #variable for total men
  total_adult_males <- sum(adult_males_in_class$Freq)
  #variable for total male survivors
  total_male_survivors <- adult_males_in_class$Survivors == "Yes"
  #variable for survival rate of males
  male_survival_rate <- round((total_male_survivors/adult_males_in_class) * 100)
  #variable for total women and children
  women_and_children_in_class <- sum(given_class$Freq) - total_adult_males
  #total women and children and total women/children survivors
  total_women_and_children_survivors <- women_and_children_in_class$Survivors == "Yes"
  #variable for survival rate of women and children
  women_and_children_survival_rate <- round((total_women_and_children_survivors/
                                             women_and_children_in_class) * 100)
  #sentence stating survival rate
  sentence <- paste0("Of", sep = " ", ticket_class, sep = " ", "class,",
                     sep = " ", women_and_children_survival_rate, "% of women
                     and children survived and", sep = " ", men_survival_rate,
                     "% of men survived.")
  sentence
}

# Create variables `first_survived`, `second_survived`, `third_survived` and
# `crew_survived` by passing each class and the `titanic_df` data frame
# to your `survival_rate` function
first_survived <- survival_rate("1st", titanic_df)
second_survived <- survival_rate("2nd", titanic_df)
third_survived <- survival_rate("3rd", titanic_df)
crew_survived <- survival_rate("Crew", titanic_df)

# What notable differences do you observe in the survival rates across classes?
# Note at least 2 observations.
# [The higher social class has the larger survival rate. Adults were
# significantly more likely to survive compared to children across all classes.]

# What notable differences do you observe in the survival rates between the
# women and children versus the men in each group?
# Note at least 2 observations.
# [Women and children survivors among all classes were significantly more than men.
# The survival rate for women and children in the 1st class was about 2.5 times
# more than men in the 1st class.]

### Reading in Data ###########################################################

# In this section, you'll work with .csv data of life expectancy by country
# First, download the csv file of `Life Expectancy` data from GapMinder:
# https://www.gapminder.org/data/
# You should save the .csv file into your `data` directory

# Before getting started, explore the GapMinder website to better understand
# the *original* source of the data (e.g., who calculated these estimates)
# Place a brief summary of the each data source here (e.g., 1 - 2 sentences
# per data source)
# [The 'Life Expectancy' data has three main sources that are combined together
#  to span from 1800-2099. The v7 source by Mattias Lindgren covers the time
# period from 1800-1970 and this source itself is compiled from 100 sources on
# huge, fatal disasters. THe IHME source covers the time period from 1970-2016
# which takes information from the Global Burden of Disease Study of 2017 done
# at the University of Washington. The UN source covers the time period from
# 2017-2099 and is based on the 'World Population Prospects 2019' file.]

# Using the `read.csv` function, read the life_expectancy_years.csv file into
# a variable called `life_exp`.
life_exp <- read.csv("data/life_expectancy_years.csv", )

# Write a function `get_col_mean()` that takes a column name and a data frame
# and returns the mean of that column. Make sure to properly handle NA values
# Hint: `mean()` takes in an argument called `na.rm`
get_col_mean <- function(column_name, life_exp) {
  mean(data_frame[[column_name]], na.rm = T)
}

# Create a list `col_means` that has the mean value of each column in the
# data frame (except the `Country` column). You should use your function above.
# Hint: Use an `*apply` function (lapply, sapply, etc.)
relevant_col <- colnames(life_exp)[1:300(life_exp)]
col_means <- as.list(sapply(relevant_col, get_col_mean))

# Create a variable `avg_diff` that is the difference in average country life
# expectancy between 1800 and 2018
avg_diff <- get_col_mean("2018", life_exp) - get_col_mean("1800", life_exp)

# Create a column `life_exp$change` that is the change in life
# expectancy from 2000 to 2018. Increases in life expectancy should
# be *positive*
life_exp$change <- life_exp$"2018" - life_exp$"2000"

# Create a variable `most_improved` that is the *name* of the country
# with the largest gain in life expectancy. Make sure to filter NA values
# Hint: `max()` takes in an argument called `na.rm`
most_improved <- life_exp[life_exp$change == max(life_exp$change, na.rm = T), "country"]

# Create a variable `num_small_gain` that has the *number* of countries
# whose life expectance has improved less than 1 year between 2000 and 2018
# Make sure to filter NA values
# Hint: Lookup `is.na()`
num_small_gain <- nrow(!is.na(life_exp[life_exp$change > 0 & life_exp$change < 1, ]))

# Write a function `country_change()` that takes in a country's name,
# two years as numbers (not strings), and the `life_exp` data frame
# Parameters should be written *in the above order*
# It should return the phrase:
# "Between YEAR1 and YEAR2, the life expectancy in COUNTRY went DIRECTION by
# SOME_YEARS years".
# Make sure to properly indictate the DIRECTION as "up" or "down"
# Hint: Use an if/else statement to help compute DIRECTION
country_change <- function(country_name, year_one, year_two, life_exp) {

  year_one_life_exp <- life_exp[life_exp$country == country_name, year_one]
  year_two_life_exp <- life_exp[life_exp$country == country_name, year_two]
  absolute_difference <- abs(life_exp[life_exp$country == country_name, year_one]
                             - life_exp[life_exp$country == country_name, year_two])

  if (year_one_life_exp > year_two_life_exp) {
    sentence <- paste0("Between", sep = " ", year_one, sep = " ", "and", sep = " "
                     , year_two, ", the life expectancy in", sep = " ", country_name
                     , sep = " ", "went up by", sep = " ", absolute_difference, sep = " ",
                     "years.")
  } else if (year_two_life_exp > year_one_life_exp) {
    sentence <- paste0("Between", sep = " ", year_one, sep = " ", "and", sep = " "
                     , year_two, ", the life expectancy in", sep = " ", country_name
                     , sep = " ", "went down by", sep = " ", absolute_difference, sep = " ",
                     "years.")
  } else if (year_one_life_exp == year_two_life_exp) {
    sentence <- paste0("Between", sep = " ", year_one, sep = " ", "and", sep = " "
                     , year_two, ", the life expectancy in", sep = " ", country_name
                     , sep = " ", "stayed the same.")
  }
  sentence
}

# Using your `country_change()` function, create a variable `sweden_change`
# that is the change in life expectancy from 1960 to 1990 in Sweden
sweden_change <- country_change("Sweden", 1960, 1990)

# Write a function `compare_change()` that takes in two country names and your
# `life_exp` data frame as parameters, and returns a sentence that describes
# their change in life expectancy from 2000 to 2018 (the `change` column)
# For example, if you passed the values "China", and "Bolivia" to you function,
# It would return this:
# "The country with the bigger change in life expectancy was China (gain=6.9),
#  whose life expectancy grew by 0.6 years more than Bolivia's (gain=6.3)."
# Make sure to round your numbers to one digit (though only after calculations)
# Hint: Use an if/else statement to paste the countries in the correct order
compare_change <- function(country_one, country_two, life_exp) {

  country_one_change <- round(life_exp[life_exp$country == country_one, "difference"], 1)
  country_two_change <- round(life_exp[life_exp$country == country_two, "difference"], 1)
  absolute_difference <- abs(country_two_change - country_one_change)

  if (country_one_change > country_two_change) {
    sentence <- paste0("The country with the bigger change in life expectancy
                     was", sep = " ", country_one, sep = " ", "(gain=",
                     country_one_change,"), whose life expectancy grew by",
                     sep = " ", absolute_difference, sep = " ", "years more than", sep =
                     " ", country_two, "'s (gain=", sep = " ",
                     country_two_change, ").")
  } else if (country_two_change > country_one_change) {
    sentence <- paste0("The country with the bigger change in life expectancy
                     was", sep = " ", country_two, sep = " ", "(gain=",
                       country_two,"), whose life expectancy grew by",
                     sep = " ", absolute_difference, sep = " ", "years more than", sep =
                     " ", country_one, "'s (gain=", sep = " ",
                     country_one_change, ").")
  } else if (country_one_change == country_two_change) {
    sentence <- paste0("Country One and Country Two had the same amount of
                       change", sep = " ", change, "years, in their life expectancies")
  }
  sentence
}

# Using your `bigger_change()` function, create a variable `usa_or_france`
# that describes who had a larger gain in life expectancy (the U.S. or France)
usa_or_france <- compare_change("United States.", "France")

# Write your `life_exp` data.frame to a new .csv file to your
# data/ directory with the filename `life_exp_with_change.csv`.
# Make sure not to write row names.
write.csv(life_exp, "data/life_exp_with_change.csv", row.names = F)


# script invoked from within incumbent-reelection.r

## # OJO: when using spTranform in script, use line below for google earth, or next line for OSM/google maps
#x.map <- spTransform(x.map, CRS("+proj=longlat +datum=WGS84"))
#x.map <- spTransform(x.map, osm()) # project to osm native Mercator

# to use osm backgrounds
library(rJava)
library(OpenStreetMap)

# make discrete altitude variables and colors for maps
library(arules)
tmp <- censo$wmeanalt
tmp <- discretize(tmp, method = c("interval","frequency")[1], breaks = 9) # factors
censo$wmeanaltcat <- as.numeric(tmp)
tmp <- censo$wsdalt
tmp <- discretize(tmp, method = c("interval","frequency")[2], breaks = 9) # factors
censo$wsdaltcat <- as.numeric(tmp)
tmp <- censo$meanalt
tmp <- discretize(tmp, method = c("interval","frequency")[1], breaks = 9) # factors
censo$meanaltcat <- as.numeric(tmp)
tmp <- censo$sdalt
tmp <- discretize(tmp, method = c("interval","frequency")[2], breaks = 9) # factors
censo$sdaltcat <- as.numeric(tmp)
# make colors
library(RColorBrewer)
nclr <- 9                                    #CATEGORÍAS DE COLOR (MIN=3 MAX=9)
blues <- brewer.pal(nclr,"Blues")            #GENERA CODIGOS DE COLOR QUE CRECEN CON GRADO
reds <- brewer.pal(nclr,"Reds")
yellows <- brewer.pal(nclr,"YlOrBr")
library(plyr)
censo$wmeanaltcol <- mapvalues ( censo$wmeanaltcat, from = 1:9, to = yellows )
censo$wsdaltcol   <- mapvalues ( censo$wsdaltcat, from = 1:9, to = reds )
censo$meanaltcol <- mapvalues ( censo$meanaltcat, from = 1:9, to = yellows )
censo$sdaltcol   <- mapvalues ( censo$sdaltcat, from = 1:9, to = reds )
censo$wmeanaltcat <- censo$wsdaltcat <- censo$meanaltcat <- censo$sdaltcat <- NULL

# geospatial data
library(spdep); # no longer available as of 22sep2020
library(maptools)
# used to determine what datum rojano data has
library(rgdal)
#gpclibPermit()

# state borders
md <- "/home/eric/Downloads/Desktop/data/mapas/entidad/estados2013/"
ed.map <- readOGR(dsn = md, layer = 'ESTADOS')
# projects to a different datum with long and lat
ed.map <- spTransform(ed.map, osm())

# read municipios
md <- "/home/eric/Downloads/Desktop/data/mapas/municipio/munInegi2013/"
mu.map <- readOGR(dsn = md, layer = 'MUNICIPIOS')
# projects to a different datum with long and lat
mu.map <- spTransform(mu.map, osm())
#
colnames(mu.map@data) <- c("edon","munn","mun")
mu.map$edon <- as.numeric(as.character(mu.map$edon))
mu.map$munn <- as.numeric(as.character(mu.map$munn))
mu.map$mun <-             as.character(mu.map$mun)
mu.map$ife <- mu.map$edon*1000 + mu.map$munn

## # read terrain ruggedness raster --- ATTEMPT TO READ DATA FROM RASTER USING MUN POLYGONS FAILED
## Useful resources:
## https://diegopuga.org/data/rugged/#grid
## https://luisdva.github.io/rstats/GIS-with-R/
## https://gis.stackexchange.com/questions/23212/how-to-calculate-the-average-value-of-a-raster-within-polygons
## https://gis.stackexchange.com/questions/92221/extract-raster-from-raster-using-polygon-shapefile-in-r/92227
## library(raster)
## library(rgeos)
## library(sp)
## #
## # get terrain ruggedness raster
## tmp.r <- raster("/home/eric/Dropbox/data/mapas/terrain-ruggedness/tri-clipped-mx.tif")
## proj4string(tmp.r) <- CRS("+init=epsg:3857")
## plot(tmp.r)
## plot(mu.map[mu.map$ife==1001,], add = TRUE)
## plot(mu.map[mu.map$ife==1001,])
## plot(tmp.r, add = TRUE)
## summary(mu.map)
## #
## summary(getValues(tmp.r, 50))/1000
## #
## # alternative approach
## library(stars)
## raster_extract = function(x, y, fun = NULL, na.rm = FALSE) {
##   x = as(x, "Raster")
##   y = as(y, "Spatial")
##   raster::extract(x = x, y = y, fun = fun, na.rm = na.rm)
## }
## md <- "/home/eric/Downloads/Desktop/data/mapas/municipio/munInegi2013/"
## tmp.m <- st_read(md, layer = 'MUNICIPIOS')
## plot(tmp.m)
## tmp <- read_stars("/home/eric/Dropbox/data/mapas/terrain-ruggedness/tri-clipped-mx.tif")
## #
## tmp2 <- raster_extract(tmp, tmp.m)
## tmp2[[2]]
## #
## tmp.m <-
##   tmp.m %>% mutate(
##     hfpMean = raster_extract(tmp, tmp.m), fun = mean, na.rm = TRUE),
##     hfpMax = raster_extract(tmp, tmp.m, fun = max, na.rm = TRUE),
##     hfpMin = raster_extract(tmp, tmp.m, fun = min, na.rm = TRUE)
##   )
##  tmp.m %>%
##      st_set_geometry(NULL)
## %>%
##      knitr::kable()
## #
## tmp.m <- within(tmp.m, hfpMax <- hfpMin <- hfpMean <- NULL)
## #
## raster_extract(tmp, tmp.m, fun = mean, na.rm = TRUE)
## plot(tmp)
## tmp

# merge census and altitude data
tmp1 <- mu.map@data
tmp1$ord <- 1:nrow(tmp1)
tmp2 <- censo; tmp2$inegi <- tmp2$edon <- NULL
tmp1 <- merge(x = tmp1, y = tmp2, all.x = TRUE, all.y = FALSE)
tmp1 <- tmp1[order(tmp1$ord),] # SORT AS IT WAS
mu.map@data <- tmp1 # return manipulated data

## # maybe useful
## wd2 <- c("~/Dropbox/data/elecs/MXelsCalendGovt/atlasDis/data/")
## setwd(wd2)
## load(file="elDatForMaps.RData")
## wd <- c("/home/eric/Downloads/Desktop/MXelsCalendGovt/reelec/data/")
## setwd(wd)

# shave map's bb to exclude pacific island
shave <- function(m = NA, p = .5, s = 0, eastwest = TRUE){ # m is map to be shaved, p the rightmost part (share) to keep, -1<s<1 a shift rightward, eastwest=FALSE makes shift northsouth
    #m <- ed.map$col # duplicate
    m <- m; p <- p;
    dim <- ifelse(eastwest==TRUE, 1, 2)
    b <- as.data.frame(m@bbox)
    b[dim,] <- b[dim,] - s*(b$max[dim] - b$min[dim])       # shift map rightward (bbox leftward)
    b$min[dim] <- b$max[dim] - p*(b$max[dim] - b$min[dim]) # keeps only 100*p% of horizontal length
    m@bbox <- as.matrix(b)
    #ed.map$col <- m
    return(m)
}
#
# (use 1984 long/lat for this map when mercator projection was chosen)
p84 <- function(x = NA){
    x <- x
    x <- spTransform(x, CRS("+proj=longlat +datum=WGS84"))
}
portray <- mu.map$wmeanaltcol  # elegir qué reportará el mapa
portray <- mu.map$wsdaltcol   # elegir qué reportará el mapa
portray <- mu.map$meanaltcol  # elegir qué reportará el mapa
portray <- mu.map$sdaltcol   # elegir qué reportará el mapa

setwd("/home/eric/Dropbox/data/elecs/MXelsCalendGovt/reelec/graph")
#pdf("map.pdf")
par(mar=c(0,0,2,0)) ## SETS B L U R MARGIN SIZES
#par(mar=c(2,2,2,1)) ## SETS B L U R MARGIN SIZES
plot(shave(p84(ed.map),  p = .93), col = "white", axes = TRUE, main = "sd(Altitud municipal)", bg = "lightblue")
#library(scales) # has function alpha()
#plot(p84(mu.map), add = TRUE, border = NULL, col = alpha(portray, .25)) # color nwin
plot(p84(mu.map), add = TRUE, border = portray, col = portray) # color nwin
# thick state border
plot(p84(ed.map), add = TRUE, lwd = 1)
#plot(p84(ed.map), add = TRUE, border = "red", lty = 3, lwd = 1.5)
#
# add neighboring states
## text( x = -117, y = 29.5, labels = "O C E A N O   P A C I F I C O", cex = .9, col = "deepskyblue", srt = -60 )
## text( x = -113.2, y = 30, labels = "M A R   D E   C O R T E Z", cex = .9, col = "deepskyblue", srt = -55 )
## text( x = -113.4, y = 27.9, labels = "B.C.S.", col = "darkgray", cex = .9 )
## text( x = -113.5, y = 31.8, labels = "SONORA", col = "darkgray", cex = .9, srt = -20 )
## text( x = -116, y = 32.75, labels = "EE.UU.", col = "darkgray", cex = .9, srt = 6 )
#dev.off()


##
## Plot descriptive stats
##
library(futile.logger)
library(xlsx)
library(tidyverse)
source("init if necessary.r")

flog.info("Plotting descriptive stats")

############################################################################################
## Gifts split by whether or not they were given to members of the same herding group:
##
dyads.subset %>%
  filter(GiftGiven==1) %>%

  ggplot(aes(x=factor(SameHerdingGroup))) +
    geom_histogram(stat="count") +

    scale_x_discrete(labels=c("0" = "No", "1" = "Yes")) +
    xlab("Member of same herding group?") +
    ylab("Number of gifts") +

    facet_wrap(~PopName) +
    common_theme

ggsave(filename=file.path(plots.dir, "gifts by herding group membership.png"), width=150, height=150, units="mm")
ggsave(filename=file.path(plots.dir, "gifts by herding group membership.pdf"), width=150, height=150, units="mm")

############################################################################################
## Ranges of gifts by site
##
people %>%
  group_by(PopName) %>%
  summarise(
    # summarise number of gifts received
    n.mean = mean(gift.deg.in), n.median = median(gift.deg.in),
    n.min  = min(gift.deg.in),  n.max = max(gift.deg.in),
    # summarise amounts received
    amount.mean = mean(gifts.total), amount.median = median(gifts.total),
    amount.min  = min(gifts.total),  amount.max = max(gifts.total)) %>%
  write_csv(path=file.path(results.dir, "gifts summary.csv"))

############################################################################################
## Kin and non-kin in the same herding group and other groups:
##
dyads.r = dyads.subset %>%
  mutate(r.bin = cut(r, c(0, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5, 1), right=F))

dyads.r$SameHerdingGroupText = factor(dyads.r$SameHerdingGroup)
levels(dyads.r$SameHerdingGroupText) = c("No", "Yes")

ggplot(dyads.r, aes(x=r.bin)) +
  geom_histogram(aes(fill=SameHerdingGroupText), position="dodge", stat="count", alpha=0.75) +

  scale_y_log10(breaks=c(1, 10, 100, 1000, 10000)) +

  scale_fill_manual(values = cols) +
  xlab("Coefficient of relatedness") +
  ylab("Frequency") +

  guides(fill= guide_legend("Same herding group?")) +
  facet_wrap(~PopName, scales="free_y") +

  common_theme +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1)  # rotate x-axis labels
   ,legend.position="bottom"
  )

ggsave(filename=file.path(plots.dir, "relatedness to herding group.png"), width=250, height=150, units="mm")
ggsave(filename=file.path(plots.dir, "relatedness to herding group.pdf"), width=250, height=150, units="mm")

rm(dyads.r)

############################################################################################
## Proportion of gifts going to a close relative (r>=0.5), any other relative, non-kin, split by population
##
# divide into relatedness categories
dyads.gifts = dyads.subset %>%
  filter(GiftGiven == 1) %>%
  mutate(r.desc = factor( case_when(
    .$r >= 0.5              ~ "Immediate family",
    .$r >= 0.25 & .$r < 0.5 ~ "Other close kin",
    .$r > 0 & .$r < 0.25    ~ "Distant kin",
    .$r == 0                ~ "Non-kin"
  ), levels=c("Non-kin", "Distant kin", "Other close kin", "Immediate family"))) %>%

  # calculate proportions of gifts given to different classes of kin
  group_by(PopName, r.desc) %>%
  summarise(n = n()) %>%
  mutate(Prop = n / sum(n))

ggplot(dyads.gifts, aes(x=r.desc, y=Prop)) +
  geom_bar(stat="identity") +

  xlab("") +
  ylab("Proportion of gifts") +
  facet_wrap(~PopName) +

  common_theme +
  theme( axis.text.x = element_text(angle = 45, hjust = 1) )  # rotate x-axis labels

ggsave(filename=file.path(plots.dir, "gifts by relatedness.png"), width=150, height=150, units="mm")
ggsave(filename=file.path(plots.dir, "gifts by relatedness.pdf"), width=150, height=150, units="mm")

rm(dyads.gifts)

############################################################################################
## Distribution of herd sizes for everyone in the sample
##
# get median herd sizes in each site and draw on graph
median.cattle = people %>%
  group_by(PopName) %>%
  summarise(Median.cattle = median(HerdSize, na.rm=T))

ggplot(people, aes(x=HerdSize)) +
  geom_histogram(binwidth = 50, alpha=0.5) +
  geom_vline(aes(xintercept = Median.cattle), median.cattle) +

  xlab("Number of livestock") +
  ylab("Frequency") +

  facet_wrap(~PopName, scales = "free") +
  common_theme

ggsave(filename=file.path(plots.dir, "distribution of herd sizes.png"), width=200, height=150, units="mm")
ggsave(filename=file.path(plots.dir, "distribution of herd sizes.pdf"), width=200, height=150, units="mm")

rm(median.cattle)

############################################################################################
## summary stats table
##
# calculate each person's relatedness to their herding group (in each site)
group.r = dyads %>%
  filter(SameHerdingGroup == 1) %>%        # only want within-group dyads
  unite(Pop.HG, PopName, Ego.HG) %>%       # group IDs might be repeated across sites, so make a unique identifier
  select(DyadID, Pop.HG, r) %>%            # keep only necessary variables...
  distinct() %>%                           #... and remove repeated dyads (essentially making an undirected network)
  group_by(Pop.HG) %>%                     # summary stats for each site/herding group
  summarise(r.mean   = mean(r, na.rm=T),
            r.median = median(r, na.rm=T),
            r.sd     = sd(r, na.rm=T),
            r.se     = sd(r) / sqrt(length(r)),
            N.dyads  = length(r))
# separate(Pop.HG, c("PopName", "HG"), sep="_")  # split the Pop.HG unique identified (step 2) back into its separate components

# how many people in each herding group (that we interviewed)?
group.n = people %>%
  unite(Pop.HG, PopName, HG) %>%
  group_by(Pop.HG) %>%
  summarise(N = n())

# merge group sizes into group relatedness table
group.r = group.r %>%
  full_join(group.n, by="Pop.HG") %>%                 # use full_join because there are some groups in group.n who we don't have relatedness info for (because there are no within-group dyads)
  separate(Pop.HG, c("PopName", "HG"), sep="_") %>%   # split the Pop.HG unique identified back into its separate components
  arrange(PopName, N)  # order by number of members

# grand mean of relatedness within each site (and some other summary stats)
group.r.sum = group.r %>%
  group_by(PopName) %>%
  summarise(n.groups = n(),
            mean.N = mean(N, na.rm=T),
            sd.N = sd(N, na.rm=T),
            grand.mean.r = mean(r.mean, na.rm=T))

# save this summary
write.csv(group.r.sum, file=file.path(results.dir, "herding groups summary.csv"), row.names=F)

# summarise total N
sample.summary = dyads %>%
  group_by(PopName) %>%
  summarise(n = length(unique(Ego.ID)))

# summarise people who played gift games
gifts.summary = dyads %>%
  group_by(PopName) %>%
  filter(GiftGiven==1) %>%
  summarise(n.givers = length(unique(Ego.ID)), n.gifts = sum(GiftGiven))

# summarise ages and genders
age.summary = people %>%
  select(HerderID, PopName, Age) %>%
  na.omit %>%
  group_by(PopName) %>%
  summarise(age.mean = mean(Age),
            age.sd   = sd(Age))

sex.summary = people %>%
  select(HerderID, PopName, Sex) %>%
  na.omit %>%
  count(PopName, Sex) %>%
  spread(Sex, n, fill=0)

# summarise herd sizes
herds.summary = people %>%
  select(HerderID, PopName, HerdSize, cattle.z, Age.z, Sexb, gift.deg.in, gift.betweenness, gift.eigen) %>%
  na.omit %>%
  group_by(PopName) %>%
  summarise(herd.mean = mean(HerdSize),
            herd.sd = sd(HerdSize))

# merge in gifts and herding groups summaries
sample.summary = sample.summary %>%
  left_join(gifts.summary, by="PopName") %>%
  left_join(age.summary,   by="PopName") %>%
  left_join(sex.summary,   by="PopName") %>%
  left_join(group.r.sum,   by="PopName") %>%
  left_join(herds.summary, by="PopName")

# calculate totals
sample.totals = sample.summary %>%
  summarise(PopName="Totals", n=sum(n), n.givers=sum(n.givers), n.gifts=sum(n.gifts),
            age.mean=99, age.sd=99, f=sum(f), m=sum(m), o=sum(o),
            n.groups=sum(n.groups), mean.N=-99, sd.N=-99, grand.mean.r=-99, herd.mean=-99, herd.sd=-99)  # treat this as missing -- don't want to total the averages -- but NA doesn't work properly when opening in Excel

# save summary
wb = createWorkbook()
sheet_sample = createSheet(wb, "sample descriptives")
addDataFrame( as.data.frame(bind_rows(sample.summary, sample.totals)), sheet=sheet_sample, row.names=F)
saveWorkbook(wb, file.path(results.dir, "Sample summaries.xlsx"))


## * Utilities
upper1st <- function(x) {
    if (is.factor(x))
        x0 <- levels(x) else x0 <- as.character(x)
    nc <- nchar(x0)
    x0[nc > 1] <- sprintf('%s%s', toupper(substr(x0[nc > 1], 1, 1)), substr(x0[nc > 1], 2, nchar(x0[nc > 1])))
    x0[nc == 1] <- toupper(x0[nc == 1])
    if (is.factor(x))
        levels(x) <- x0 else x <- x0
    return(x)
}

## * Statistical
estBetaParams <- function(mu, var) {
    ## Estimate alpha and beta of beta distribution from mean and variance
    ## from http://stats.stackexchange.com/questions/12232/calculating-the-parameters-of-a-beta-distribution-using-the-mean-and-variance
    alpha <- ((1 - mu) / var - 1 / mu) * mu ^ 2
    beta <- alpha * (1 / mu - 1)
    return(params = list(alpha = alpha, beta = beta))
}

## * For PST
## formula from Neil & Lebreton 2008
funNL<- function(x,a,s) (exp((a+s/(x-s))^-1)-x)^2
lmax_nl <- function(a,s) return(optimise(funNL, c(1,2), a=a, s=s, tol=1e-10)$minimum)
Lmax_nl <- function(a,s,usemc=F) {
    if (usemc) {
        library(parallel)
        return(mcmapply(lmax_nl, a, s))
    } else return(mapply(lmax_nl, a, s))
}
Rmax_NL <- function(s,a,...) return(Lmax_nl(a,s,...)-1)


# This file includes a demonstration of how to use the method "svl" to identify the source
# vent location of tephra fall deposits based on thickness or maximum clast size
# measurements.
# Author: Qingyuan Yang, Marcus Bursik, and E. Bruce Pitman.
# GPL: License. Use at your own risk.
###
# The work was supported by National Science Foundation Hazard SEES grant number 1521855
# to G. Valentine, M. Bursik, E.B. Pitman and A.K. Patra, and National Science Foundation
# DMS grant number 1621853 to A.K. Patra, M. Bursik, and E.B. Pitman.
# We appreciate your comments, suggestions, and feedback.
# Please feel free to contact us through vhub or email: qyang5@buffalo.edu
########################################## Demonstration ################################
# In this demonstration, we use a thickness dataset of the North Mono Bed 2
# (Sieh and Bursik, 1986) as an example. North Mono Bed 2 was erupted from Upper Dome, which is a
# part of the Mono-Inyo Craters (eastern central California).
# It is noted that the method can also be applied to maximum clast size measurements.

# Set working directory.
setwd("/the/directory/where/you/put/your/data/")

#---

# The input dataset should have three columns:
#	The first two columns are the coordinates (x or E and y or N) of sample sites in the UTM system.
#	The third column should include the corresponding thickness or maximum clast size
#	measurements in millimeters, with a minimum value of 1 mm.
# The input dataset should be a ".csv" file, and separated by ",".
# The head or column names of the three columns should be "x", "y", and "zr".
# In the case of  North Mono Bed 2, the x and y coordinates are in UTM Zone 11.
# Read dataset from the working directory.
td = read.table("nmb2.csv", header=TRUE, sep = ",")

#---

# Check data structure (optional command).
str(td)
# Return:
	#'data.frame':      114 obs. of  3 variables:
	#$ x : num  320364 328807 327410 329283 327802 ...
	#$ y : num  4194955 4192135 4193500 4194283 4194929 ...
	#$ zr: num  0 0 0 0 0 0 0 0 0 0 ...
# NOTE: if the data include observations of zero thickness; it is necessary to exclude them for the
#	method to work (optional command).
#
#
#---

# Exclude zero-thickness observations.
td = subset(td, zr!=0)

#---

# Check data structure in a different way (optional command).
# Command below shows the first six rows of the dataset.
head(td)
# Return:
	#          x       y zr
	#12 326341.2 4199522 22
	#15 327685.3 4203216 10
	#26 320851.0 4197091 38
	#27 321276.5 4197466 82
	#28 320946.3 4197606 96
	#29 321606.7 4197460 78
# Note: the 1st column with # is just sample numbers; these are not
# part of the dataset. The data are not in order (1, 2, 3,...)
# because zero-thickness observations have been excluded.

#---

# Define the initial guess of source vent location.
# These coordinates should be within the area where the vent is likely
# to be.
# We recommend users to try different coordinates within that area to
# run the method,
# and then check if the results converge to the same point.
sv_assumed = cbind(x = 322227, y = 4181034)
# In the example case, assuming that we known the vent is from the Mono-Inyo Craters,
# the values of the initial guess are the coordinates of Obsidian Dome, which is > 14 km
# south of Upper Dome, the true vent location of North Mono Bed 2.

#---

# Source functions of the method "svl".
# Note: the semi-empirical model proposed by Yang and Bursik (2016)
# is used here.
source("/where/you/put/your/source/code/pub_svl_2.0_exponential.r")

#---

# Run the method "svl".

# Brief description of the method:
#	Starting with an initial guess, "sv_assumed", on vent location, the
#	value is updated in each iteration (loop).
# Start loop:								 <----------------|
#	The method proposes different possible vent locations around "sv_assumed"   	  |
#	that are at a certain distance (distance: h = 1000 m in this case) from it,       |
#	and compares if they are closer or farther to the true vent compared 		  |
#	with "sv_assumed".								  |
#          										  |
#	If "sv_assumed" is closer to the true vent:                                       |
#		we shrink the search radius (controlled by r * h, 0.7 * 1000 = 700 here)  |
#		to improve the resolution,						  |
#		and do the same thing with the smaller search radius; --------------->----/
#	If one of the nearby points is closer to the true vent:				  |
#		the guess on vent location, "sv_assumed", 				  |
#		is updated/replaced (see function "compare" for more details),		  |
#		and with the same search radius, the method does			  |
#		the same thing with the new guess on vent location.------------------>----/
#
#	In the actual implementation of the method, the search radius is updated
#	in a slightly more efficient manner (see detailed description in our work, whose
#	link will be provided soon).
#	This does not affect the notation in this file.
#
#	As described above, after each iteration,
#	the search radius gets either smaller or unchanged.
#	When the search radius is sufficiently small, the vent is found.
# End loop.

#	The number of iterations is controlled by "runs".
#---
#       How to assign values to the input parameters:
#	sv = sv_assumed, the initial guess on the source vent location;
#	td: the input dataset;
#	runs: the number of iterations;
#	h: the initial search radius (in meters);
#	r: the shrink ratio in the search radius.
#		Suggested value: 0.7
#	nlps, h_ratio: these are related to estimating the wind direction in each
#		iteration. It is sufficient to keep them fixed as 20 and 1, respectively.
#	numb: the number of rows of data points within "td" that will be used as input.
#	      To use the complete dataset, set it to "1:nrow(td)".
#---
#***	Values of "runs" and "h" need to be selected with care. ***
#	Here we use the example of the North Mono Bed 2 to show how the values are determined.
#
# 	Assuming that we know the tephra was erupted from the Mono-Inyo Craters,
#	which cover a range of >15 km in the y direction, and about 5 km in the x-direction.
#
#	By specifying the initial search radius to be 1000 m (h = 1000), we ensure that it takes at most
#	~15 steps/iterations before the method shrinks the search radius.
#	By the time it shrinks the search radius, it can be assumed approximately that the true vent
#	is within ~1500 m of the current point.
#
# 	Consider the worst-case scenario, namely the search radius keeps shrinking.  This means that
#	the searching resolution is improving in each iteration at the lowest rate.
#	In this case, the initial search radius keeps shrinking at a rate of 0.7 (r = 0.7).
#	For the resolution to be at ~10 m scale, the method requires 13 more iterations: 1000*(0.7)^13 = 9.61.
# 	Based on this, it is ensured that runs = 40 (greater than 15+13)
#	iterations are sufficient.
#
# 	Based on the argument above, we recommend users to follow this strategy to assign values of
#	"h" and "runs":
#	h = (the maximum height or width of the region of interest)/10
#	For "runs", if we want to reach the solution at a ~10 m scale, then
#	we need to find out the value "x" in the brackets of the function: h*0.7^(x) = ~10.
#	And then set "runs = 10 + x + E", where E could be an integer ranging from 5 to 20, a fudge-factor.
#	Greater value in E means more additional iterations,
#	which is likely to yield a more accurate estimate.
result_linear = gd_simplified(sv = sv_assumed, td, runs = 40, h = 1000, r = 0.7, nlps = 20, h_ratio = 1, numb = 1:nrow(td))

# Check the output.
result_linear
# Return:
      #       x       y output_ang          h (Intercept)          dist            dd      ssr   rsquare
      #322224.4 4197601   172.3507 0.06281024    2.231973 -0.0003055393 -0.0002597007 2.877154 0.9419849

# Interpretation:
#	x and y: 	estimated vent coordinates of the North Mono Bed 2. This location is within the extent of
# 			its true source, Upper Dome.
#	output_ang: 	estimated wind direction (from north clockwise). In this case, it is the UPWIND direction.
#			See note below on how to tell if the estimated wind direction
#			is downwind or upwind.
#	h:		the length of the search radius (m) from the last iteration. If this value is small
#			enough (e.g., <10), then the method converged.
#			If this value is comparable to the initial search radius (say 490 = 1000*0.7*0.7),
#			then users should try to increase the number of iterations,
#			namely increase the value "runs" (e.g., set it to be 60),
#			and run the method again.
#				If the method is run with more iterations,
#				but the resultant "h" is still comparable
#				to the initial search radius, that means the method fails
#				to converge.
#				Then users should try to change the initial
#				guess on vent location (sv_assumed), and run the method.
#	(intercept):	fitted coefficients for the semi-empirical model.
#	dist:		same as above.
#	dd:		same as above.
#	ssr:		sum of squared residuals from the fitting given estimated vent location and
#			wind direction.
#	rsquare:	r-squared value for the final estimate given estimated vent location and wind direction.
#
# Given sparse data, it is important to check if the fitted coefficients are physical.
# For the exponential model, this can be done by checking if dist+dd<0. If their sum dist+dd > 0 or dist > 0, this means that
# along the dispersal direction, the thickness or maximum clast size increases with distance, which is generally unphysical.

#------------------------------------------
# Use the semi-empirical (power-law) model proposed by Gonzalez-Mellado and De la Cruz-Reyna (2010).
# Source the functions of the method "svl".
source("/where/you/put/your/source/code/pub_svl_2.0_power-law.r")

#---

# Run the method "svl" with identical inputs.
result_power = gd_simplified(sv = sv_assumed, td, runs = 40, h = 1000, r = 0.7, nlps = 20, h_ratio = 1, numb = 1:nrow(td))
# Check the result.
result_power
# Return:
# 	x              y output_ang         h (Intercept)           dif  log(dist)      ssr   rsquare
# 	322859.7 4198078   337.9795 0.5338782    5.194675 -0.0001700573 -0.4008759 2.084604 0.9579659

# Interpretation:
# 	See lines 166-190.
#	The estimated vent location is within the area of Upper Dome, the true vent of
#	this tephra deposit.
#	### the output_ang in this case is the DOWNwind direction.
#	See note below on how to tell if the estimated wind direction is downwind or upwind.
# 	If log(dist) > 0 or (Intercept) < 0, then unphysical prediction occurs.

######

#---

# Note on how to tell if the estimated wind direction (output_ang) is downwind or upwind:
# Due to the design of "svl", the output "output_ang" could be either the upwind or downwind direction.
# This is related to the gradient descent method adopted in "svl".
# To tell if it is upwind or downwind,
# users need to examine the relationship between the fitted coefficients:

	# If "svl" is combined with the exponential method of Yang and Bursik (2016):
	#	if dd < 0, then "output_ang" is the upwind direction;
	#	if dd > 0, then "output_ang" is the downwind direction.

	# If "svl" is combined with the power-law method of Gonzalez-Mellado and De la Cruz-Reyna (2010):
	#	if dif < 0, then "output_ang" is the downwind direction;
	#	if dif > 0, then "output_ang" is the upwind direction.

# References:
#	Gonzalez-Mellado, A. O., and S. De la Cruz-Reyna. "A simple semi-empirical approach to model thickness of
# ash-deposits for different #eruption scenarios." Natural Hazards and Earth System Sciences 10.11 (2010): 2241.
# 	Sieh K, Bursik M. Most recent eruption of the Mono Craters, eastern central California. Journal of Geophysical
# Research: Solid Earth, 1986, 91(B12): 12539-12571.
# 	Yang Q, Bursik M. A new interpolation method to model thickness, isopachs, extent, and volume of tephra fall
# deposits. Bulletin of Volcanology, 2016, 78(10): 68.


#' Calculate the proportion of observations that lie within a given bandwidth
#'
#' Facilitates a \code{knn}-type bandwidth by calculating the proportion \eqn{sum(w) / n}. Called repeatedly by \code{optimize} in \code{lagr.dispatch} to home in on the desired \code{knn}.
#'
#' @param bw bandwidth for which to compute \code{sum(w)}
#' @param loc location around which to center the kernel
#' @param coords matrix of observation locations
#' @param dist vector of distances from central location to the observation locations
#' @param kernel kernel function for generating the local observation weights
#' @param target targeted \code{knn} bandwidth
#' @param prior.weights vector of prior observation weights provided by the user
#' @param total.weight sum of prior weights
#' @param verbose print detailed information about our progress?
#'
#' @return difference between the calculated \code{sum(w) / total.weight} and the target
#'
lagr.knn = function(bw, loc, coords, dist, kernel, target, prior.weights, total.weight, verbose) {
    kernel.weights = kernel(dist, bw)
    w = kernel.weights * prior.weights
    prop = sum(w)/total.weight

    #return the difference between the calculated sum(w) and the target
    return(abs(prop-target))
}


# Use data from EveryCen-boxplot.pl and process taking the ratio of ChIP/ Input
## Rscript plot_median.r sample1 sample2 output

args <- commandArgs(trailingOnly = TRUE)

# Load data
sample1 <- read.table(args[1])
sample2 <- read.table(args[2])

library(dplyr)

#calculate the median per region
sample1_median <- as.data.frame(sample1) %>% summarise_each(funs(median(., na.rm=TRUE) ))
sample2_median <- as.data.frame(sample2) %>% summarise_each(funs(median(., na.rm=TRUE) ))

# windows are 100bp, + - 25000bp from the centre of the centromere
Coords <- (1:499 * 100) -25000

#Plot
pdf(paste(args[3], ".pdf", sep=""), width=15)
plot(Coords, log2(sample1_median), pch='.', col="red",
	     xlab="Position", ylab="log2 of median ratio of reads: ChIP/Input")
lines (Coords, log2(sample1_median), pch='.', col="red", lw=3)
lines (Coords, log2(sample2_median), pch='.', col="darkblue", lw=3)


#  James Rekow

fracturedAbdListCreator = function(M = 40, numSubgroups = 1, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                                  thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                  intTime = 1, interSmplMult = 0.01, lambda = 0, returnParams = FALSE,
                                  conGraph = NULL){

  #  ARGS: numSubgroups - the number of subgroups into which the cohort will be divided. If this value
  #                       is greater than one then each subgroup is created as a separate cohort before
  #                       being combined and interacted as a single cohort
  #
  #  RETURNs: abdList - list of integrated and interacted (if lambda > 0) abundances

  source("cohortCreator.r")
  source("intraCohortInteraction.r")
  source("partition.r")
  source("eulerIntegrate.r")

  #  used to determine if the system is near equilibrium
  threshold = {thresholdMult * tStep} ^ 2

  #  define integrator function to apply eulerIntegrate with desired parameter vals
  integrator = function(smpl){
    return(eulerIntegrate(smpl, threshold = threshold, maxSteps = maxSteps, tStep = tStep))
  } #  end integrator function

  #  create vector with the number of samples in each subgroup
  subgroupSizeVec = partition(n = M, numPartitions = numSubgroups)

  createSubgroup = function(subgroupSize){

    #  ARGS: subgroupSize - number of samples in subgroup
    #
    #  RETURNS: subgroup - a subgroup with subgroupSize samples. This is just an un-integrated cohort with
    #                      the given number of samples

    #  construct subgroup
    subgroup = cohortCreator(M = subgroupSize, N = N, iStrength = iStrength, univ = univ,
                             sigmaMax = sigmaMax)

    return(subgroup)

  } #  end createSubgroup function

  #  create subgroups
  subgroupList = lapply(as.list(subgroupSizeVec), createSubgroup)

  #  combine subgroups into a single cohort
  chrt = unlist(subgroupList, recursive = FALSE)

  #  integrate samples in the cohort
  abdList = lapply(chrt, integrator)

  #  simulate intra-cohort interaction if lambda > 0
  if(lambda > 0){

    #  update the abundances of each sample in the cohort
    for(i in 1:M){
      chrt[[i]][[1]] = abdList[[i]]
    } #  end for

    #  simulate intra-cohort interactions
    abdList = intraCohortInteraction(chrt, M = M, N = N, lambda = lambda, threshold = threshold,
                                     maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                     interSmplMult= interSmplMult, conGraph = conGraph)

  } #  end if

  return(abdList)

} #  end fracturedAbdListCreator function