##
## Analyse the best-fitting GEE models (averaged)
##
library(ggplot2)
library(gridExtra)
library(aod)
library(data.table)
library(dplyr)
library(xlsx)
library(geepack)

source("init.r")

# either load GEE models or fit them from scratch
gee.path = file.path(models.dir, "gees.RData")
if (file.exists(gee.path)) {
  load(gee.path)
} else {
  source("fit gee models.r")
}

############################################################################
## Save best models table
##
best.models.df = as.data.frame(best.models)
best.models.df$Model = row.names(best.models.df)
row.names(best.models.df) = NULL

best.models.df$Model = gsub("^gee.null$", "Intercept-only", best.models.df$Model)
best.models.df$Model = gsub("^gee.control$", "Control model (Distance + HH size + Relative wealth)", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin$", "Relatedness", best.models.df$Model)
best.models.df$Model = gsub("^gee.ra$", "Reciprocated help", best.models.df$Model)
best.models.df$Model = gsub("^gee.gift$", "Gifts", best.models.df$Model)
best.models.df$Model = gsub("^gee.need_afb$", "Relative need", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_ra$", "Relatedness + Reciprocity", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_gift$", "Relatedness + Gifts", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_need$", "Relatedness + Relative need", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_ra_need$", "Relatedness + Reciprocity + Relative need", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_need_gift$", "Relatedness + Relative need + Gifts", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_ra_need_gift$", "Relatedness + Reciprocity + Relative need + Gifts", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_ra_need_gift_int$", "Relatedness × Relative need + Reciprocity + Gifts", best.models.df$Model)
best.models.df$Model = gsub("^gee.kin_ra_need_gift_int_2$", "Relatedness × Relative need + Relatedness × Reciprocity + Gifts", best.models.df$Model)

best.models.df$qLik = round(best.models.df$qLik, 3)
best.models.df$delta = round(best.models.df$delta, 3)
best.models.df$weight = round(best.models.df$weight, 3)

write.csv(subset(best.models.df, select=c(Model, qLik, delta, weight)),
          file.path(results.dir, "best gee models.csv"), row.names=F)

############################################################################
## Plot odds ratios from best-fitting GEE model(s)
##
# put ORs and CIs in a data frame
gee.or = cbind( data.frame(Estimate = exp(coef(gee.best.z, full=T))), exp(confint(gee.best.z, full=T, digits=3)) )
names(gee.or) = c("Estimate", "lwr", "upr")

setDT(gee.or, keep.rownames = TRUE)[]  # convert row names to first column

# put ORs into a more sensible order (list is reverse because of coordinate flip in ggplot)
rn_order = rev(c("(Intercept)", "z.r", "z.r:z.HelpReceived", "z.Distance:z.r", "z.r:z.ChildrenInAlter", "z.r:z.Ego.Need.AFB", "z.r:z.Alter.Need.AFB",
                 "z.HelpReceived", "z.GiftGiven.ind", "z.Ego.Need.AFB", "z.Alter.Need.AFB",
                 "z.ChildrenInAlter", "z.AnyWivesInAlter", "z.AnyHusbandsInAlter",
                 "z.Distance", "z.RelativeWealthRank", "z.Ego.Size", "z.Alter.Size",
                 "Ego.VillageID2", "Ego.VillageID5", "Ego.VillageID6", "Ego.VillageID8"))
gee.or$rn = factor(gee.or$rn, levels=rn_order)

levels(gee.or$rn)[ levels(gee.or$rn)=="z.Distance" ] = "Distance (km)"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.RelativeWealthRank" ] = "Relative wealth rank"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.Ego.Size" ] = "Size of helper household (ego)"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.Alter.Size" ] = "Size of landowner household (alter)"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.r" ] = "Relatedness (r)"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.AnyWivesInAlter" ] = "Any wives in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.AnyHusbandsInAlter" ] = "Any husbands in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.ChildrenInAlter" ] = "Any children in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.HelpReceived" ] = "Help reciprocated?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.Ego.Need.AFB" ] = "Helper household's need"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.Alter.Need.AFB" ] = "Landowner household's need"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.GiftGiven.ind" ] = "Gift given from ego to alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.Distance:z.r" ] = "r × Distance"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.r:z.ChildrenInAlter" ] = "r × Any children in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.r:z.Ego.Need.AFB" ] = "r × Helper household's need?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.r:z.Alter.Need.AFB" ] = "r × Landowner household's need?"
levels(gee.or$rn)[ levels(gee.or$rn)=="z.r:z.HelpReceived" ] = "r × Help reciprocated?"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID2" ] = "Village B"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID5" ] = "Village C"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID6" ] = "Village D"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID8" ] = "Village E"

gee.or$text = paste0("(OR = ", round(gee.or$Estimate, 3), "; 95% CI [", round(gee.or$lwr, 3), ", ", round(gee.or$upr, 3), "])")

##
## save odds ratio and candidate models tables
##
write.xlsx(gee.or, file=file.path(results.dir, "GEE tables.xlsx"), sheetName="Odds ratios", row.names=F)
write.xlsx(subset(best.models.df, select=c(Model, qLik, delta, weight)), file=file.path(results.dir, "GEE tables.xlsx"), append=T, sheetName="Best models", row.names=F)

##
## plot odds ratios
##
ggplot(subset(gee.or, rn != "(Intercept)"),
       aes(x=rn, y=Estimate)) +
  geom_hline(yintercept=1, colour = "grey80", linetype=2) +
  geom_point(size=2) +
  geom_errorbar(aes(ymax=upr, ymin=lwr), width=.2, size=.3) +

  xlab("") +
  ylab("Odds ratio") +  # because of flipped plot

  scale_y_log10(breaks=c(0.01, 0.1, 1, 10), limits=c(0.1, 10)) +
  coord_flip() +
  #facet_grid(.~Year) +

  theme_bw() +
  #eliminates baground, gridlines, and chart border
  theme(
    plot.background = element_blank()
    ,panel.grid.major = element_blank()
    ,panel.grid.minor = element_blank()
    #,panel.border = element_blank()
    ,panel.background = element_blank()
  ) +
  theme(axis.line = element_line(color = 'black')) +
  # hide legend
  theme(legend.position="none")

ggsave(filename=file.path(plots.dir, "fig 3 - odds ratios.png"), width=175, height=100, units="mm")
ggsave(filename=file.path(plots.dir, "fig 3 - odds ratios.pdf"), width=175, height=100, units="mm")

##
## what's the intercept?
##
intercept = gee.or[1,]
paste0("OR = ", round(intercept$Estimate, 3), " [", round(intercept$lwr, 3), ", ", round(intercept$upr, 3), "]")

############################################################################
## Unstandardised odds ratios (reported in Results text)
##
gee.logodds = data.frame(Estimate = coef(gee.best, full=T), confint(gee.best, full=T, digits=3))

# we want to know the increased odds of helping when r=0.5 compared to r=0, rather than the default interpretation, which is when r=1 compared to r=0
# therefore, half the log-odds for relatedness
gee.logodds[row.names(gee.logodds) == "r",] = gee.logodds[row.names(gee.logodds) == "r",] / 2

# put ORs and CIs in a data frame
gee.or = exp(gee.logodds)
gee.or = gee.logodds
names(gee.or) = c("Estimate", "lwr", "upr")

setDT(gee.or, keep.rownames = TRUE)[]  # convert row names to first column

# put ORs into a more sensible order (list is reverse because of coordinate flip in ggplot)
rn_order = rev(c("(Intercept)", "r", "r:HelpReceived", "Distance:r", "r:ChildrenInAlter", "r:Ego.Need.AFB", "r:Alter.Need.AFB",
                 "HelpReceived", "GiftGiven.ind", "Ego.Need.AFB", "Alter.Need.AFB",
                 "ChildrenInAlter", "AnyWivesInAlter", "AnyHusbandsInAlter",
                 "Distance", "RelativeWealthRank", "Ego.Size", "Alter.Size",
                 "Ego.VillageID2", "Ego.VillageID5", "Ego.VillageID6", "Ego.VillageID8"))
gee.or$rn = factor(gee.or$rn, levels=rn_order)

levels(gee.or$rn)[ levels(gee.or$rn)=="Distance" ] = "Distance (km)"
levels(gee.or$rn)[ levels(gee.or$rn)=="RelativeWealthRank" ] = "Relative wealth rank"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.Size" ] = "Size of helper household (ego)"
levels(gee.or$rn)[ levels(gee.or$rn)=="Alter.Size" ] = "Size of landowner household (alter)"
levels(gee.or$rn)[ levels(gee.or$rn)=="r" ] = "Relatedness (r)"
levels(gee.or$rn)[ levels(gee.or$rn)=="AnyWivesInAlter" ] = "Any wives in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="AnyHusbandsInAlter" ] = "Any husbands in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="ChildrenInAlter" ] = "Any children in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="HelpReceived" ] = "Help reciprocated?"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.Need.AFB" ] = "Helper household's need"
levels(gee.or$rn)[ levels(gee.or$rn)=="Alter.Need.AFB" ] = "Landowner household's need"
levels(gee.or$rn)[ levels(gee.or$rn)=="GiftGiven.ind" ] = "Gift given from ego to alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="Distance:r" ] = "r × Distance"
levels(gee.or$rn)[ levels(gee.or$rn)=="r:ChildrenInAlter" ] = "r × Any children in alter?"
levels(gee.or$rn)[ levels(gee.or$rn)=="r:Ego.Need.AFB" ] = "r × Helper household's need?"
levels(gee.or$rn)[ levels(gee.or$rn)=="r:Alter.Need.AFB" ] = "r × Landowner household's need?"
levels(gee.or$rn)[ levels(gee.or$rn)=="r:HelpReceived" ] = "r × Help reciprocated?"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID2" ] = "Village B"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID5" ] = "Village C"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID6" ] = "Village D"
levels(gee.or$rn)[ levels(gee.or$rn)=="Ego.VillageID8" ] = "Village E"

gee.or$text = paste0("(log odds = ", round(gee.or$Estimate, 3), "; 95% CI [", round(gee.or$lwr, 3), ", ", round(gee.or$upr, 3), "])")

##
## save odds ratio and candidate models tables
##
write.xlsx(gee.or, file=file.path(results.dir, "GEE tables.xlsx"), sheetName="Odds ratios", row.names=F)
write.xlsx(subset(best.models.df, select=c(Model, qLik, delta, weight)), file=file.path(results.dir, "GEE tables.xlsx"), append=T, sheetName="Best models", row.names=F)

############################################################################
## Function to calculate 95% CIs for GEE models
## adapted from: https://danieljhocking.wordpress.com/2012/07/25/plotting-95-confidence-bands-in-r/
##
m.terms = terms(gee.kin_ra_need_gift_int_2)

predict_gee = function(m, m.terms, new.data)
{
  mm.geeEX = model.matrix(m.terms, new.data)  # use the full model to create the design matrix, since can't run terms() on an averaged model
  new.data$HelpObserved = mm.geeEX %*% coef(m)

  tvar1.gee = diag(mm.geeEX %*% tcrossprod(aod::vcov(m), mm.geeEX))

  new.data = data.frame(
    new.data
    , tlo = new.data$HelpObserved - 2*sqrt(tvar1.gee)
    , thi = new.data$HelpObserved + 2*sqrt(tvar1.gee)
  )

  # keep log odds
  # new.data$HelpObserved_logodds = new.data$HelpObserved
  # new.data$tlo_logodds = new.data$tlo
  # new.data$thi_logodds = new.data$thi

  # transform log odds to probabilities
  new.data$HelpObserved = as.numeric(plogis(new.data$HelpObserved))
  new.data$tlo          = plogis(new.data$tlo)
  new.data$thi          = plogis(new.data$thi)
  return(new.data)
}

##
## to make the plots look pretty
##
plot_style = theme_bw() +
  #eliminates baground, gridlines, and chart border
  theme(
    plot.background = element_blank()
    ,panel.grid.major = element_blank()
    ,panel.grid.minor = element_blank()
    ,panel.background = element_blank()
    ,axis.text=element_text(size=12)
    ,axis.title=element_text(size=12)
    ,axis.text.x = element_text(angle = 45, hjust = 1)  # rotate x-axis labels
  ) +
  theme(legend.position="bottom", legend.title=element_blank())  # legends at the bottom, with no titles

############################################################################
## Plot model predictions
##
new.data = expand.grid(r=seq(from=0, to=0.5, length.out = 50),
                       ChildrenInAlter = 0:1,
                       # set these predictors to their means
                       Distance = mean(hh.all$Distance),
                       RelativeWealthRank = mean(hh.all$RelativeWealthRank),
                       Ego.Size = mean(hh.all$Ego.Size),
                       Alter.Size = mean(hh.all$Alter.Size),
                       AnyWivesInAlter = mean(hh.all$AnyWivesInAlter),
                       AnyHusbandsInAlter = mean(hh.all$AnyHusbandsInAlter),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       Ego.Need.AFB = mean(hh.all$Ego.Need.AFB),
                       Alter.Need.AFB = mean(hh.all$Alter.Need.AFB),
                       GiftGiven.ind = mean(hh.all$GiftGiven.ind),
                       HelpReceived = mean(hh.all$HelpReceived),
                       Ego.VillageID = unique(hh.all$Ego.VillageID),
                       # set response to zero for now
                       HelpObserved=0)

new.data = predict_gee(gee.best, m.terms, new.data)

new.data$ChildrenInAlter = factor(new.data$ChildrenInAlter)
levels(new.data$ChildrenInAlter) = c("No children alter", "Has children in alter")

plt.r_children = new.data %>%
  filter(Ego.VillageID==1) %>%
  ggplot(aes(x=r, y=HelpObserved)) +
  geom_line(aes(colour=factor(ChildrenInAlter))) +
  geom_ribbon(aes(ymin=tlo, ymax=thi, fill=factor(ChildrenInAlter)), alpha=0.2) +
  xlab("Coefficient of relatedness") +
  ylab("Probability of farm help") +

  #scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  scale_x_continuous(breaks=c(0.0001, 0.063, 0.125, 0.25, 0.5)) +

  plot_style
#ggsave(filename="predicted farm help - gee - by relatedness and children in alter.png", width=300, height=120, units="mm")

##
## relatedness and help reciprocated
##
new.data = expand.grid(r = c(seq(from=0, to=0.5, length.out = 50), 0.25),
                       HelpReceived = 0:1,
                       # set these predictors to their means
                       Distance = mean(hh.all$Distance),
                       RelativeWealthRank = mean(hh.all$RelativeWealthRank),
                       Ego.Size = mean(hh.all$Ego.Size),
                       Alter.Size = mean(hh.all$Alter.Size),
                       AnyWivesInAlter = mean(hh.all$AnyWivesInAlter),
                       AnyHusbandsInAlter = mean(hh.all$AnyHusbandsInAlter),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       Ego.Need.AFB = mean(hh.all$Ego.Need.AFB),
                       Alter.Need.AFB = mean(hh.all$Alter.Need.AFB),
                       GiftGiven.ind = mean(hh.all$GiftGiven.ind),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       Ego.VillageID = unique(hh.all$Ego.VillageID),
                       # set response to zero for now
                       HelpObserved=0)

new.data = predict_gee(gee.best, m.terms, new.data)

new.data$HelpReceived = factor(new.data$HelpReceived)
levels(new.data$HelpReceived) = c("No help reciprocated", "Help reciprocated")

new.data %>%
  filter(r == 0.25 & HelpReceived=="No help reciprocated")

plt.r_recip = new.data %>%
  filter(Ego.VillageID==1) %>%
  ggplot(aes(x=r, y=HelpObserved)) +
  geom_line(aes(colour=factor(HelpReceived))) +
  geom_ribbon(aes(ymin=tlo, ymax=thi, fill=factor(HelpReceived)), alpha=0.2) +
  xlab("Coefficient of relatedness") +
  ylab("Probability of farm help") +

  #scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  scale_x_continuous(breaks=c(0.0001, 0.063, 0.125, 0.25, 0.5)) +

  plot_style

##
## relatedness and gifts
##
new.data = expand.grid(r=seq(from=0, to=0.5, length.out = 50),
                       GiftGiven.ind = 0:1,
                       # set these predictors to their means
                       Distance = mean(hh.all$Distance),
                       RelativeWealthRank = mean(hh.all$RelativeWealthRank),
                       Ego.Size = mean(hh.all$Ego.Size),
                       Alter.Size = mean(hh.all$Alter.Size),
                       AnyWivesInAlter = mean(hh.all$AnyWivesInAlter),
                       AnyHusbandsInAlter = mean(hh.all$AnyHusbandsInAlter),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       Ego.Need.AFB = mean(hh.all$Ego.Need.AFB),
                       Alter.Need.AFB = mean(hh.all$Alter.Need.AFB),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       HelpReceived = mean(hh.all$HelpReceived),
                       Ego.VillageID = unique(hh.all$Ego.VillageID),
                       # set response to zero for now
                       HelpObserved=0)

new.data = predict_gee(gee.best, m.terms, new.data)

new.data$GiftGiven.ind = factor(new.data$GiftGiven.ind)
levels(new.data$GiftGiven.ind) = c("No gifts", "Ego gave gifts")

plt.r_gift = new.data %>%
  filter(Ego.VillageID==1) %>%
  ggplot(aes(x=r, y=HelpObserved)) +
  geom_line(aes(colour=factor(GiftGiven.ind))) +
  geom_ribbon(aes(ymin=tlo, ymax=thi, fill=factor(GiftGiven.ind)), alpha=0.2) +
  xlab("Coefficient of relatedness") +
  ylab("Probability of farm help") +

  #scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  scale_x_continuous(breaks=c(0.0001, 0.063, 0.125, 0.25, 0.5)) +

  plot_style

##
## relatedness and landowner's (alter's) need (for need values: 0, 1, 2)
##
new.data = expand.grid(r=seq(from=0, to=0.5, length.out = 50),
                       Alter.Need.AFB = 0:2,
                       # set these predictors to their means
                       Distance = mean(hh.all$Distance),
                       RelativeWealthRank = mean(hh.all$RelativeWealthRank),
                       Ego.Size = mean(hh.all$Ego.Size),
                       Alter.Size = mean(hh.all$Alter.Size),
                       AnyWivesInAlter = mean(hh.all$AnyWivesInAlter),
                       AnyHusbandsInAlter = mean(hh.all$AnyHusbandsInAlter),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       Ego.Need.AFB = mean(hh.all$Ego.Need.AFB),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       HelpReceived = mean(hh.all$HelpReceived),
                       GiftGiven.ind = mean(hh.all$GiftGiven.ind),
                       Ego.VillageID = unique(hh.all$Ego.VillageID),
                       # set response to zero for now
                       HelpObserved=0)

new.data = predict_gee(gee.best, m.terms, new.data)

new.data$Alter.Need.AFB = factor(new.data$Alter.Need.AFB)
levels(new.data$Alter.Need.AFB) = c("No need", "Medium need", "High need")

plt.r_need = new.data %>%
  filter(Ego.VillageID==1) %>%
  ggplot(aes(x=r, y=HelpObserved)) +
  geom_line(aes(colour=factor(Alter.Need.AFB))) +
  geom_ribbon(aes(ymin=tlo, ymax=thi, fill=factor(Alter.Need.AFB)), alpha=0.2) +
  xlab("Coefficient of relatedness") +
  ylab("Probability of farm help") +

  #scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  scale_x_continuous(breaks=c(0.0001, 0.063, 0.125, 0.25, 0.5)) +

  plot_style

##
## relatedness and distance
##
new.data = expand.grid(r=seq(from=0, to=0.5, length.out = 50),
                       Distance = c(0, mean(hh.all$Distance), max(hh.all$Distance)),
                       # set these predictors to their means
                       RelativeWealthRank = mean(hh.all$RelativeWealthRank),
                       Ego.Size = mean(hh.all$Ego.Size),
                       Alter.Size = mean(hh.all$Alter.Size),
                       AnyWivesInAlter = mean(hh.all$AnyWivesInAlter),
                       AnyHusbandsInAlter = mean(hh.all$AnyHusbandsInAlter),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       Ego.Need.AFB = mean(hh.all$Ego.Need.AFB),
                       Alter.Need.AFB = mean(hh.all$Alter.Need.AFB),
                       ChildrenInAlter = mean(hh.all$ChildrenInAlter),
                       HelpReceived = mean(hh.all$HelpReceived),
                       GiftGiven.ind = mean(hh.all$GiftGiven.ind),
                       Ego.VillageID = unique(hh.all$Ego.VillageID),
                       # set response to zero for now
                       HelpObserved=0)

new.data = predict_gee(gee.best, m.terms, new.data)

new.data$Distance = factor(new.data$Distance)
levels(new.data$Distance) = c("Close neighbours", "Mean distance", "Furthest")

plt.r_dist = new.data %>%
  filter(Ego.VillageID==1) %>%
  ggplot(aes(x=r, y=HelpObserved)) +
  geom_line(aes(colour=factor(Distance))) +
  geom_ribbon(aes(ymin=tlo, ymax=thi, fill=factor(Distance)), alpha=0.2) +
  xlab("Coefficient of relatedness") +
  ylab("Probability of farm help") +

  #scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  scale_x_continuous(breaks=c(0.0001, 0.063, 0.125, 0.25, 0.5)) +

  plot_style

##
## Save the plots
##
# first give them titles
plt.r_children = plt.r_children + ggtitle("(a)")
plt.r_recip    = plt.r_recip    + ggtitle("(b)")
plt.r_gift     = plt.r_gift     + ggtitle("(c)")
plt.r_need     = plt.r_need     + ggtitle("(d)")
plt.r_dist     = plt.r_dist     + ggtitle("(e)")

png(filename = file.path(plots.dir, "fig 4 - predicted  farm labour.png"), height=20, width=25, units = "cm", res=300)
grid.arrange(plt.r_children, plt.r_recip, plt.r_gift, plt.r_need, plt.r_dist,
             ncol=3, nrow=2)
dev.off()

pdf(file = file.path(plots.dir, "fig 4 - predicted  farm labour.pdf"), height=7.9, width=9.8)
grid.arrange(plt.r_children, plt.r_recip, plt.r_gift, plt.r_need, plt.r_dist,
             ncol=3, nrow=2)
dev.off()

## distance stats
round( mean(hh.all$Distance), 3 )
round( max(hh.all$Distance), 3 )


rebol [
	title: "SWF sprites and movie clip related parse functions"
	purpose: "Functions for parsing sprites and movie clip related tags in SWF files"
]

[
rs/run 'imagick rs/run 'jpg-size
rs/run/fresh 'rswf rs/go 'robotek
rescale-swf %ovladac_olejak.swf run %xxx.swf
]

rswf-rescale-index:   .56; 0.8 ;0.75 ;0.25 ;0.5 ;0.75
rsc: func[val][
	switch/default type?/word val [
		integer! [round rswf-rescale-index * val]
		pair!    [as-pair round rswf-rescale-index * val/x rswf-rescale-index * val/y]
		block!   [forall val [change val rsc val/1] val: head val]
	][
 		to (type? val) val * rswf-rescale-index
 	]
]

set 'rescale-swf-tag func[tagId tagData /local err action st st2][
	reduce either none? action: select parseActions tagId [
		;tagData
		form-tag tagId tagData
	][
		setStreamBuffer tagData
		clearOutBuffer

		;print ["IMP>" index? inBuffer length? inBuffer]
		;print [tagId select swfTagNames tagId]

		if error? set/any 'err try [
			set/any 'result do bind/copy action 'self
		][
			print ajoin ["!!! ERROR while rescaling tag:" select swfTagNames tagId "(" tagId ")"]
			throw err
		]

		;head inBuffer
		;print ["IMP<" index? inBuffer length? head inBuffer]
		if tagId = 6 [tagId: 21]
		if tagId = 43 [print as-string tagData]
		;print ["rescale tagId:" tagId]
		either result [
			form-tag tagId result ;head inBuffer
		][	copy #{} ]
	]

]

rescale-PlaceObject2: has[flags] [
	;print "rescale-PlaceObject2"
	writeUI8 flags: readUI8
	carryBytes 2 ;depth
	if isSetBit? flags 2 [carryBytes 2]   ;HasCharacter
	if isSetBit? flags 3 [rescaleMATRIX]  ;HasMatrix
	if isSetBit? flags 4 [carryCXFORMa]   ;HasCxform

	if isSetBit? flags 5 [carryBytes 2]   ;HasRatio
	if isSetBit? flags 6 [carryString ]   ;HasName
	if isSetBit? flags 7 [carryBytes 2]   ;HasClipDepth
	;if isSetBit? flags 8 [readCLIPACTIONS][none]
	;print ["len:" length? inBuffer index? inBuffer length? head inBuffer]
	carryBytes length? inBuffer ;<------------------------------------------------------asi blbe
	head outBuffer
]
rescale-PlaceObject3: has [flags1][
	;probe inbuffer
	f: context [
		HasClipActions?: carryBitLogic
		HasClipDepth?:   carryBitLogic
		HasName?:        carryBitLogic
		HasRatio?:       carryBitLogic
		HasColorTransform?: carryBitLogic
		HasMatrix?:        carryBitLogic
		HasCharacter?:     carryBitLogic
		Move?:             carryBitLogic
		carryBits 3 ;reserved
		HasImage?:         carryBitLogic
		HasClassName?:     carryBitLogic
		HasCacheAsBitmap?: carryBitLogic
		HasBlendMode?:     carryBitLogic
		HasFilterList?:    carryBitLogic
	]
	;alignBuffers
	carryBytes 2 ;Depth
	;probe inbuffer
	if any [
		f/HasClassName?
		all [f/HasImage? f/HasCharacter?]
	][writeString readString] ;ClassName
	if f/HasCharacter? [carryBytes 2] ;ID
	;print "?"
	if f/HasMatrix? [rescaleMATRIX]
	;print "?"
	carryBytes length? inBuffer
	comment {
	if f/HasColorTransform? [carryCXFORMa]
	if f/HasRatio? [carryBytes 2]
	if f/HasName?  [writeString readString]
	if f/HasClipDepth?  [carryBytes 2]
	carryBytes length? inBuffer

	if f/HasFilterList? [rescaleFILTERLIST]
	if f/BlendMode?     [carryBytes 1]

	}
	head outBuffer
]

rescale-Shape: has[data tmp][

	carryBytes 2 ;shapeID
	writeRect tmp:  rsc readRect ;shape bounds
	;print ["originalBaounds:" mold tmp]
	;writeRect tmp ;reduce [tmp/1 - 600 tmp/2 + 600 tmp/3 - 600 tmp/4 + 600]
	if tagId >= 67 [
		writeRect rsc readRect ;edgeBounds
		carryBytes 1    ;flags: 6*reserved,usesNonScalingStrokes,usesScalingStrokes
	]
	rescaleFILLSTYLEARRAY
	rescaleLINESTYLEARRAY
	rescaleSHAPERECORD (alignBuffers carryUB 4) carryUB 4
	head outBuffer
]

rescale-DefineMorphShape: has [tmp][
	;print ["rescale-DefineMorphShape"]
	carryBytes 2 ;shapeID
	;probe inBuffer
	writeRect rsc readRect ;shape StartBounds
	writeRect rsc readRect ;shape EndBounds
	if tagId = 84 [
		writeRect rsc readRect ;shape StartEdgeBounds
		writeRect rsc readRect ;shape EndEdgeBounds
		;probe inBuffer
		carryBytes 1 ;flags: 6*reserved,usesNonScalingStrokes,usesScalingStrokes

	]
	;do not write offset yet!
	tmp: outBuffer
	readBytes 4 ;offset

	;probe inBuffer
	rescaleMORPHFILLSTYLEARRAY
	;probe inBuffer
	rescaleLINESTYLEARRAY
	rescaleSHAPERECORD (alignBuffers carryUB 4) carryUB 4
	alignBuffers

	;write correct offset to start of the end edges
	offs: (index? outBuffer) - (index? tmp)
	outBuffer: tmp
	writeUI32 offs
	outBuffer: tail outBuffer

	rescaleSHAPERECORD (carryUB 4) carryUB 4
	head outBuffer
]

rescale-DefineBits: has[md5 tmp file file-sc][
	md5: enbase/base checksum/method skip inBuffer 2 'md5 16
	tmp: parse-DefineBits
	file:    rejoin [swfDir %tag6_ md5 %.jpg]
	file-sc: rejoin [swfDir %_sc rswf-rescale-index-percent: to-integer (rswf-rescale-index * 100) #"/" %tag6_ md5 %.jpg]
	print ["JPEGTables:" mold JPEGTables]
	if not exists? file-sc [
		unless exists? file [
			;write/binary file  (join JPEGTables skip tmp/2 2)
			write/binary file  JPG-repair either JPEGTables [join JPEGTables tmp/2][tmp/2]
		]
		imagick/resize-jpg file file-sc join form to-string rswf-rescale-index-percent "%"
	]
	writeUI16 tmp/1
	;swf-parser/tagId: 21
	writeBytes read/binary file-sc
	head outBuffer
]
rescale-DefineBitsJPEG2: has[md5 tmp file file-sc][
	md5: enbase/base checksum/method skip inBuffer 2 'md5 16
	tmp: parse-DefineBitsJPEG2
	file:    rejoin [swfDir %tag21_ md5 %.jpg]
	file-sc: rejoin [swfDir %_sc rswf-rescale-index-percent: to-integer (rswf-rescale-index * 100) #"/" %tag21_ md5 %.jpg]
	if not exists? file-sc [
		unless exists? file [
			write/binary file   JPG-repair tmp/2
		]
		imagick/resize-jpg file file-sc join form to-string rswf-rescale-index-percent "%"
	]
	writeUI16 tmp/1
	writeBytes read/binary file-sc
	head outBuffer
]
rescale-DefineBitsJPEG3: has[md5 tmp img file file-sc alphaimg][
	md5: enbase/base checksum/method skip inBuffer 2 'md5 16
	tmp: parse-DefineBitsJPEG3
	file:    rejoin [swfDir %tag35_ md5 %.jpg]
	file-sc: rejoin [swfDir %_sc rswf-rescale-index-percent: to-integer (rswf-rescale-index * 100) #"/" %tag35_ md5 %.jpg]
	if not exists? file-sc [
		unless exists? file [
			;replace tmp/2 #{FFD9FFD8} #{}
			write/binary file  JPG-repair tmp/2
		]
		imagick/resize-jpg file file-sc join form to-string rswf-rescale-index-percent "%"
	]
	writeUI16 tmp/1
	img: read/binary file-sc
	writeUI32 length? img
	writeBytes img

	file:    rejoin [swfDir %tag35_ md5 %.png]
	file-sc: rejoin [swfDir %_sc rswf-rescale-index-percent #"/" %tag35_ md5 %.png]
	if not exists? file-sc [
		unless exists? file [
			img: make image! jpg-size rejoin [swfDir %tag35_ md5 %.jpg]
			img/alpha:	as-binary zlib-decompress tmp/3 (img/size/1 * img/size/2)
			save/png file img
		]
		imagick/resize-jpg file file-sc join form to-string rswf-rescale-index-percent "%"
	]
	img: load file-sc
	;probe img/alpha
	writeBytes head head remove/part tail compress img/alpha -4
	head outBuffer
]
rescale-DefineBitsLossless: has [md5 tmp file file-sc][
	md5: enbase/base checksum/method skip inBuffer 2 'md5 16
	tmp: parse-DefineBitsLossless

	file:    rejoin [swfDir %tag20_ md5 %.png]
	file-sc: rejoin [swfDir %_sc rswf-rescale-index-percent: to-integer (rswf-rescale-index * 100) #"/" %tag20_ md5 %.png]
	if not exists? file-sc [
		unless exists? file [
			write/binary file ImageCore/PIX24-to-PNG context [
				bARGB:  as-binary zlib-decompress tmp/6 (4 * tmp/3 * tmp/4)
				size: as-pair tmp/3 tmp/4
			]
		]
		imagick/resize-jpg file file-sc join form to-string rswf-rescale-index-percent "%"
	]
	writeUI16 tmp/1
	writeBytes ImageCore/ARGB2BLL xxx: ImageCore/load file-sc
	head outBuffer
]

rescale-DefineBitsLossless2: has [md5 tmp file file-sc][
	md5: enbase/base checksum/method skip inBuffer 2 'md5 16
	tmp: parse-DefineBitsLossless
	;print ["BitmapFormat:" tmp/2]
	probe file:    rejoin [swfDir %tag36_ md5 %.png]
	probe file-sc: rejoin [swfDir %_sc rswf-rescale-index-percent: to-integer (rswf-rescale-index * 100) #"/" %tag36_ md5 %.png]
	if not exists? file-sc [
		unless exists? file [
			write/binary file ImageCore/ARGB2PNG context [
				bARGB: as-binary zlib-decompress tmp/6 (4 * tmp/3 * tmp/4)
				size:  as-pair tmp/3 tmp/4
			]
		]
		imagick/resize-jpg file file-sc join form to-string rswf-rescale-index-percent "%"
	]
	writeUI16 tmp/1
	writeBytes probe ImageCore/ARGB2BLL probe ImageCore/load file-sc
	head outBuffer
]

rescale-DefineSprite: has[][
	carryBytes 4 ;ID + FrameCount
	writeBytes rescaleSWFTags inBuffer
	head outBuffer
]

rescaleSHAPERECORD: func[numFillBits numLineBits /local states nBits cx cy dx dy posx posy rposx rposy mainPoints mp][
		;print ["readSHAPERECORD" numFillBits numLineBits "availableBits:" availableBits mold copy/part inBuffer 10]
		alignBuffers
		;numFillBits: carryUB 4 ;Number of fill index bits for new styles
		;numLineBits: carryUB 4 ;...line...
		posx: 0
		posy: 0
		rposx: 0
		rposy: 0
		moveX: moveY: none
		mainPoints: copy [] ;move positions and style changes
		;minX: minY: 1000000
	;	maxX: maxY: -1000000
		until [
			either readBitLogic [ ;edge?
				print "edge"
				either readBitLogic [;straightEdge?
					;print "line - "
					nBits: 2 + readUB 4 ;original nBits - result may be different!
					;comment {
					either readBitLogic [
						;GeneralLine
						dx:	readSB nBits ;deltaX
						dy:	readSB nBits ;deltaY
					][
						either readBitLogic [
							;Vertical
							dx: 0
							dy: readSB nBits
						][	;Horizontal
							dx: readSB nBits
							dy: 0
						]
					]

					;rescaling position, not delta to eliminate rounding errors
					newx: posx + dx
					newy: posy + dy

					odx: dx
					ody: dy

					dx: (negate rposx) + rposx: (rsc newx)
					dy: (negate rposy) + rposy: (rsc newy)

					posx: newx
					posy: newy

					;either rposx > maxX [maxX: rposx][ if rposx < minX [minX: rposx]]
					;either rposy > maxY [maxY: rposy][ if rposy < minY [minY: rposy]]

					;print ["line:" posx posy]
					print [posx newx posy newy]
					;print ">>>>>>>"
					case [
						all [dx <> 0 dy <> 0][
							;print "xy"
							writeBit true
							writeBit true
							writeUB (-2 + nBits: getSBnBits reduce [dx dy]) 4 ;new nBits
							writeBit true
							writeSB dx nBits
							writeSB dy nBits
						]
						dx <> 0 [
							;print "x"
							writeBit true
							writeBit true
							nBits: getSBitsLength dx
							writeUB (-2 + nBits) 4
							writeBit false
							writeBit false
							writeSB dx nBits
						]
						dy <> 0 [
							;print "y"
							writeBit true
							writeBit true
							nBits: getSBitsLength dy
							writeUB (-2 + nBits) 4
							writeBit false
							writeBit true
							writeSB dy nBits
						]
						true [
							;print ["!!!!!!!!!!!!!!!!!!L" ]
							if find [46 84] tagId [
								;there MUST be same number of points in Morph shapes!!!
								writeBit true
								writeBit true
								writeUB 0 4
								writeBit false
								writeBit false
								writeSB 0 2
							]

						]
					]
					;}
					comment {
					either readBitLogic [
						;GeneralLine
						dx:	rsc readSB nBits ;deltaX
						dy:	rsc readSB nBits ;deltaY
						writeUB (-2 + nBits: getSBnBits reduce [dx dy]) 4 ;new nBits
						writeBit true
						writeSB dx nBits
						writeSB dy nBits

					][
						either readBitLogic [
							;Vertical
							nBits: getSBitsLength dy: rsc readSB nBits
							writeUB (-2 + nBits) 4
							writeBit false
							writeBit true
							writeSB dy nBits
						][	;Horizontal
							nBits: getSBitsLength dx: rsc readSB nBits
							writeUB (-2 + nBits) 4
							writeBit false
							writeBit false
							writeSB dx nBits
						]
					]
					}

				][

					;print "curve - "
					nBits: 2 + readUB 4
					cx: readSB nBits ;controlDeltaX
					cy: readSB nBits ;Y
					dx:	readSB nBits ;anchorDeltaX
					dy:	readSB nBits ;Y

					;print ["p:" cx cy dx dy rposx rposy]
					;rescaling control position, not delta to eliminate rounding errors
					newx: posx + cx
					newy: posy + cy
					cx: (negate rposx) + rposx: (rsc newx)
					cy: (negate rposy) + rposy: (rsc newy)
					posx: newx
					posy: newy

					;rescaling delta position, not delta to eliminate rounding errors
					newx: posx + dx
					newy: posy + dy

					dx: (negate rposx) + rposx: (rsc newx)
					dy: (negate rposy) + rposy: (rsc newy)

					posx: newx
					posy: newy

					;print ["n:" cx cy dx dy]
					;print ["curve:" posx posy "   (" cx cy  dx dy]
					either any [
					;	true
						;all [(abs cx) < 20 (abs cy) < 20]
						;all [(abs dx) < 20 (abs dy) < 20]
						false
					][
						;print ".."
						dx: dx + cx
						dy: dy + cy
						;if any [(abs dx) > 20 (abs dy > 20)][
							case [
								all [dx <> 0 dy <> 0][
									;print "xy"
									writeBit true
									writeBit true
									writeUB (-2 + nBits: getSBnBits reduce [dx dy]) 4 ;new nBits
									writeBit true
									writeSB dx nBits
									writeSB dy nBits
								]
								dx <> 0 [
									;print "x"
									writeBit true
									writeBit true
									nBits: getSBitsLength dx
									writeUB (-2 + nBits) 4
									writeBit false
									writeBit false
									writeSB dx nBits
								]
								dy <> 0 [
									;print "y"
									writeBit true
									writeBit true
									nBits: getSBitsLength dy
									writeUB (-2 + nBits) 4
									writeBit false
									writeBit true
									writeSB dy nBits
								]
								;true [print "!!!!!!!!!!!!!!!!!!"]
							]
							;posx: posx + dx
							;posy: posy + dy
						;]
					][
						either any [dx <> 0 dy <> 0] [
							writeBit true
							writeBit false
							writeUB (-2 + nBits: getSBnBits reduce [cx cy dx dy]) 4 ;new nBits
							writeSB cx nBits
							writeSB cy nBits
							writeSB dx nBits
							writeSB dy nBits

							;posx: posx + cx + dx
							;posy: posy + cy + dy
						][
							;print ["!!!!!!!!!!!!!!!!!!C" cx cy dx dy]
						]
					]

					;either rposx > maxX [maxX: rposx][ if rposx < minX [minX: rposx]]
					;either rposy > maxY [maxY: rposy][ if rposy < minY [minY: rposy]]
				]
				false
			][

				states: readUB 5
				;print ["STATES:" states "POS:" posx posy "MOV:" moveX moveY mold mainPoints]
				comment {
				if all [
					not none? moveX
					any [
						moveX <> posX
						moveY <> posY
					]
					;all [
					;	5 > abs (dx: moveX - posx)
					;	5 > abs (dy: moveY - posy)
					;]
				][
					mindiffx: mindiffy: 10000
					newPos: none
					forall mainPoints [

						;print [abs (mainPoints/1  - (as-pair posx posy))]
						if all [
							mindiffx > tmpx: abs (mainPoints/1/x  - posx)
							mindiffy > tmpy: abs (mainPoints/1/y  - posy)
						][
							mindiffx: tmpx
							mindiffy: tmpy
							newPos: mainPoints/1
						]
					]
					mainPoints: head mainPoints
					print ["midiff:" mindiffx mindiffy "newPos:" newPos "oldPos:" as-pair posX posY]
					if all [
						mindiffx < 20
						mindiffy < 20
					][
						dx: newPos/x - posx
						dy: newPos/y - posy
						posX: newPos/x
						posY: newPos/y

						;print ["AAAAAAAAAAAA:" moveX posX MoveY posY dx dy]
						;dx: moveX - posx
						;dy: moveY - posy
						case [
							all [dx <> 0 dy <> 0][
								;print "xy"
								writeBit true
								writeBit true
								writeUB (-2 + nBits: getSBnBits reduce [dx dy]) 4 ;new nBits
								writeBit true
								writeSB dx nBits
								writeSB dy nBits
							]
							dx <> 0 [
								;print "x"
								writeBit true
								writeBit true
								nBits: getSBitsLength dx
								writeUB (-2 + nBits) 4
								writeBit false
								writeBit false
								writeSB dx nBits
							]
							dy <> 0 [
								;print "y"
								writeBit true
								writeBit true
								nBits: getSBitsLength dy
								writeUB (-2 + nBits) 4
								writeBit false
								writeBit true
								writeSB dy nBits
							]
							;true [print "!!!!!!!!!!!!!!!!!!"]
						]
					]
				]
				}
				either states = 0 [
					;EndShapeRecord
					writeBit false
					writeUB 0 5
				;	print [
				;		"bounds:" minX maxX minY  maxY
				;	]

					alignBuffers
					;outBuffer: skip head outBuffer 2
					;writeRect reduce [minX - 100 maxX + 100 minY - 100 maxY + 100]
					;outByteAlign
					;probe head outBuffer
					true ;end
				][
					;StyleChangeRecord
					writeBit false
					writeUB states 5
					if 0 < (states and 1 ) [
				;		prin "Move "

						set [newx newy] readSBPair
						if all [posx = newx newy = posy][print "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"]
						moveX: posx: newx
						moveY: posy: newy

						rposx: rsc posx
						rposy: rsc posy
						;print ["MOVE:" rposx rposy "puvodni:" posx posy]

						;either rposx > maxX [maxX: rposx][ if rposx < minX [minX: rposx]]
						;either rposy > maxY [maxY: rposy][ if rposy < minY [minY: rposy]]
						writeSBPair reduce [rposx rposy]
						;rescaleSBPair
					]      ;move
					if 0 < (states and 2 ) [ carryUB numFillBits] ;fillStyle0
					if 0 < (states and 4 ) [ carryUB numFillBits] ;fillStyle1
					if 0 < (states and 8 ) [ carryUB numLineBits] ;lineStyle
					if 0 < (states and 16) [
					;print "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
						rescaleFILLSTYLEARRAY
						rescaleLINESTYLEARRAY
						numFillBits: carryUB 4 ;Number of fill index bits for new styles
						numLineBits: carryUB 4 ;...line...
					] ;NewStyles
					;mp: as-pair posX posY
					;unless find mainPoints mp [append mainPoints mp]

					false ;continue
				]
			]
		]
]

rescaleSBPair: has[nBits x y][
	nBits: readUB 5
	x: rsc readSB nBits
	y: rsc readSB nBits
	writeSBPair reduce [x y]
	;writeUB (nBits: getSBnBits probe reduce [x y]) 5 ;new nBits
	;writeSB x nBits
	;writeSB y nBits
]

rescaleMATRIX: does [
	alignBuffers
	if carryBitLogic [;scale
		;carryPair
		writePair  readPair
		;writePair rsc probe readPair
	]
	if carryBitLogic [;rotate
		writePair  readPair
		;carryPair
		;writePair probe readPair
	]
	rescaleSBPair
	alignBuffers
]
rescaleMATRIXall: does[
	alignBuffers
	if carryBitLogic [;scale
		;carryPair
		;writePair  readPair
		writePair rsc readPair
	]
	if carryBitLogic [;rotate
		writePair  readPair
		;carryPair
		;writePair probe readPair
	]
	rescaleSBPair
	alignBuffers
]

rescaleGRADIENT: func[type] [
	alignBuffers
	;print ["gradient:" to-hex type]
	carryBits 4 ;SpreadMode + InterpolationMode
	loop carryUB 4 [
		;GRADRECORD
		carryBytes either tagId >= 32 [5][4] ;ratio + color
	]
	if all [type = 19 tagId = 83] [carryBytes 2] ;FocalPoint
]

rescaleMORPHGRADIENT: func[type][
	alignBuffers
	;print ["rescaleMORPHGRADIENT" mold copy/part inBuffer 30 ]
	loop carryUI8[
		carryBytes 10 ;Start ratio,Start color,End ratio,End color
	]
]

rescaleFILLSTYLEARRAY: does [
	;print ["FSA:" mold copy/part inBuffer 10]
	alignBuffers
	loop carryCount [
		rescaleFILLSTYLE
	]
]
rescaleMORPHFILLSTYLEARRAY: does[
	;print ["MFSA:" mold copy/part inBuffer 10]
	alignBuffers
	loop carryCount [ ;FillStyleCount
		rescaleMORPHFILLSTYLE
	]
]

rescaleFILLSTYLE: has[type][
	;print ["fillstyle" mold copy/part inBuffer 10]
	alignBuffers
	type: readUI8 ;FillStyleType

	case [
		type = 66 [type: 64 print "66 000000000000000000000000"]
		type = 67 [type: 65 print "67 000000000000000000000000"]
	]

	writeUI8 type

	case [
		type = 0 [
			;solid fill
			case [
				find [46 84] tagId [
					carryBytes 8 ;morph RGBAs
				]
				tagId >= 32 [carryBytes 4] ;RGBA
				true [carryBytes 3] ;RGB
			]
		]
		any [
			type = 16 ;linear gradient fill
			type = 18 ;radial gradient fill
			type = 19 ;focal gradient fill (swf8)
		][
			;gradient
			either find [46 84] tagId [
				;morph
				rescaleMATRIX
				rescaleMATRIX
				rescaleMORPHGRADIENT type
			][	;shape
				;print "./......................."
				rescaleMATRIXall
				rescaleGRADIENT type
			]
		]
		type >= 64 [
			;bitmap
			reduce either find [46 84] tagId [
				;morph
				carryBytes 2 ;id
				rescaleMATRIX
				rescaleMATRIX
			][	;shape
				carryBytes 2 ;id
				rescaleMATRIX
			]
		]
	]
]

rescaleMORPHFILLSTYLE: does [
	;print ["Mfillstyle" mold copy/part inBuffer 10]
	alignBuffers
	type: readUI8 ;FillStyleType

	case [
		type = 66 [type: 64 print "66 000000000000000000000000"]
		type = 67 [type: 65 print "67 000000000000000000000000"]
	]

	writeUI8 type
	case [
		type = 0 [
			;solid fill
			carryBytes 8 ;morph RGBAs
		]
		any [
			type = 16 ;linear gradient fill
			type = 18 ;radial gradient fill
			type = 19 ;focal gradient fill (swf8)
		][
			;gradient
			rescaleMATRIXall
			rescaleMATRIXall
			rescaleMORPHGRADIENT type
		]
		type >= 64 [
			;bitmap
			carryBytes 2 ;id
			rescaleMATRIX
			rescaleMATRIX
		]
	]
]

rescaleLINESTYLEARRAY: has[LineStyles joinStyle hasFill?][
	;print "linestylearray"
	alignBuffers
	loop carryCount [ ;LineStyleCount
		alignBuffers
		;print ["linestyle" tagId]
		case [
			;DefineMorphShape
			tagId = 46 [
				writeUI16 rsc readUI16 ;StartWidth
				writeUI16 rsc readUI16 ;EndWidth
				carryBytes 8 ;RGBA + RGBA
			]
			;DefineShape4
			any [tagId = 67 tagId = 83][
				writeUI16 rsc readUI16   ;Width
				carryBits 2              ;f_start_cap_style
				joinStyle: carryUB 2     ;f_join_style
				hasFill?:  carryBitLogic ;f_has_fill
				carryBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

				if joinStyle = 2 [carryBytes 2] ;miterLimit
				either hasFill? [rescaleFILLSTYLE][carryBytes 4]
			]
			;DefineMorphShape2
			tagId = 84 [
				writeUI16 rsc readUI16 ;StartWidth
				writeUI16 rsc readUI16 ;EndWidth

				carryBits 2              ;f_start_cap_style
				joinStyle: carryUB 2     ;f_join_style
				hasFill?:  carryBitLogic ;f_has_fill
				carryBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

				if joinStyle = 2 [carryBytes 2] ;miterLimit
				either hasFill? [rescaleFILLSTYLE][carryBytes 8]
			]
			true [
				writeUI16 rsc readUI16 ;Width
				carryBytes either tagId = 32 [4][3]
			]
		];case
	]
]

rescaleMORPHLINESTYLEARRAY: has[LineStyles][
	;print "linestylearray"
	alignBuffers
	loop carryCount [ ;LineStyleCount
		alignBuffers
		writeUI16 rsc readUI16 ;StartWidth
		writeUI16 rsc readUI16 ;EndWidth

		;print ["linestyle" tagId]
		case [
			;DefineMorphShape
			tagId = 46 [
				writeUI16 rsc readUI16 ;StartWidth
				writeUI16 rsc readUI16 ;EndWidth
				carryBytes 8 ;RGBA + RGBA
			]
			;DefineShape4
			any [tagId = 67 tagId = 83][
				writeUI16 rsc readUI16   ;Width
				carryBits 2              ;f_start_cap_style
				joinStyle: carryUB 2     ;f_join_style
				hasFill?:  carryBitLogic ;f_has_fill
				carryBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

				if joinStyle = 2 [carryBytes 2] ;miterLimit
				either hasFill? [rescaleFILLSTYLE][carryBytes 4]
			]
			;DefineMorphShape2
			tagId = 84 [
				writeUI16 rsc readUI16 ;StartWidth
				writeUI16 rsc readUI16 ;EndWidth

				carryBits 2              ;f_start_cap_style
				joinStyle: carryUB 2     ;f_join_style
				hasFill?:  carryBitLogic ;f_has_fill
				carryBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

				if joinStyle = 2 [carryBytes 2] ;miterLimit
				either hasFill? [rescaleFILLSTYLE][carryBytes 8]
			]
			true [
				writeUI16 rsc readUI16 ;Width
				carryBytes either tagId = 32 [4][3]
			]
		];case
	]
]

;--------------------------------------------------------------------

carryCXFORM: has [HasAddTerms? HasMultTerms? nbits][
	HasAddTerms?:  carryBitLogic
	HasMultTerms?: carryBitLogic
	nbits: carryUB 4
	if HasMultTerms? [
		carrySB nbits ;R
		carrySB nbits ;G
		carrySB nbits ;B
	]
	if HasAddTerms? [
		carrySB nbits ;R
		carrySB nbits ;G
		carrySB nbits ;B
	]
	alignBuffers
]
carryCXFORMa: has [HasAddTerms? HasMultTerms? nbits][
	HasAddTerms?:  carryBitLogic
	HasMultTerms?: carryBitLogic
	nbits: carryUB 4
	if HasMultTerms? [
		carrySB nbits ;R
		carrySB nbits ;G
		carrySB nbits ;B
		carrySB nbits ;A
	]
	if HasAddTerms? [
		carrySB nbits ;R
		carrySB nbits ;G
		carrySB nbits ;B
		carrySB nbits ;A
	]
	alignBuffers
]


library(gplots)
lineage_matrix <- read.csv("/Volumes/GoogleDrive/My\ Drive/python_code/connectome_tools/lineage_analysis/lineage_matrix.csv")

palette <- colorRampPalette(c("white", "orange", "brown4","brown4","brown4","brown4","brown4","brown4"))(n = 128)
width <- 10
height <- 10
pointsize <- 4

#setEPS()
#postscript("/Volumes/GoogleDrive/My\ Drive/R\ code/CNpaper/new_names_analysis/plots/ExtFig4d_MB2ONsimilarity_by_MBON-input_CNnames_cluster.eps", width = width, height = height, pointsize = pointsize)
heatmap.2(as.matrix(lineage_matrix), scale="none", density.info="none", trace="none", col=palette, key.xlab="Similarity", key.title=FALSE, keysize = 1, key = FALSE)
#dev.off()


# Title: accounting.r
# Objective: Track dispositions of deposits, apportion fund worth to designations including tax
# Created by: NR
# Additional editors:

########################################################################
# Preamble
########################################################################

# Set options
options(stringsAsFactors=F)

# libraries
library(lattice)
library(quantmod)
library(optparse)
library(reshape2)

# Structure/document how arguments are to be passed to this script
option_list = list(
  make_option(c("-w", "--working_directory"), type="character", default=NULL,
              help="Path to the base level of the local repository instance", metavar="character")
)

opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

working.dir <- opt$working_directory
setwd(working.dir)
getwd()

# Source common Fns
source('tickerFns.r')
source("tactFns.r")

########################################################################
# Gather data:
########################################################################

history <- read.csv(file=file.path(working.dir,'sim001','simPos.csv'),header=T)


# Parameters

# Columns associated with the different dataset

cols_std <- c("idx", "full.name.of.describer", "date")
cols_dis <- c("genus", "species", "author", "date")

cols_ll  <- c(
    "idx", "lat_n", "lon_n", "type.country_n.A3",
    "type.locality.verbatim", "type.locality.updated",
    "full.name.of.describer", "date"
)

# Min. thresholds for latitude
lat <- list(
    trop = 0,
    subtrop = 23.436740,
    temp = 35.000000,
    pol = 66.563250
)

lat_splits <- list(
    trop = 2,
    temp = 3
)

# Lookup files

lookup_cty <- get_lp_statoid()
lookup_cty_subset_ll <- lookup_cty[prop_area_latitude >= .6, ] # subset
lookup_cty_subset_biogeo <- lookup_cty[prop_area_biogeo_wwf >= 0.6,] # subset

# Alternative to lookup_cty_subset_ll
# lookup_cty$area_km2 <- as.numeric(lookup_cty$area_km2)
# lookup_cty_subset_ll <- lookup_cty[
#     area_km2 < quantile(area_km2, .95, na.rm = T),
# ] # exclude the largest countries

lookup_bm <- get_lp_biome()

# Extra data lookup files

filepath_nearest_loc_biome <- paste0(
    v2_dir_data_ch2,
    '2020-11-03-nearest-loc.csv'
)
# note: this process took >3h so it was persisted instead

filepath_nearest_loc_ecoregion <- paste0(
    v2_dir_data_ch2,
    '2020-11-03-nearest-loc-ecoregion.csv'
)


# Jinliang Yang
# 7/24/2012
#

###############################################################################
# NAM data2 from Buckler and Panzea, CW, AKW TKW and KC
###############################################################################

pheno <- read.table("/Users/yangjl/Documents/GWAS2_KRN/pheno/traitMatrix_maize282NAM_v10-120314.txt", header=T)

### Keep only the following traits
### EAR:AKW, KC, TKW=earWeight -CobWeight
### COB: CL

mynm <- names(pheno)
mynm1 <- c("Trait","X20KernelWeight","CobDiameter","CobDiameter.1","CobWeight","CobWeight.1","EarDiameter","EarDiameter.1","EarLength","EarLength.1",
           "EarRowNumber","EarRowNumber.1","EarWeight","EarWeight.1","TotalKernelVolume", "TotalKernelVolume.1")
mypheno <- pheno[, mynm1]
nampheno <- mypheno[-1:-283,]
nampheno[nampheno==-999] <- NA;
nampheno$FID <- NA;
names(nampheno)[1] <- "Genotype";
nampheno$Genotype <- as.character(nampheno$Genotype);
for(i in 1:nrow(nampheno)){
  tem <- unlist(strsplit(nampheno$Genotype[i], split="E"));
  nampheno$FID[i] <- tem[1];
}
nampheno$Fix <- 1;

nampheno[,2:16] <- apply(nampheno[,2:16], 2, as.numeric)
summary(nampheno)

##### AKW #######################################################
nampheno$X20KernelWeight <- as.numeric(as.character(nampheno$X20KernelWeight))/20
names(nampheno)[2] <- "AKW"

##### KRN =EarRowNumber EarRowNumber.1 ###########################

##### KC =TotalKernelVolume TotalKernelVolume.1#######################################################

##### TKW #######################################################
# TKW= EarWeight - CobWeight
nampheno$TKW_rep1 <- nampheno$EarWeight - nampheno$CobWeight
nampheno$TKW_rep2 <- nampheno$EarWeight.1 - nampheno$CobWeight.1

names(nampheno) <- c("Genotype", "AKW","CD_rep1", "CD_rep2", "CW_rep1", "CW_rep2", "EarDiameter",
 					 "EarDiameter.1", "CL_rep1","CL_rep2", "KRN_rep1","KRN_rep2", "EarWeight", "EarWeight.1",
					 "KC_rep1", "KC_rep2", "FID","Fix", "TKW_rep1", "TKW_rep2")
library(reshape)
bnamlong <- melt(nampheno, id=c("Genotype", "FID", "Fix"))

### get all the BLUEs
##### CW #######################################################
bcw <- subset(bnamlong, variable=="CW_rep1" | variable=="CW_rep2")
bcw <- bcw[, c(1,4,5)]
names(bcw) <- c("Genotype", "Location", "CW")
bcw <- bcw[bcw$CW<50,]

idx1 <- grep("B73", nam2011blue$Genotype)
nam2011cw <- nam2011blue[-idx1,]
nam2011cw <- nam2011cw[, c("Genotype", "CW")]
nam2011cw$Location <- "Ames2011"
nam2011cw <- nam2011cw[, c(1,3,2)]

cw2008 <- pheno2008[['cw']]
cw2008 <- cw2008[, c("Genotype", "Location", "RIL")]
names(cw2008) <- c("Genotype", "Location", "CW")

hist(bcw$CW)
hist(nam2011cw$CW)
hist(cw2008$CW)

cw <- rbind(bcw, nam2011cw, cw2008)
cw <- cw[!is.na(cw$CW),]
cw_blue <- BLUE(data=cw, model=CW~Genotype, random=~1|Location, trait="CW", intercept="Z001E0001")

##### AKW #######################################################
bakw <- subset(bnamlong, variable=="AKW")
bakw <- bakw[, c(1,4,5)]
names(bakw) <- c("Genotype", "Location", "AKW")

idx1 <- grep("B73", nam2011blue$Genotype)
nam2011akw <- nam2011blue[-idx1,]
nam2011akw <- nam2011akw[, c("Genotype", "AKW")]
nam2011akw$Location <- "Ames2011"
nam2011akw <- nam2011akw[, c(1,3,2)]

akw2008 <- pheno2008[['akw']]
akw2008 <- akw2008[, c("Genotype", "Location", "RIL")]
names(akw2008) <- c("Genotype", "Location", "AKW")

akw <- rbind(bakw, nam2011akw, akw2008)
akw <- akw[!is.na(akw$AKW),]
akw_blue <- BLUE(data=akw, model=AKW~Genotype, random=~1|Location, trait="AKW", intercept="Z001E0001")

##### TKW #######################################################
btkw <- subset(bnamlong, variable=="TKW_rep1" | variable=="TKW_rep2")
btkw <- btkw[, c(1,4,5)]
names(btkw) <- c("Genotype", "Location", "TKW")
btkw <- btkw[btkw$TKW>0,]

idx1 <- grep("B73", nam2011blue$Genotype)
nam2011tkw <- nam2011blue[-idx1,]
nam2011tkw <- nam2011tkw[, c("Genotype", "TKW")]
nam2011tkw$Location <- "Ames2011"
nam2011tkw <- nam2011tkw[, c(1,3,2)]

tkw2008 <- pheno2008[['tkw']]
tkw2008 <- tkw2008[, c("Genotype", "Location", "RIL")]
names(tkw2008) <- c("Genotype", "Location", "TKW")

tkw <- rbind(btkw, nam2011tkw, tkw2008)
tkw <- tkw[!is.na(tkw$TKW),]
tkw_blue <- BLUE(data=tkw, model=TKW~Genotype, random=~1|Location, trait="TKW", intercept="Z001E0001")

##### KC #######################################################
bkc <- subset(bnamlong, variable=="KC_rep1" | variable=="KC_rep2")
bkc <- bkc[, c(1,4,5)]
names(bkc) <- c("Genotype", "Location", "KC")

idx1 <- grep("B73", nam2011blue$Genotype)
nam2011kc <- nam2011blue[-idx1,]
nam2011kc <- nam2011kc[, c("Genotype", "KC")]
nam2011kc$Location <- "Ames2011"
nam2011kc <- nam2011kc[, c(1,3,2)]

kc2008 <- pheno2008[['kc']]
kc2008 <- kc2008[, c("Genotype", "Location", "RIL")]
names(kc2008) <- c("Genotype", "Location", "KC")

kc <- rbind(bkc, nam2011kc, kc2008)
kc <- kc[!is.na(kc$KC),]
kc <- kc[kc$KC>0,]
kc_blue <- BLUE(data=kc, model=KC~Genotype, random=~1|Location, trait="KC", intercept="Z001E0001")
kc_blue <- kc_blue[kc_blue$KC>30,]

#########################
nam_blue <- list()
nam_blue[['akw']] <- akw_blue;
nam_blue[['tkw']] <- tkw_blue;
nam_blue[['kc']] <- kc_blue;
nam_blue[['cw']] <- cw_blue;


library(foreach)
library(doSNOW)

r=3
k=c(2,2,2,3)
source("codeKfixedLOG.r")
source("codeKvariable.r")
kmax=4

n=100
Ti=4
pers=12
sepp=2.5

source("doSimu.r")
pers=10
source("doSimu.r")
pers=8
source("doSimu.r")


#Anemone associations

#   1) Did anemone associations evolve numerous times (if so, how many)?
#   2) Does phylogenetic relatedness, or adult max body size best explain the life history stage at which anemone-associated fishes are associated with anemones?
#   3) Is there any real difference in these analysis when comparing facultative and obligate anemone associated fishes?
#
#   3 is less important, as all we're trying to formally show is whether there's a good and broad case for size-selective predation being a generalisable selection force for anemone-associations in fishes.

### Hello

library(ape)
library(phytools)
library(caper)

nrow(dat<-read.csv('data/Anemonefish Comparative Data 22.06.2016.csv'))
#[1] 87
names(dat)
# [1] "Common.name"                     "Family"
# [3] "Scientific.name"                 "Location"
# [5] "Association"                     "Ontogentic.Stage.of.Association"
# [7] "Adult.Max.Length..mm."           "COI"

#Ntip(phy<-read.tree('COI\ genbank\ alignment/tree.phy'))
#Ntip(phy<-read.tree('phylogenies/20160711_averaged_jModeltest.phy'))
Ntip(phy<-read.tree('phylogenies/20160714_averaged_jModeltest_withnames.phy'))

# [1] 64

### phy has a basal polytomy, so try creating an outgroup (worked)
plot(outg <- read.tree(text='(outgroup:0.05,TREE:0.00);'))
phy1 <- bind.tree(outg, phy, where=grep('TREE', outg$tip.label))
phy2 <- root(phy1, 'outgroup')

### Need to match genbank IDs in phy tip labels to actual species names
#   head(trans <- read.csv('COI\ genbank\ alignment/genbank_spp_translate.txt'))
#   ##  genbank                       sp
#   ##  1 gi|584295226|gb|KF929610.1|      Apogon aunerolineatus
#   ##  2 gi|614136154|gb|KJ466130.1|   Ostorhinchus cyanosoma
#   ##  3 gi|356996146|gb|JN827969.1|         Apogon maculatus
#   ##  4 gi|356996320|gb|JN828056.1|   Apogon quadrisquamatus
#   ##  5 gi|584296689|gb|KF930338.1|      Pterapogon kauderni
#   ##  6 gi|816375469|gb|KP194051.1| Plagiotremus tapeinosoma
#
#   trans$gb <- substr(trans$genbank, 1, 10)
#
#   head(intersect(trans$genbank <- substr(trans$genbank, 1, 10), phy2$tip.label))
#
#   head(phy2$tip.label <- as.character(trans$sp[match(phy2$tip.label, trans$genbank)]))
#
#   phy2$tip.label[1]<-'outgroup'

dd <- subset(dat, select=c('Scientific.name','Family','Ontogentic.Stage.of.Association','Adult.Max.Length..mm.'))
names(dd)<-c('sp','family','stage','length')

dd$sp <- as.character(dd$sp)
dd$sp.trans <- paste(substr(dd$sp, 1, 2), '.', sub('^.* ','',dd$sp), sep='')

levels(dd$stage)[1] <- 'Blank (presume no data?)'

phy2$tip.label <- sub('Os.cyanosoma','Os.nanus', phy2$tip.label)

phy2$tip.label <- dd$sp[match(phy2$tip.label, dd$sp.trans)]
phy2$tip.label <- as.character(phy2$tip.label)
phy2$tip.label[1]<-'outgroup'
treedat <- comparative.data(phy2, dd, sp)

summary(pgls1 <- pgls(length ~ stage, data=treedat, lambda='ML'))
##  Call:
##    pgls(formula = length ~ stage, data = treedat, lambda = "ML")
##
##  Residuals:
##    Min       1Q   Median       3Q      Max
##  -108.265  -23.871    1.031   19.396  120.312
##
##  Branch length transformations:
##
##    kappa  [Fix]  : 1.000
##  lambda [ ML]  : 0.637
##  lower bound : 0.000, p = 0.00048113
##  upper bound : 1.000, p = < 2.22e-16
##  95.0% CI   : (0.288, 0.849)
##  delta  [Fix]  : 1.000
##
##  Coefficients:
##    Estimate Std. Error t value  Pr(>|t|)
##  (Intercept)      151.8956     3.7715 40.2751 < 2.2e-16 ***
##    stageJuvAndAdult -23.1969    28.0817 -0.8260     0.412
##  stageJuvenile    181.4165    34.1788  5.3079 1.696e-06 ***
##    ---
##    Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 40.79 on 60 degrees of freedom
##  Multiple R-squared: 0.4018,	Adjusted R-squared: 0.3819
##  F-statistic: 20.15 on 2 and 60 DF,  p-value: 2.02e-07

pdf(paste('plots/','Length vs Stage', '-', Sys.Date(),'.pdf',sep=''), height=8, width=8)
with(treedat$data, boxplot(length~stage, las=1, xlab='Stage of association', ylab='Adult max length'))
plot(jitter(resid(pgls1))~jitter(fitted(pgls1)), las=1, main='PGLS residuals versus fitted values')
dev.off()


library( "rmacrolite" )

# # Setup MACRO directory (if needed)
# rmacroliteSetModelVar( "C:/swash/macro" )

# Import a par-file

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182_1910-1911.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

# Run the simulation
out <- rmacroliteRun( x = par_file )

# Inspect the results

#   View the water and solute balance as output by MACRO
#   attributes( out ) # full list of attributes
attr( x = out, which = "waterSoluteBalance" )

library( "macroutils2" )

macroPlot( x = out[, c( "Date", "WOUT_99-100_100",
    "SFLOW_99-100_100" ) ], gui = FALSE, subPlots = TRUE )


#!/usr/bin/Rscript --vanilla
# Author: Peris, IATA-CSIC

library(ggplot2)
library(gridExtra)
library(dplyr)
library(optparse)

option_list = list(
make_option(c("-i", "--dirFolder"), action="store", type="character", default=NULL,
        help="Direct folder where qaf.tab files are stored",metavar="character"),
make_option(c("-o", "--outputFile"), action="store", type="character", default=NULL,
        help="Name of the output file",metavar="character")
)

opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

data_HTZ_distr <- list.files(opt$dirFolder, pattern = "*.qaf.tab")
lista_p = list()

pdf(paste0(opt$outputFile,"_HTZ_multiplot.pdf"),height=6,width=14)
for(i in 1:length(data_HTZ_distr)){
  f_temp <- read.table(paste0(opt$dirFolder,data_HTZ_distr[i]),sep= "\t", header = T)
  f_temp <- f_temp[nchar(as.character(f_temp$REF))==1,]
  f_temp <- f_temp[nchar(as.character(f_temp$ALT))==1,]
  f_temp <- mutate(f_temp, AFATOT = AFA*TOTC, AFRTOT=AFR*TOTC)
  lista_p[[i]] <- ggplot(f_temp, aes_string(x="AFATOT",y="AFRTOT")) +
      geom_point(size = 1, color = "red") +
      theme_classic() +
      theme(axis.line.x = element_line(colour = "black"),axis.line.y = element_line(colour = "black"), axis.title.x = element_blank(),axis.title.y = element_blank()) +
      xlab("Alternative") + scale_x_continuous(limits = c(0,400)) +
      ylab("Reference") + scale_y_continuous(limits = c(0,400)) +
      ggtitle(unlist(strsplit(as.character(data_HTZ_distr[i]),".qaf"))[1])

  print(ggplot(f_temp, aes_string(x="AFATOT",y="AFRTOT")) +
      geom_point(size = 1, color = "red") +
      theme_classic() +
      theme(axis.line.x = element_line(colour = "black"),axis.line.y = element_line(colour = "black"), axis.title.x = element_blank(),axis.title.y = element_blank()) +
      xlab("Alternative") + scale_x_continuous(limits = c(0,400)) +
      ylab("Reference") + scale_y_continuous(limits = c(0,400)) +
      ggtitle(unlist(strsplit(as.character(data_HTZ_distr[i]),".qaf"))[1]))
  names_plots <- c(lista_p, paste0("p",i))
}
print(do.call(grid.arrange,c(lista_p, nrow = 2)))
dev.off()


#--------------------------------------------#
# local authority variation - final data set #
#--------------------------------------------#

# packages ----
library(janitor)
library(tidyr)
library(purrr)
library(dplyr)
library(readxl)
library(readr)

#-------------#
# get data ----
#-------------#
setwd("N:/Documents/Data & Programming/Public data")

la_lkup <- read_xls("gov uk/nlac-2011.xls") %>%
  clean_names()

gdp <- read_xlsx("LA spending/gdp_deflator_1718.xlsx")

#------------#
# LA data ----
#------------#
col_name <- c("csc_centre_spend", "csc_youth_spend")
csc_spend <- map(c("sure_start_spend.xlsx",
                   "young_people_spend.xlsx"), ~read_xlsx(paste0("LAIT/",.x), sheet = "data"))  %>%
  map(., ~gather(., key = "year", value = "spend", -la_code, -la_name)) %>%
  map(., ~mutate(., year = as.numeric(gsub("year_", "", year)))) %>%
  map2(., col_name, ~rename(.x, !!.y := spend, "old_la_code" = la_code, "old_la_name" = la_name)) %>%
  reduce(left_join, by = c("old_la_code", "old_la_name", "year")) %>%
  left_join(la_lkup, by = "old_la_code") %>%
  right_join(gdp, by = "year") %>%
  mutate(la_code = case_when(new_la_code == "E08000037" ~ "E08000020",
                             new_la_code == "E06000057" ~ "E06000048",
                             new_la_code == "E06000050" ~ "E06000049",
                             TRUE ~ as.character(new_la_code))) %>%
  dplyr::select(la_code, year, csc_centre_spend, csc_youth_spend, gdp_deflator) %>%
  group_by(la_code, year, gdp_deflator) %>%
  summarise_all(funs(sum(.))) %>%
  mutate_at(vars(contains("spend")), funs(.*(gdp_deflator/100))) %>%
  ungroup()

#-------------#
# IMD data ----
#-------------#

# 2010:
old_lad_lkup <- read_csv("N:/Documents/Data & Programming/Public data/ons/old_LAD_to_LA_code_lookup.csv") %>%
  dplyr::select(lad_old_code, la_code)

IMD_2010_dat <- read.csv("N:/Documents/Data & Programming/Public data/gov uk/imd2010.csv") %>%
  clean_names() %>%
  dplyr::select(lsoa_code, lad_old_code = post_2009_la_code, imd_score, contains("geog")) %>%
  left_join(old_lad_lkup, by = "lad_old_code") %>%
  arrange(desc(imd_score)) %>%
  mutate(rank = row_number(),
         lsoa10_pct = ifelse(rank < n()/10,1,0)) %>%
  group_by(la_code) %>%
  summarise(prop10_imd = sum(lsoa10_pct)/n()) %>%
  mutate(la_code = case_when(la_code == "E08000037" ~ "E08000020",
                             la_code == "E06000057" ~ "E06000048",
                             la_code == "E06000050" ~ "E06000049",
                             TRUE ~ as.character(la_code))) %>%
  group_by(la_code) %>%
  summarise_all(list( ~round(median(as.numeric(.)), 2))) %>%
  ungroup()

#----------------------------------------#
# mid-year population estimates (ONS) ----
#----------------------------------------#
pop_est_dat <- readRDS("ONS/pop_est_dat.rds") %>%
  dplyr::select(la_code, year, pop_U1, total, pop_child_tot, pop_adult_tot, pop_women) %>%
  mutate(la_code = ifelse(la_code == "E06000050", "E06000049", as.character(la_code))) %>%
  group_by(la_code, year) %>%
  summarise_all(funs(sum(.))) %>%
  ungroup()

#-------------------------------#
# Rural/Urban classification ----
#-------------------------------#
ru11 <- readRDS("gov uk/ruralurban_class_la.rds") %>%
  filter(la_code != "E06000050") %>%  # cheshire east and west have the same classification
  dplyr::select(la_code, starts_with("ru"))

#--------------------------#
# ethnicity data (ONS) ----
#--------------------------#
ethnicity <- read.csv("ONS/ethnicity_notdetailed.csv") %>%
  clean_names() %>%
  rename(la_code = geography_code) %>%
  dplyr::select(la_code, contains("white_measures"), contains("all_categories")) %>%
  mutate(la_code = case_when(la_code == "E08000037" ~ "E08000020",
                             la_code == "E06000057" ~ "E06000048",
                             la_code == "E06000050" ~ "E06000049",
                             TRUE ~ as.character(la_code))) %>%
  group_by(la_code) %>%
  summarise_all(funs(sum(.))) %>%
  mutate(white_pct = round(ethnic_group_white_measures_value*100/ethnic_group_all_categories_ethnic_group_measures_value, 2)) %>%
  dplyr::select(-contains("ethnic_group")) %>%
  ungroup()

#--------------#
# CLA data ----
#--------------#
ADM_dat <- readRDS("CLA/CLA rds/ADM_tidy.rds") %>%
  filter(geog_l == "LA") %>%
  dplyr::select(year, la_code = New_geog_code, SCLA_U1) %>%
  mutate(la_code = case_when(la_code == "E08000037" ~ "E08000020",
                             la_code == "E06000057" ~ "E06000048",
                             la_code == "E06000050" ~ "E06000049",
                             TRUE ~ as.character(la_code))) %>%
  group_by(year, la_code) %>%
  summarise_all(funs(sum(.))) %>%
  ungroup()

#--------------#
# PHE data ----
#--------------#
look_up_code <- read.csv("gov uk/Ward_to_LAD_to_County_to_County_Electoral_Division_May_2017_Lookup_for_England.csv", header = TRUE) %>%
  dplyr::select(lad2014_code = 3, la_code = 5) %>%
  filter(tolower(substr(lad2014_code,1,1)) != "w") %>%
  mutate(lad2014_code = as.character(lad2014_code)) %>%
  distinct(lad2014_code, .keep_all = TRUE)

phe_list <- map(c(11202, 10101), ~filter(clean_names(read.csv("PHE/PHE_LA_data.csv")), indicator_id == .x & category == "" & area_type == "District & UA")) %>%
  map(., ~dplyr::select(., starts_with("indicator"), area_code, area_name, time_period, value, count, denominator)) %>%
  map(~droplevels(.)) %>%
  map(~left_join(.,look_up_code, by = c("area_code" = "lad2014_code"))) %>%
  map(~mutate(., la_code = ifelse(is.na(la_code), as.character(area_code), as.character(la_code)),
              la_code = case_when(la_code == "E08000037" ~ "E08000020",
                                  la_code == "E06000057" ~ "E06000048",
                                  la_code == "E06000050" ~ "E06000049",
                                  TRUE ~ as.character(la_code)),
                 year = as.numeric(substr(as.character(time_period),1,4)))) %>%
  map(~group_by(., year, la_code)) %>%
  map(~mutate_at(., vars("count", "denominator"), funs(sum = sum(., na.rm = TRUE)))) %>%
  map(~ungroup(.)) %>%
  map(~distinct(., year, la_code, .keep_all = TRUE)) %>%
  map(~mutate(., value_new = count_sum*100/denominator_sum)) %>%
  map2(.,c("violent_crime", "child_lowinc"), ~dplyr::select(.x,la_code, year, !!.y := value_new))

violent_crime <- phe_list[[1]] %>%
  filter(year == 2010) %>%
  dplyr::select(-year)

child_lowinc <- phe_list[[2]]

#-------------------------------#
# highest qual (2011 census) ----
#-------------------------------#
# highest_qual <- read.csv("census/highest_qual_by_sex_la.csv") %>%
#   clean_names() %>%
#   dplyr::select(contains("geography"), contains("all_persons")) %>%
#   dplyr::select(la_code = geography_code, qual_denom = 3, none = 4, lvl1 = 5, lvl2 = 6) %>%
#   mutate(la_code = case_when(la_code == "E08000037" ~ "E08000020",
#                              la_code == "E06000057" ~ "E06000048",
#                              la_code == "E06000050" ~ "E06000049",
#                              TRUE ~ as.character(la_code))) %>%
#   group_by(la_code) %>%
#   summarise_at(vars(qual_denom, none, lvl1, lvl2), funs(sum(.))) %>%
#   mutate(qual_lt2 = none + lvl1 + lvl2,
#          qual_lt2_pct = qual_lt2*100/qual_denom,
#          qual_lt1 = none + lvl1,
#          qual_lt1_pct = qual_lt1*100/qual_denom) %>%
#   dplyr::select(la_code, qual_lt1_pct) %>%
#   ungroup()

#----------------------------------------#
# household composition (2011 census) ----
#----------------------------------------#
household_comp <- read.csv("census/household_composition_la.csv") %>%
  clean_names() %>%
  dplyr::select(contains("geography"), contains("age_all"), -contains("sex_males"), -contains("sex_females")) %>%
  dplyr::select(contains("geography"), contains("dependent"), -contains("non_dependent"),
                sex_all_persons_age_all_categories_age_household_composition_all_categories_household_composition_measures_value) %>%
  dplyr::select(la_code = geography_code, married_couple = 3, cohab_couple = 4, lone_parent = 5, other = 6, all_households = 7) %>%
  mutate(dependent_denom = married_couple + cohab_couple + lone_parent + other,
         la_code = case_when(la_code == "E08000037" ~ "E08000020",
                             la_code == "E06000057" ~ "E06000048",
                             la_code == "E06000050" ~ "E06000049",
                             TRUE ~ as.character(la_code))) %>%
  group_by(la_code) %>%
  summarise_all(funs(sum(.))) %>%
  mutate(lone_parent_pct = lone_parent*100/dependent_denom,
         depend_house_pct = dependent_denom*100/all_households) %>%
  ungroup() %>%
  dplyr::select(la_code, lone_parent_pct, depend_house_pct)

#-------------------------#
# get dsh data ----
#-------------------------#

hes_dat <- readRDS("N:/Documents/Data & Programming/DSH data/RDS files/hes_dat.rds")
hes_child_dat <- readRDS("N:/Documents/Data & Programming/DSH data/RDS files/hes_child_dat.rds")
cla_dat <- readRDS("N:/Documents/Data & Programming/DSH data/RDS files/cla_dat.rds")
hes_bt_dat <- readRDS("N:/Documents/Data & Programming/DSH data/RDS files/hes_bt_dat.rds")

#---------------------------#
# LA CSC ofsted results ----
#---------------------------#
#ofsted <- read_xlsx("N:/Documents/Data & Programming/Public data/gov uk/LA_csc_inspection.xlsx") %>%
#  left_join(la_lkup, by = "la_name") %>%
#  dplyr::select(la_code = new_la_code, inspect_date, ends_with("score")) # latest inspection

#-------------------------#
# region look-up table ----
#-------------------------#
region_lkup <- readRDS("N:/Documents/Data & Programming/RDS files/region_lkup.rds") %>%
  dplyr::select(la_code, la_name = uaccnm, contains("region")) %>%
  mutate(la_name = ifelse(la_code == "E06000049", "Cheshire (pre-2009)", as.character(la_name))) %>%
  filter(la_code != "E06000050")

#----------------------------------#
# add all data sources together ----
#----------------------------------#
all_dat <- list(hes_dat, hes_child_dat, cla_dat,
                pop_est_dat, csc_spend,
                ADM_dat, child_lowinc) %>%
  reduce(left_join, by = c("la_code","year")) %>%
  left_join(IMD_2010_dat, by = "la_code") %>% # IMD 2010 data
  left_join(ethnicity, by = "la_code") %>%   # ethnicity (2011 census data)
  left_join(violent_crime, by = "la_code") %>% #for the year 2010/11 only
  #left_join(highest_qual, by = "la_code") %>% #for the year 2011 only
  left_join(household_comp, by = "la_code") %>% #for the year 2011 only
  #left_join(ofsted, by = "la_code") %>%
  left_join(ru11, by = "la_code") %>% # census 2011 data
  left_join(hes_bt_dat, by = "la_code") %>% # hes birthweight data 2012/13 only
  #dplyr::select(-old_la_code, -old_la_name, -new_la_code) %>%
  mutate(early_csc_spend = csc_centre_spend + csc_youth_spend,
         early_csc_spend_pc = early_csc_spend/pop_child_tot) %>%
  left_join(region_lkup, by = "la_code")

saveRDS(all_dat, "N:/Documents/Data & Programming/RDS files/la_analysis_dat.rds")


library(ggplot2)
library(scales)
library(ggthemes)
source("./utils.r")

demog_data <- read.csv("./outputs/demog_summary.csv")
demog_data <- subset(demog_data, sex != "")
demog_data$sex <- factor(demog_data$sex, levels = c("M", "F"))
demog_data$dataset <- factor(
  demog_data$dataset, levels = c("camcan", "lemon", "chbp", "tuab"),
  labels = c("Cam-CAN\n(MEG)", "LEMON\n(EEG)", "CHBP\n(EEG)", "TUAB\n(EEG)"))

demog_summary1 <- do.call(rbind, lapply(
  split(demog_data, list(demog_data$sex, demog_data$dataset)),
  function(dat){
    with(dat,
      data.frame(dataset = dat$dataset[[1]],
                 sex = sex[[1]],
                 sub_count = length(sex),
                 sub_M = mean(age),
                 sub_min = min(age),
                 sub_max = max(age))
    )
}))

demog_summary2 <- do.call(rbind, lapply(
  split(demog_data, demog_data$dataset),
  function(dat) {
    with(dat,
      data.frame(dataset = dat$dataset[[1]],
                 count = nrow(dat),
                 min = min(age),
                 max = max(age),
                 SD = sd(age),
                 M = mean(age))
    )
}))

demog_out <- merge(demog_summary2, demog_summary1, by = "dataset")

is_num <- sapply(demog_out, is.numeric)
demog_out[, is_num] <- round(demog_out[, is_num], 1)

write.csv(demog_out, "./outputs/demog_summary_table.csv")

demog_count <- demog_out[seq(1, 8, 2), c("dataset", "count")]
demog_count$label <- paste('n =', demog_count$count)

fig <- ggplot(
  aes(x = age, color = sex, fill = sex),
      data = demog_data) +
  geom_density(alpha = 0.4, size = 1, trim = T) +
  geom_rug() +
  facet_wrap(.~dataset, ncol = 4) +
  theme_minimal(base_size = 22) +
  scale_color_solarized() +
  scale_fill_solarized() +
  labs(x = "Age [years]", y = "Density") +
  geom_text(x = 70, y = 0.026,
            size = 6,
            inherit.aes = F,
            mapping = aes(label =  label), data = demog_count)
print(fig)
my_ggsave("./figures/fig_demographics", fig, dpi = 300, width = 10, height = 4.5)


library("ggplot2")
setwd("~/dev/BitFunnel/src/Scripts")
df <- read.csv(header=TRUE, file="history.csv")

png(filename="bitfunnel-progress.png",width=1600,height=1200)
df$date <- as.Date(df$date)
ggplot(df, aes(date, wc)) + geom_line(size=3) + scale_x_date() +
    labs(x = "Date", y = "Lines of code") +
    stat_smooth(se=FALSE) +
    theme_bw() +
    theme(axis.text = element_text(size=40),
          axis.title = element_text(size=40))
dev.off()

endDate <- as.Date("2017/07/01")
png(filename="bitfunnel-extrapolation.png",width=1600,height=1200)
ggplot(df, aes(date, wc)) + geom_line(size=3) +
    scale_x_date(limits=c(df$date[1],endDate)) +
    labs(x = "Date", y = "Lines of code") +
    stat_smooth(method="lm",fullrange=TRUE,se=FALSE) +
    geom_hline(yintercept=72000,color="green") +
    geom_hline(yintercept=144000,color="red") +
    theme_bw() +
    theme(axis.text = element_text(size=40),
          axis.title = element_text(size=40))
dev.off()


library(tidyverse)
library(zoo)
library(data.table)

my.max <- function(x) ifelse( !all(is.na(x)), max(x, na.rm=T), NA)
my.min <- function(x) ifelse( !all(is.na(x)), min(x, na.rm=T), NA)

setwd("~/GitHub/COVID19_Monitor")
###Data Generation Function

###Data Generation Function
covid_data_gen <- function(directory="data/"){
    covid_county_raw <- read.csv(paste0(directory, "us-counties.csv"))

    covid_county_raw$index <- paste0(covid_county_raw$state, "_", covid_county_raw$county)
    county_pops <- read.csv(paste0(directory, "countypops.csv"))
    county_pops$index <- paste0(county_pops$State, "_", county_pops$County)
    zips <- read.csv(paste0(directory, "zipcodes.csv"))
    zips$index <- paste0(zips$state, "_", zips$county)

    covid_county_merge <- merge(county_pops[,c("index", "Pop")], covid_county_raw, by="index")

    unique_counties <- unique(covid_county_merge$index)
    covid_county_list <- list()
    for(i in unique_counties){
        covid_county_list[[i]] <- covid_county_merge[covid_county_merge$index %in% i, ]
    }

    for(i in unique_counties){
        covid_county_list[[i]] <- covid_county_list[[i]][order(as.Date(covid_county_list[[i]]$date)),]
    }

    for(i in unique_counties){
        covid_county_list[[i]] <- covid_county_list[[i]] %>%
            mutate(date = as.Date(date)) %>%
            arrange(date) %>%
            mutate(new_cases = cases - dplyr::lag(cases)) %>% #new cases is diff over a 1-day lag
            mutate(new_cases_7d_avg = rollmean(new_cases, k=7, na.pad=TRUE, align="right")) %>%
            mutate(new_deaths = deaths - dplyr::lag(deaths)) %>%
            mutate(new_deaths_7d_avg = rollmean(new_deaths, k=7, na.pad=TRUE, align="right")) %>%
            mutate(new_cases = ifelse(new_cases < 0, 0, new_cases)) %>% #Set negative days to zero
            mutate(new_deaths = ifelse(new_deaths < 0, 0, new_deaths)) %>% #Set negative days to zero
            filter(!is.na(new_cases_7d_avg)) %>%
            mutate(cases_norm = new_cases/my.max(new_cases)) %>%
            mutate(deaths_norm = new_deaths/my.max(new_deaths)) %>%
            mutate(cases_pop = (cases/Pop)*100000) %>%
            mutate(deaths_pop = (deaths/Pop)*100000) %>%
            mutate(new_cases_pop = (new_cases)/Pop*100000) %>%
            mutate(new_deaths_pop = (new_deaths/Pop)*100000) %>%
            mutate(new_cases_7d_pop = (new_cases_7d_avg)/Pop*100000) %>%
            mutate(new_deaths_7d_pop = (new_deaths_7d_avg/Pop)*100000)
    }

    covid_county_processed <- as.data.frame(data.table::rbindlist(covid_county_list))

    covid_county_merge_spatial <- merge(zips[,c("index", "zip_code", "latitude", "longitude")], covid_county_processed, by="index")
    covid_county_merge_spatial$date <- as.Date(covid_county_merge_spatial$date)

    date_bundle <- list(covid_county_processed=as.data.table(covid_county_processed), covid_county_merge_spatial=as.data.table(covid_county_merge_spatial))
    return(date_bundle)
}

data_bundle <- covid_data_gen()

saveRDS(data_bundle, "data/covid_data.rds", compress="xz")


# function(s) to make a plot of data from 3D model mapping data and field data.
# specifically the data on kinematics vs geometric estimations
# Eric Barefoot
# Sep 2019

# first, load libraries

# load packages

library(tidyverse)
library(here)
library(broom)
library(lme4)
library(devtools)  # for the next thing
library(colorspace)
library(paleohydror)
library(purrr)
library(rsample)

if (interactive()) {
    require(colorout)
}

figdir = here('figures', 'outputs', 'manuscript_figures')

# load data

chamb_data = readRDS(file = here('data','derived_data', 'chamberlin_model_data.rds'))
chamb_model = readRDS(file = here('data','derived_data', 'chamberlin_stat_model.rds'))
model = readRDS(file = here('data','derived_data','piceance_3d_model_data.rds'))
field = readRDS(file = here('data','derived_data','piceance_field_data.rds'))
combined = readRDS(file = here('data', 'derived_data', 'piceance_field_model_data.rds'))
barpres_raw = readRDS(file = here('data', 'derived_data', 'piceance_bar_preservation.rds'))

barpres = barpres_raw %>%
rename(frac_elems = 'perc_full') %>% ungroup() %>%
mutate(formID = case_when(
  formation == 'ohio_creek' ~ 3,
  formation == 'atwell_gulch' ~ 2,
  formation == 'molina' ~ 1,
  formation == 'shire' ~ 0)
) %>%
select(formID, id, frac_elems) %>%
mutate(depth = NA, slope = NA) %>%
slice(1:round(n() * 0.5))

barpres_means = barpres %>% group_by(formID) %>%
summarize(mean_elems = median(frac_elems)) %>%
mutate(depth = NA, slope = NA)

cpal = hcl(h = c(80, 120, 240), c = rep(100, 3), l = c(85, 65, 20))

field_depths = field %>%
filter(structure %in% c('bar','channel') & meas_type %in% c('thickness', 'dimensions')) %>%
mutate(depth = case_when(meas_type == 'thickness' ~ meas_a, meas_type == 'dimensions' ~ meas_b)) %>%
select(formation, set_id, depth) %>%
mutate(formID = case_when(
  formation == 'ohio_creek' ~ 3,
  formation == 'atwell_gulch' ~ 2,
  formation == 'molina' ~ 1,
  formation == 'shire' ~ 0)
)

bedloadSamples = field %>%
filter(meas_type == 'sample' & !(structure %in% c('outcrop', 'formation', 'bar_drape')) & meas_a < 2000) %>%
transmute(set_id = set_id, D50 = meas_a * 1e-6)

slopes =
inner_join(field_depths, bedloadSamples, by = 'set_id') %>%
group_by(formID, set_id) %>% summarize(depth = median(depth), D50 = median(D50)) %>%
mutate(slope = atan(trampush_slp(D50, depth)) * (90 / pi)) %>%
select(formID, slope) %>%
mutate(id = NA, frac_elems = NA, mean_elems = NA, depth = NA)

depths = field_depths %>% select(formID, depth) %>%
mutate(id = NA, frac_elems = NA, mean_elems = NA, slope = NA)

data_table = bind_rows(depths, slopes, barpres, barpres_means, .id = 'split') %>%
mutate(formID = as.factor(formID)) %>% select(-id) %>%
pivot_longer(c(depth, slope, frac_elems, mean_elems), names_to = 'meas', values_to = 'vals') %>%
mutate(meas = ifelse(meas == 'mean_elems', 'frac_elems', meas)) %>%
mutate(meas = as.factor(
  case_when(
  meas == 'depth' ~ 100,
  meas == 'slope' ~ 200,
  meas == 'frac_elems' ~ 300)
)
)

labels = as_labeller(c(`0` = 'Shire', `1` = 'Molina', `2` = 'Atwell Gulch', `100` = 'Flow Depth (m)', `200` = 'Fluvial Slope (º)', `300` = '% Fully Preserved Bars'))
form_labs = c('Shire','Molina','Atwell Gulch')

data_figure = ggplot() +
# plot depths
stat_bin(data = filter(data_table, split == 1),
aes(x = vals, y = ..count.., fill = formID),
geom = 'bar', position = "identity", bins = 20, color = 'black', size = 0.5) +
# plot slopes
stat_bin(data = filter(data_table, split == 2),
aes(x = vals, y = ..count.., fill = formID),
geom = 'bar', position = "identity", bins = 7, color = 'black', size = 0.5) +
# plot histogram of % bar estimates from bootstrapping
stat_bin(data = filter(data_table, split == 3),
aes(x = vals, y = ..count.., fill = formID, color = formID),
geom = 'bar', position = "identity", bins = 20, size = 0.5, alpha = 0.4) +
# plot mean line
geom_vline(data = filter(data_table, split == 4),
aes(xintercept = vals, color = formID), size = 2) +
# adjust other parameters for the whole plot.
scale_fill_manual(values = cpal, name = 'Stratigraphic Member', labels = form_labs) +
scale_color_manual(values = cpal) +
facet_grid(rows = vars(formID), cols = vars(meas), scales = 'free_x', labeller = labels) +
labs(x = NULL, y = 'Frequency') +
theme_classic() +
theme(strip.background = element_blank(), strip.text.y = element_blank(), legend.position = 'bottom') +
guides(color = 'none')

# save figure

ggsave(plot = data_figure, filename = "petm_data.pdf", path = figdir, width = 6, height = 4, units = "in")

########################################################
# Old scripts to make some plots like this one.
########################################################
# # first step is to generate a dataset which has all the same attributes but
# # estimates the depth based on paleohydro.
#
# # group the data by formation and the set_id, which indicates a set of paleohydro
# # measurements for a single location/outcrop in time. can only compare/combine
# # measurements from the same set to calculate slope, etc.
#
# fieldDataGrouped = field_data %>% group_by(formation, set_id) %>% filter(set_id != 'FORMANA')
#
# fieldDataGrouped_BZF = field_data %>% group_by(formation, set_id)
#
# # calculate the depth based on a x-set to depth calculation.  May fine-tune this
# # later, but for now chooses the most ham-fisted option.  TODO: provide for
# # selecting different methods based on field observations of certain kinds, or
# # the availability of certain data.
#
#
# flowDepthSetXset = fieldDataGrouped %>% filter(structure == "cross_set" & meas_type ==
#     "thickness") %>% summarize(xsetDepth = suppressMessages(xset2depthSimple(meas_a)))
#
# # calculate the depth based on channel scour fill thicknesses.  TODO: estimate
# # some compaction estimation.
#
# flowDepthSetChannel = fieldDataGrouped %>% filter(structure == "channel" & meas_type ==
#     "thickness") %>% summarize(channelDepth = mean(meas_a))
#
# # calculate the depth based on point bar thicknesses.
#
# flowDepthSetBarThick = fieldDataGrouped %>% filter(structure == "bar" & meas_type ==
#     "thickness") %>% summarize(barDepthThick = mean(meas_a))
#
# # calculate the depth based on point bar y dimensions as measured from outcrop.
#
# flowDepthSetBarDims = fieldDataGrouped %>% filter(structure == "bar" & meas_type ==
#     "dimensions") %>% summarize(barDepthDims = mean(meas_b))
#
# # merge these all back together into one tibble.
#
# flowDepthsSetAll = Reduce(function(...) {
#     full_join(..., by = c(formation = "formation", set_id = "set_id"))
# }, list(flowDepthSetChannel, flowDepthSetBarThick, flowDepthSetBarDims))
#
# # reshape for easier summary.
#
# flowDepthsSetAll = flowDepthsSetAll %>% gather(key = "measType", value = "depth",
#     c(-formation, -set_id))
#
# # assign weights to each of the techniques for estimating depth. x-set
# # measurements, though the most heavily weighted, have significant uncertainties,
# # although simply by virtue of the fact that I have a lot of them and they are at
# # all the sites, I am going to consider them the most important ones.
#
# # They are, in order: xset thicknesses, channel thicknesses, bar thicknesses, and
# # bar ydimensions (thicknesses) TODO: figure out how to weight bar measuments by
# # grade. Future stuff.
#
# weightByType = tibble(measType = unique(flowDepthsSetAll$measType), weight = c(10, 10, 10))
#
# # join the weight vector to the table.
#
# flowDepthsSetAll = left_join(flowDepthsSetAll, weightByType, by = "measType")
#
# # group variables by formation, then by set id.
#
# flowDepthSet = group_by(flowDepthsSetAll, formation, set_id)
#
# # take a weighted mean of the different techniques by set, then by formation.
#
# flowDepthSetMean = flowDepthSet %>% summarize(depth = weighted.mean(x = depth, w = weight,
#     na.rm = T))
# flowDepthFormMean = flowDepthSetMean %>% summarize(depth = mean(depth, na.rm = T))
#
# # exploratory plots of the distributions.
#
# # Now that we have depth, the next thing we really need is grain size. I don't
# # have any data on this yet, so I'll just build the framework for now. The data
# # for each sample is going to come in as a separate dataset. I can provide here a
# # list of sample names.
#
# sampleData = fieldDataGrouped %>% filter(meas_type == 'sample')
#
# bedloadSamples = sampleData %>% filter(structure != 'outcrop' & structure != 'formation' & structure != 'bar_drape' & meas_a < 2000)
#
# bedloadSamples = bedloadSamples %>% mutate(D50 = meas_a * 1e-6)
#
# # sampCodes = as.vector(na.omit(unique(fieldDataGrouped$samp_code)))
# #
# # sample_info = fieldDataGrouped %>% filter(!is.na(samp_code)) %>% select(samp_code,
# #     samp_description, textures, observations) %>% distinct()
# #
# # D50 = rep(NA, nrow(sample_info))
# # D95 = rep(NA, nrow(sample_info))
# #
# # for (i in 1:nrow(sample_info)) {
# #     str1 = sample_info$samp_description[i]
# #     str2 = sample_info$textures[i]
# #     if (grepl("bedload", str1)) {
# #         if (grepl("coarse", str2)) {
# #             D = rnorm(1, 5e-04, 1e-04)
# #         } else if (grepl("fine", str2)) {
# #             D = rnorm(1, 2e-04, 1e-04)
# #         } else {
# #             # message('this doesnt have a coarse-fine choice, going in between')
# #             D = rnorm(1, 3e-04, 1e-04)
# #         }
# #         D50[i] = D
# #     } else if (grepl("suspended", str1)) {
# #         D = rnorm(1, 7.5e-05, 1e-05)
# #         D95[i] = D
# #     } else {
# #
# #     }
# # }
# #
# # sizeGuess = tibble(D50 = D50, D95 = D95, samp_code = sampCodes)
#
# # sampSizes = left_join(sample_info, sizeGuess, by = "samp_code")
#
# # flowDepthSetGrainSize = left_join(flowDepthSetMean, ungroup(sampSizes) %>%
# # select(-(samp_description:observations), -formation), by = "set_id")
#
#
# flowDepthSetGrainSize = inner_join(flowDepthSetMean, bedloadSamples %>% ungroup() %>% group_by(set_id) %>% summarize(D50 = mean(D50)), by = "set_id")
#
#
# # slopeShearEstimates = flowDepthSetGrainSize %>% mutate(S = trampush_slp(D = D50, H = depth)) %>% mutate(tau = 1000 * 9.8 * depth * S)
# #
# # # flowDepthSetGrainSize$D50[is.na(flowDepthSetGrainSize$samp_code)] = 3e-04
# # # flowDepthSetGrainSize$samp_code[is.na(flowDepthSetGrainSize$samp_code)] = "20171007S6MMPB6014S006"
# #
# # S = numeric(length(unique(flowDepthSetGrainSize$set_id)))
# # F = numeric(length(unique(flowDepthSetGrainSize$set_id)))
# # j = 1
# # for (i in sort(unique(flowDepthSetGrainSize$set_id))) {
# #     dat = flowDepthSetGrainSize %>% filter(set_id == i)
# #     Dbed = mean(dat$D50, na.rm = TRUE)
# #     # Dsusp = mean(dat$D95, na.rm = TRUE)
# #     H = mean(dat$depth, na.rm = TRUE)
# #     S[j] = trampush_slp(D = Dbed, H = H)
# #     if (is.na(Dsusp)) {
# #     } else {
# #         S[j] = trampush_slp(Dbed = Dbed, H = H)
# #         F[j] = NA
# #     }
# #     j = j + 1
# # }
# #
# # tibb_slopeF = tibble(set_id = sort(unique(flowDepthSetGrainSize$set_id)), S, F)
# #
# # paleoHydroSetEst = left_join(flowDepthSetGrainSize, tibb_slopeF, by = "set_id") %>%
# #     mutate(tau = 1000 * 9.8 * depth * S)
#
#
# paleoHydroSetEst = flowDepthSetGrainSize %>% mutate(S = trampush_slp(D = D50, H = depth)) %>% mutate(tau = 1000 * 9.8 * depth * S)
#
# paleoHydroSetEst = ungroup(flowDepthSetGrainSize) %>% group_by(formation) %>% mutate(S = trampush_slp(D = D50, H = depth)) %>% mutate(tau = 1000 * 9.8 * depth * S)
#
# paleoHydroFormEst = paleoHydroSetEst %>% summarize(h = median(depth), depthsd = sd(depth), slope = median(S), slopesd = sd(S), tau = median(tau), Dbed = median(D50, na.rm = TRUE), D50sd = sd(D50), n = n())
#
# paleoHydroFormEst = paleoHydroSetEst %>% summarize(depth = median(depth), slope = median(S), tau = median(tau), D50 = median(D50, na.rm = TRUE), n = n())
#
# cpal = hcl(h = c(80, 120, 240), c = rep(100, 3), l = c(85, 65, 20))
#
# paleoHydroSetEst = paleoHydroSetEst %>% mutate(formID = case_when(formation == 'ohio_creek' ~ 3, formation == 'atwell_gulch' ~ 2, formation == 'molina' ~ 1, formation == 'shire' ~ 0))
#
# # df = field_data %>% mutate(formID = case_when(formation == 'ohio_creek' ~ 3, formation == 'atwell_gulch' ~ 2, formation == 'molina' ~ 1, formation == 'shire' ~ 0))
#
# legend_ord = levels(with(paleoHydroSetEst, reorder(formation, formID)))
# #
# # df %>% group_by(formID, loc_x, loc_y, formation) %>%
# # summarize(n = n()) %>% filter(formation != 'ohio_creek') %>%
# # ggplot() + aes(x = loc_x, y = loc_y, color = reorder(formation, formID)) +
# # scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch','Ohio Creek'), breaks = legend_ord) +
# # geom_point() + labs(x = 'Longitude', y = 'Latitude') + theme_minimal()
#
# # slope_plot
#
# slope_freq = paleoHydroSetEst %>% ggplot() + stat_bin(aes(x = S, y = ..density.., color = reorder(formation, formID)), geom = 'line', position = 'identity', bins = 8, size = 1.5) +
# scale_x_log10(breaks = c(1e-04, 2e-04, 3e-04, 5e-04, 7e-04, 0.001, 0.002, 0.003), labels = c(expression(10^-4), expression(2%*%10^-4), expression(3%*%10^-4), expression(5%*%10^-4), expression(7%*%10^-4), expression(10^-3), expression(2%*%10^-3), expression(3%*%10^-3))) +
# theme_minimal() + scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = 'Slope (-)', y = 'Probability Density')
#
# # slope_freq
#
# # depth plot
#
# depth_freq = paleoHydroSetEst  %>% ggplot() + stat_bin(aes(x = depth, y = ..density.., color = reorder(formation, formID)), geom = 'line', position = "identity", binwidth = 0.7, size = 1.5) + theme_minimal() + scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = 'Flow Depth (m)', y = 'Probability Density')
#
# # depth_freq
#
# # grain size plot
#
# grainsize_freq = paleoHydroSetEst %>% ggplot() + stat_bin(aes(x = D50 * 1e6, y = ..density.., color = reorder(formation, formID)), geom = 'line', position = "identity", binwidth = 65, size = 1.5) + theme_minimal() + scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = expression(paste('Bedload Sample ', D[50], ' (', mu, 'm)')), y = 'Probability Density')
#
# # grainsize_freq
#
# # slope_plot
#
# slope_curves = paleoHydroSetEst %>% ggplot() + stat_density(aes(x = S, color = reorder(formation, formID)), geom = 'line', position = "identity", bw = 0.15) +
# scale_x_log10(breaks = c(1e-04, 2e-04, 3e-04, 5e-04, 7e-04, 0.001, 0.002, 0.003), labels = c(expression(10^-4), expression(2%*%10^-4), expression(3%*%10^-4), expression(5%*%10^-4), expression(7%*%10^-4), '0.001', '0.002', '0.003')) + theme_minimal() +
# scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = 'Slope (-)', y = 'Probability Density')
#
# # slope_curves
# # depth plot
#
# depth_curves = paleoHydroSetEst  %>% ggplot() + stat_density(aes(x = depth, color = reorder(formation, formID)), geom = 'line', position = "identity", bw = 0.7) + theme_minimal() + scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = 'Flow Depth (m)', y = 'Probability Density')
#
# # grain size plot
#
# grainsize_curves = paleoHydroSetEst %>% ggplot() + stat_density(aes(x = D50 * 1e6, color = reorder(formation, formID)), geom = 'line', position = "identity", bw = 50) + theme_minimal() + scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = expression(paste('Sample ', D[50], ' (', mu, 'm)')), y = 'Probability Density')
#
# # ggsave(plot = slope_curves, filename = "petm_slope_piceance_density_estimates.pdf", path = figdir, width = 7, height = 4, units = "in")
# #
# # ggsave(plot = grainsize_curves, filename = "petm_grainsize_piceance_density_estimates.pdf", path = figdir, width = 7, height = 4, units = "in")
# #
# # ggsave(plot = depth_curves, filename = "petm_depth_piceance_density_estimates.pdf", path = figdir, width = 7, height = 4, units = "in")
#
# ggsave(plot = slope_freq, filename = "petm_slope_piceance_frequency.png",
#     path = figdir, width = 7, height = 4, units = "in")
#
# ggsave(plot = grainsize_freq, filename = "petm_grainsize_piceance_frequency.png",
#     path = figdir, width = 7, height = 4, units = "in")
#
# ggsave(plot = depth_freq, filename = "petm_depth_piceance_frequency.png",
#     path = figdir, width = 7, height = 4, units = "in")
#
# save(file = here("data", "derived_data", "paleoHydroFormationEstimates.rda"), paleoHydroFormEst)
# save(file = here("data", "derived_data", "paleoHydroSetEstimates.rda"), paleoHydroSetEst)
#
#
# # formNames = list('Ohio Creek','Shire','Molina','Atwell Gulch')
# #
# # formlabels = function(var,v) {
# #   return(formNames[[v]])
# # }
#
# SizeplotDepth = paleoHydroSetEst %>% ggplot() + theme_minimal() + scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) + labs(x = expression(paste('Grain Size (', mu, 'm)')), y = 'Flow Depth (m)') + facet_grid(rows = vars(formation)) +
# geom_smooth(method = 'lm', aes(x = D50 * 1e6, y = depth, color = reorder(formation, formID)), fill = hcl(c = 0, l = 85), level = 0.99) + theme(legend.position = 'bottom') + geom_point(aes(x = D50 * 1e6, y = depth, color = reorder(formation, formID)), position = "identity")
#
# ggsave(plot = SizeplotDepth, filename = "petm_depth_grainsize_piceance.pdf",
#     path = figdir, width = 4, height = 7, units = "in")
#
# # and once we have a list of the names, which will be the data frame names, we
# # just need to calculate the D50 of each, and the Dmaxs of each, and compile them
# # here.
#
# ######################################################################################################################## Some code extracting the D50 from each sample code, ending in a predictably
# ######################################################################################################################## named dataset grainSizeSamples
#
# # left_join(fieldDataGrouped, grainSizeSamples, by = 'set_id')
#
# ######################################################################################################################## Some code generating some fake grainsize data based on notes.  coarse/medium
# ######################################################################################################################## sand = 500 micron medium/fine sand = 200 micron medium silt = 20 micron
#
#
# paleoHydroFormEst = paleoHydroFormEst %>% mutate(formID = case_when(formation == 'ohio_creek' ~ 0, formation == 'atwell_gulch' ~ 1, formation == 'molina' ~ 2, formation == 'shire' ~ 3))
#
#
# stratdat = paleoHydroFormEst %>% mutate(D50 = D50 * 10^6, slope = slope * 10^4) %>% gather(var, data, -c(formation,formID))
#
# stratplot = stratdat %>% filter(var != 'n') %>% ggplot() + aes(y = formID, x = data) + geom_path() + geom_point() + facet_grid(cols = vars(var), scales = 'free_x') + theme_minimal()
#
# stratplot


 a <- read.table("netz-gene-order.txt",header=F)
 b <- read.table("netz-mRNA-order.txt",header=F)
 c <- read.table("netz-pearson-order.txt",header=F)
 d <- read.table("netz-STRING-order.txt",header=F)
 e <- read.table("genez-order.txt",header=F)
 f <- read.table("net-name.txt",header=F)

 a1 <- 1*a
 b1 <- 1*b
 c1 <- 1*c
 d1 <- 1*d
 e1 <- 1*e

 x <- a1+b1+c1+d1+e1

 y <- cbind(f,x)

 write.table(y,"result11111.txt",sep="\t",col.names=F,row.names=F,quote=F)