#######################
# R script for the Treeweb       #
# cross-community analysis       #
# SI analysis                    #
#######################################

# load libraries
library(vegan)
library(plyr)
library(reshape2)
library(boot)
library(dplyr)
library(UpSetR)
library(DHARMa)
library(ade4)
library(ggplot2)
library(gridExtra)

# set working directory
setwd("~/PostDoc_Ghent/Synthesis_3/treeweb_community/")

# load plot data
plot_info <- read.csv("data/synthesis_expldata_raw.csv", stringsAsFactors = FALSE)
plot_xy <- read.csv("data/plot_xy.csv")

# load community data
comms <- c("bird", "bat", "spider", "opiliones", "carabid", "isopods", "diplopod", "herb", "vegetation")
comm_l <- lapply(comms, function(x) read.csv(paste0("data/treeweb_", x, "_format.csv")))
names(comm_l) <- comms

# remove the species with no record in the bird table
comm_l$bird <- comm_l$bird[,-which(colSums(comm_l$bird) == 0)]
# divide herbivore by sampling effort
comm_l$herb <- cbind(comm_l$herb[,1], comm_l$herb[,-1] / plot_info$specrich)
# remove genus level id in isopods
comm_l$isopods <- comm_l$isopods[,-ncol(comm_l$isopods)]

########### Part 1: RDA per trophic group ###########

# an helper function to run the RDA
# arguments are:
# @comm: a character, the name of the taxa
# @interaction: a logical, whether the include an interaction term between species composition and fragmentation
# @decostand: a logical, whether to hellinger-standardize the community data
# @species: a character, the tree species in focus
# @...: further argument to pass to the RDA, see ?rda

fit_rda <- function(comm, interaction = TRUE, decostand = TRUE, species = "qrob",...){

  print(species)
  # grab the plot index for the focal tree species
  ids <- eval(as.name(paste0("id_",species)))
  # if needed standardize
  if(decostand){
    comm <- decostand(comm, method = "hellinger", MARGIN = 1)
  }

  # compute PCNM
  rs <- rowSums(comm) / sum(comm) # the site weights
  pcnmw <- pcnm(dist(plot_xy[,c("X", "Y")]), w = rs) # PCNM based on plot coordinates
  # add the PCNM scores to the dataset
  dat <- cbind(plot_info[,c("speccomb", "fragm_std")], scores(pcnmw))
  # NA for opiliones, fix by putting PCNM to 0
  dat[is.na(dat)] <- 0
  # fit the RDA with or without interaction
  if(interaction){
    rr <- rda(comm[ids,] ~ . + speccomb : fragm_std, dat[ids,], ...)
  } else {
    rr <- rda(comm[ids,] ~ ., dat[ids,],...)
  }

  return(rr)
}

### fit the RDA
## plot id for the specific tree composition changes
id_qrob <- which(plot_info$speccomb %in% c("qrob", "fsyl_qrob","qrob_qrub", "all"))
id_qrub <- which(plot_info$speccomb %in% c("qrub", "fsyl_qrub","qrob_qrub", "all"))
id_fsyl <- which(plot_info$speccomb %in% c("fsyl", "fsyl_qrob","fsyl_qrub", "all"))
## the different tree species code
spp <- c("qrob", "qrub", "fsyl")

# go through the different communities
# with interaction
rda_l <- lapply(comm_l, function(comm) sapply(spp, function(sp) fit_rda(comm[,-1], interaction = TRUE, decostand = TRUE, species = sp),
                                              simplify = FALSE))
### analyze the results
## first table of effects
# grab the RDA results for the Table
## an helper function that grab p-values of the effects and R-square per taxa
eff_rda <- function(taxa = "bird"){
  rr <- rda_l[[taxa]]
  tmp <- ldply(rr, function(x) as.data.frame(anova(x, by = "terms", permutations = how(nperm = 9999))))
  tmp$terms <- rep(c("composition", "fragmentation", paste0("P", 1:14), "interaction", "residual"), 3)
  tmp <- filter(tmp, terms %in% c("composition", "fragmentation", "interaction"))
  tmp$taxa <- taxa

  # add R2
  tmp2 <- ldply(rr, function(x) as.data.frame(RsquareAdj(x)$adj.r.squared))
  tmp2$terms <- "R2"
  names(tmp2)[2] <- names(tmp)[5]
  tmp2$taxa <- taxa

  tmp <- rbind(tmp2, tmp[,c(1,5,6,7)])

  return(tmp)
}

# apply to all taxa
tabb <- rbind.fill(sapply(comms, function(sp) eff_rda(sp), simplify = FALSE))
# some data wraggling
tabb_w <- dcast(tabb, taxa ~ .id + terms, value.var = "Pr(>F)")
xtable(tabb_w[c(1:3,8, 7,6,4:5,9),c(1,5,2,3,4,9,6,7,8, 13, 10:12)], digits = 3)

## second, effect size of composition / fragmentation effects
# per tree diversification pathways develop indices of tree composition changes
change_qrob <- c("qrob -> qrob_fsyl", "qrob -> qrob_qrub",
                 "qrob_fsyl -> all", "qrob_qrub -> all", "qrob -> all")

change_qrub <- c("qrub -> fsyl_qrub", "qrub -> qrob_qrub",
                 "fsyl_qrub -> all", "qrob_qrub -> all", "qrub -> all")

change_fsyl <- c("fsyl -> qrob_fsyl", "fsyl -> fsyl_qrub",
                 "qrob_fsyl -> all", "fsyl_qrub -> all", "fsyl -> all")

# an helper function to get the distance between centroids of different tree composition
# and also to get the distance of changes due to the fragmentation effect
# the arguments are:
# @rr: an object of class rda, the fitted RDA from vegan
# @tree: a character, the focal tree species, like "qrob"
get_length_rda <- function(rr, tree){
  # define the composition changes
  change_comp <- eval(as.name(paste0("change_", tree)))
  # define the different composition
  change_fragm <- c(grep(tree, unique(plot_info$speccomb), value = TRUE), "all")
  # a new data frame to compute predicted shifts along the gradient of fragmentation
  newdat <- expand.grid(speccomb = change_fragm, fragm_std = c(-1.69, 2.42),
                        PCNM1 = 0, PCNM2 = 0, PCNM3 = 0, PCNM4 = 0,
                        PCNM5 = 0, PCNM6 = 0, PCNM7 = 0, PCNM8 = 0,
                        PCNM9 = 0, PCNM10 = 0, PCNM11 = 0, PCNM12 = 0,
                        PCNM13 = 0, PCNM14 = 0)
  # get the RDA centroid scores
  sc_cn <- scores(rr, choices = c(1,2), display = "cn", scaling = 0)
  # depeding on the focal tree compute the shifts in centroids
  if(tree == "qrob"){
    c1 <- dist(rbind(sc_cn[3,], sc_cn[2,]))
    c2 <- dist(rbind(sc_cn[3,], sc_cn[4,]))
    c3 <- dist(rbind(sc_cn[2,], sc_cn[1,]))
    c4 <- dist(rbind(sc_cn[4,], sc_cn[1,]))
    c5 <- dist(rbind(sc_cn[3,], sc_cn[1,]))
  }
  if(tree == "qrub"){
    c1 <- dist(rbind(sc_cn[4,], sc_cn[2,]))
    c2 <- dist(rbind(sc_cn[4,], sc_cn[3,]))
    c3 <- dist(rbind(sc_cn[2,], sc_cn[1,]))
    c4 <- dist(rbind(sc_cn[3,], sc_cn[1,]))
    c5 <- dist(rbind(sc_cn[4,], sc_cn[1,]))
  }
  if(tree == "fsyl"){
    c1 <- dist(rbind(sc_cn[2,], sc_cn[3,]))
    c2 <- dist(rbind(sc_cn[2,], sc_cn[4,]))
    c3 <- dist(rbind(sc_cn[3,], sc_cn[1,]))
    c4 <- dist(rbind(sc_cn[4,], sc_cn[1,]))
    c5 <- dist(rbind(sc_cn[2,], sc_cn[1,]))
  }
  # compute the shift along the fragmentation gradient
  sc_fragm <- predict(rr, newdata = newdat, type = "lc")
  fragm <- c(dist(sc_fragm[c(1, 5),1:2]),
             dist(sc_fragm[c(2, 6),1:2]),
             dist(sc_fragm[c(3, 7),1:2]),
             dist(sc_fragm[c(4, 8),1:2])) # if we do not restrict the dist to the first two axis we always get the same dist: 0.76

  data.frame(effect = rep(c("composition", "fragmentation"), times = c(5, 4)), change = c(change_comp, change_fragm), length = c(c1, c2, c3, c4, c5, fragm))

}

# an helper function to compute the bootstrapped shifts
# arguments are:
# @dat: a data.frame or matrix, the community data
# @id: internal argument for boot
# @N: an integer, the number of species
# @tree: a character, the focal tree species like "qrob"
boot_rda <- function(dat, id, N, tree){
  # the community data
  comm <- dat[,1:N]
  # the predicotrs
  plot_info <- dat[,(N+1):ncol(dat)]
  # standardize the community
  comm <- decostand(comm[,-1], "hellinger", MARGIN = 1)
  # run the RDA with interaction
  rr <- rda(comm[id,] ~ speccomb * fragm_std, plot_info[id,])
  # grab the effect sizes
  out <- get_length_rda(rr, tree)
  return(out$length)
}

# an helper function combining the effect computation with the bootstrapped computation
# the arguments are:
# @taxa: a character, the name of the focal taxa like "bird"
# @tree: a character, the name of the focal tree species like "qrob"
# @R: an integer, the number of bootstrap samples
get_length_df <- function(taxa = "bird", tree = "qrob", R = 10){
  print(taxa) # for debug purposes
  # grab the relevant RDA
  rr <- rda_l[[taxa]]
  # grab the relevant community matrix
  comm <- comm_l[[taxa]]
  # grab the plot index for the tree diversification pathways
  ids <- eval(as.name(paste0("id_", tree)))
  # the species numer
  n_sp <- ncol(comm)
  # put together the community and the predictor data
  boot_dat <- cbind(comm[ids,], plot_info[ids,])
  # compute the effect size
  tab <- get_length_rda(rr[[tree]], tree)
  # compute the bootstrapped effect size
  bb <- boot(data = boot_dat, statistic = boot_rda, R = R, N = n_sp, tree = tree, strata = factor(boot_dat$speccomb))
  # the bootstrapped standard deviation
  tab$std_err <- apply(bb$t, 2, sd)

  return(tab)
}

# run this for all taxa and trees
c_rob <- rbind.fill(sapply(comms, function(taxa) get_length_df(taxa = taxa, tree = "qrob", R = 10000), simplify = FALSE))
c_rub <- rbind.fill(sapply(comms, function(taxa) get_length_df(taxa = taxa, tree = "qrub", R = 10000), simplify = FALSE))
c_syl <- rbind.fill(sapply(comms, function(taxa) get_length_df(taxa = taxa, tree = "fsyl", R = 10000), simplify = FALSE))
# put everything together
c_all <- rbind(c_rob, c_rub, c_syl)
# some re-naming for the plots
c_all$tree <- rep(c("qrob", "qrub", "fsyl"), each = 81)
c_all$taxa <- rep(comms, each = 9)
c_all$taxa[c_all$taxa=="herb"] <- "herbivore"
c_all$taxa <- factor(c_all$taxa,
                     levels = c(comms[1:7], "herbivore", "vegetation"))
c_all$change <- factor(c_all$change, levels = c(change_qrob[1:2], change_qrub[1:2], change_fsyl[1:2], change_qrob[3:4], change_qrub[3], change_qrob[5], change_qrub[5], change_fsyl[5], "qrob", "fsyl", "qrub", "fsyl_qrob", "fsyl_qrub", "qrob_qrub", "all"))

# first plot on the fragmentation effect
c_fragm <- subset(c_all, effect == "fragmentation")
# the position of the bars in the graph
c_fragm$X <- c(rep(c(3, 2, 1, 4), 9), rep(c(8, 7, 6, 9), 9), rep(c(11, 12, 13, 14), 9))

# compute the average per taxa and div paths
c_fragm %>%
  group_by(taxa, tree) %>%
  summarise(avg = mean(length)) -> avg_eff
# end of the dotted average line on the graphs
avg_eff$x_start <- rep(c(10.5, 0.5, 5.5), times = 9)
avg_eff$x_end <- rep(c(14.5, 4.5, 9.5), times = 9)

# nicer name for the facets
facet_n <- c("bird" = "birds", "bat" = "bats", "spider" = "spiders",
                "opiliones" = "harvestmen", "carabid" = "carabids",
                "isopods" = "woodlice", "diplopod" = "millipedes",
                "herbivore" = "herbivores", "vegetation" = "vegetation")

# the plot
gg_f <- ggplot(c_fragm,aes(x=X, y=length, color=tree))+
  geom_bar(stat = "identity", fill = "white")+
  geom_linerange(aes(ymin=length, ymax = length + 2 * std_err))+
  scale_x_continuous(breaks = c(1:4, 6:9, 11:14), labels = c("qrob", "fsyl_qrob", "qrob_qrub", "all",
                                                             "qrub", "fsyl_qrub", "qrob_qrub", "all",
                                                             "fsyl", "fsyl_qrub", "fsyl_qrob", "all")) +
  facet_wrap(~taxa, labeller = as_labeller(facet_n)) +
  geom_segment(data = avg_eff, aes(x = x_start, xend = x_end, y = avg, yend = avg),
               size = 1, linetype = "dashed") +
  labs(x = "Diversification pathway",
       y = "Strength of fragmentation effect (95% bootstraped CI)"
       ) +
  theme(legend.position = "none", axis.text.x = element_text(angle = 90))

ggsave("figures/fragmentation_rda.png", gg_f, width = 22.77,
       height = 14.71, units = "cm")

# now the compositional change in a similar graph
c_comp <- subset(c_all, effect == "composition")
c_comp$X <- c(rep(1:5, 9), rep(7:11, 9), rep(13:17, 9))

gg_c <- ggplot(subset(c_comp, change != "fragmentation"),
               aes(x=X, y=length, group = paste0(change, tree), color = tree)) +
  geom_bar(stat = "identity", position = position_dodge(width = 0.9), fill = "white")+
  geom_linerange(aes(ymin=length, ymax = length + 2* std_err), position = position_dodge(width = 0.9))+
  facet_wrap(~taxa, labeller = as_labeller(facet_n)) +
  theme(axis.text.x = element_text(angle = 45, hjust = 0.9),
        legend.position = "none") +
  scale_x_continuous(breaks= c(1:5, 7:11, 13:17), labels = subset(c_comp, taxa == "bird")$change) +
  labs(x = "Diversification pathway",
       y = "Strength of diversification effect (95% bootstraped CI)")

ggsave("figures/composition_rda.png", gg_c, width = 22.77,
       height = 14.71, units = "cm")

########### Part 2: compositional turnover across groups, using upset graphs #####

# an helper function formatting the comminty data and outputting the desired plots
upset_comm <- function(comm){

  if(names(comm)[1] != "id_plot"){
    names(comm)[1]<- "id_plot"
  }

  #format the community
  comm %>%
    pivot_longer(cols = 2:ncol(comm), names_to = "species", values_to = "abundance") %>%
    #rename(id_plot = plot) %>%
    left_join(plot_info, by = "id_plot") %>%
    group_by(speccomb, species) %>%
    summarise(Present = sum(abundance, na.rm = TRUE)) %>%
    mutate(Present = ifelse(Present > 0, 1, 0)) %>%
    pivot_wider(names_from = speccomb, values_from = Present) -> comm_dd

  comm_dd <- as.data.frame(comm_dd)
  # one plot per diversification pathways
  u_rob <- upset(comm_dd, sets = c("qrob", "fsyl_qrob", "qrob_qrub", "all"), order.by = "freq",
                 mainbar.y.label = "Number of (shared) species", sets.x.label = "Total species\nnumber",
                 main.bar.color="#1b9e77", matrix.color="#1b9e77",
                 sets.bar.color="#d95f02")

  u_robc <- cowplot::plot_grid(NULL, u_rob$Main_bar, u_rob$Sizes, u_rob$Matrix,
                               nrow=2, align='hv', rel_heights = c(3,1),
                               rel_widths = c(2,3))

  u_rub <- upset(comm_dd, sets = c("qrub", "fsyl_qrub", "qrob_qrub", "all"), order.by = "freq",
                 mainbar.y.label = "Number of (shared) species", sets.x.label = "Total species\nnumber",
                 main.bar.color="#1b9e77", matrix.color="#1b9e77",
                 sets.bar.color="#d95f02")

  u_rubc <- cowplot::plot_grid(NULL, u_rub$Main_bar, u_rub$Sizes, u_rub$Matrix,
                               nrow=2, align='hv', rel_heights = c(3,1),
                               rel_widths = c(2,3))

  u_syl <- upset(comm_dd, sets = c("fsyl", "fsyl_qrub", "fsyl_qrob", "all"), order.by = "freq",
                 mainbar.y.label = "Number of (shared) species", sets.x.label = "Total species\nnumber",
                 main.bar.color="#1b9e77", matrix.color="#1b9e77",
                 sets.bar.color="#d95f02")

  u_sylc <- cowplot::plot_grid(NULL, u_syl$Main_bar, u_syl$Sizes, u_syl$Matrix,
                               nrow=2, align='hv', rel_heights = c(3,1),
                               rel_widths = c(2,3))

  gga <- grid.arrange(u_robc, u_rubc, u_sylc, ncol = 3)

  return(gga)
}

# run this for all taxa
ggsave("figures/upset_bird.png", upset_comm(comm_l$bird), width = 11, height = 5, units = "in")
ggsave("figures/upset_bat.png", upset_comm(comm_l$bat), width = 11, height = 5, units = "in")
ggsave("figures/upset_carabid.png", upset_comm(comm_l$carabid), width = 11, height = 5, units = "in")
ggsave("figures/upset_spider.png", upset_comm(comm_l$spider), width = 11, height = 5, units = "in")
ggsave("figures/upset_isopod.png", upset_comm(comm_l$isopods), width = 11, height = 5, units = "in")
ggsave("figures/upset_diplopod.png", upset_comm(comm_l$diplopod), width = 11, height = 5, units = "in")
ggsave("figures/upset_herbivore.png", upset_comm(comm_l$herb), width = 11, height = 5, units = "in")
ggsave("figures/upset_vegetation.png", upset_comm(comm_l$vegetation), width = 11, height = 5, units = "in")
ggsave("figures/upset_opiliones.png", upset_comm(comm_l$opiliones), width = 11, height = 5, units = "in")

########### Part 3: testing additional community webs ########

# an helper function to run the mcoa
# the arguments are:
# @web: a character, the web of interaction to quantify like "bird_bat_spider"
# @nf: an integer, the number of axis to keep
# @option: a character, the weighing used, see ?mcoa for the different options
# @std: a logical, whether to hellinger-standardize the data
mcoa_run <- function(web, nf = 2, option = "inertia", std = TRUE){
  comm_name <- strsplit(web, "_")[[1]]

  comms <- lapply(comm_name, function(x) comm_l[[x]])

  if(std){
    comms <- lapply(comms, function(comm) decostand(comm[,-1], "hellinger"))
  }

  # grab number of columns
  nb_col <- sapply(comms, function(x) ncol(x))

  # put all together
  comms_all <- do.call(cbind, comms)
  # create ktab object
  kt <- ktab.data.frame(comms_all, nb_col,
                        tabnames = comm_name)

  # run mcoa
  m <- mcoa(kt, option = option, nf = nf, scannf = FALSE)

  return(m)
}

##full web of interaction: all groups:
web_2 <- "bird_bat_spider_opiliones_carabid_isopods_diplopod_herb_vegetation"
n_taxa <- 9
m_2 <- mcoa_run(web_2)

## compute the distance of each group from the plot synthetic scores
plot_info$x <- plot_xy$X
plot_info$y <- plot_xy$Y
vhb_xy <- m_2$Tl1
vhb_xy$id_plot <- rep(1:53, n_taxa)
vhb_xy$ref_x <- m_2$SynVar[rep(1:53, n_taxa),1]
vhb_xy$ref_y <- m_2$SynVar[rep(1:53, n_taxa),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy %>%
  group_by(id_plot) %>%
  summarise(d = sum(d)) %>%
  left_join(plot_info[,c(1,13,14,15, 16, 17)], by = "id_plot") -> vhb_dd

# fit a glm to this
m_vhb <- glm(d ~ fragm_std * speccomb, vhb_dd, family = Gamma(link="log"), contrasts = list(speccomb = "contr.sum"))

## look at residuals
ss <- simulateResiduals(m_vhb)
plot(ss) # good
testSpatialAutocorrelation(ss, x = plot_info$x, y = plot_info$y) # no spatial autocorrelation

## anova
anova(m_vhb, test = "Chisq") # species composition effect

## make plot of predicted distance for the different tree composition
### a new data frame to derive the model predictions
newdat <- expand.grid(speccomb = unique(plot_info$speccomb), fragm_std = 0)

# augment per diversification path
newdat2 <- newdat[c(2, 5, 3, 4, 7, 5, 1, 4, 6, 3, 1, 4),]
newdat2$tree <- rep(c("fsyl", "qrob", "qrub"), each = 4)
# compute the model predictions
newdat2$pred <- predict(m_vhb, newdata = newdat2, type = "response")
newdat2$se <- predict(m_vhb, newdata = newdat2, type = "response", se.fit = TRUE)$se.fit

# some refinments for ordering the species somposition as we want them
newdat2$speccomb <- factor(newdat2$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))
vhb_dd$speccomb <- factor(vhb_dd$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))

# the plots
gg_syl <- ggplot(subset(vhb_dd, speccomb %in% c("fsyl", "fsyl_qrob", "fsyl_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "fsyl"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "fsyl"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("beech", "beech +\nped. oak", "beech +\nred oak", "all")) +
  labs(x = "", y = "", title = "(a)") +
  ylim(c(3.8, 10.1))

gg_rob <- ggplot(subset(vhb_dd, speccomb %in% c("qrob", "fsyl_qrob", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrob"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrob"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("ped. oak", "beech +\nped. oak", "ped. oak +\nred oak", "all")) +
  labs(x = "", y = "", title = "(b)") +
  ylim(c(3.8, 10.1))

gg_rub <- ggplot(subset(vhb_dd, speccomb %in% c("qrub", "fsyl_qrub", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrub"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrub"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  labs(x = "", y = "", title = "(c)") +
  scale_x_discrete(labels = c("red oak", "beech +\nred oak", "ped. oak +\nred oak", "all")) +
  ylim(c(3.8, 10.1))

gg_all <- grid.arrange(gg_syl, gg_rob, gg_rub, nrow = 3, bottom = "Tree species composition", left = "Community distance")

ggsave("figures/mcoa_composition_web2.png", gg_all, width = 4, height = 8)

## now only vegetation - bird - carabid - spider
web_3 <- "bird_carabid_spider_vegetation"
n_taxa <- 4
m_3 <- mcoa_run(web_3)

## compute the distance of each group from the plot synthetic scores
plot_info$x <- plot_xy$X
plot_info$y <- plot_xy$Y
vhb_xy <- m_3$Tl1
vhb_xy$id_plot <- rep(1:53, n_taxa)
vhb_xy$ref_x <- m_3$SynVar[rep(1:53, n_taxa),1]
vhb_xy$ref_y <- m_3$SynVar[rep(1:53, n_taxa),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy %>%
  group_by(id_plot) %>%
  summarise(d = sum(d)) %>%
  left_join(plot_info[,c(1,13,14,15, 16, 17)], by = "id_plot") -> vhb_dd

# fit a glm to this
m_vhb <- glm(d ~ fragm_std * speccomb, vhb_dd, family = Gamma(link="log"), contrasts = list(speccomb = "contr.sum"))

## look at residuals
ss <- simulateResiduals(m_vhb)
plot(ss) # good
testSpatialAutocorrelation(ss, x = plot_info$x, y = plot_info$y) # no spatial autocorrelation

## anova
anova(m_vhb, test = "Chisq") # species composition effect

## make plot of predicted distance for the different tree composition
### a new data frame to derive the model predictions
newdat <- expand.grid(speccomb = unique(plot_info$speccomb), fragm_std = 0)

# augment per diversification path
newdat2 <- newdat[c(2, 5, 3, 4, 7, 5, 1, 4, 6, 3, 1, 4),]
newdat2$tree <- rep(c("fsyl", "qrob", "qrub"), each = 4)
# compute the model predictions
newdat2$pred <- predict(m_vhb, newdata = newdat2, type = "response")
newdat2$se <- predict(m_vhb, newdata = newdat2, type = "response", se.fit = TRUE)$se.fit

# some refinments for ordering the species somposition as we want them
newdat2$speccomb <- factor(newdat2$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))
vhb_dd$speccomb <- factor(vhb_dd$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))

# the plots
gg_syl <- ggplot(subset(vhb_dd, speccomb %in% c("fsyl", "fsyl_qrob", "fsyl_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "fsyl"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "fsyl"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("beech", "beech +\nped. oak", "beech +\nred oak", "all")) +
  labs(x = "", y = "", title = "(a)") +
  ylim(c(0.5, 5.2))

gg_rob <- ggplot(subset(vhb_dd, speccomb %in% c("qrob", "fsyl_qrob", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrob"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrob"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("ped. oak", "beech +\nped. oak", "ped. oak +\nred oak", "all")) +
  labs(x = "", y = "", title = "(b)") +
  ylim(c(0.5, 5.2))

gg_rub <- ggplot(subset(vhb_dd, speccomb %in% c("qrub", "fsyl_qrub", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrub"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrub"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  labs(x = "", y = "", title = "(c)") +
  scale_x_discrete(labels = c("red oak", "beech +\nred oak", "ped. oak +\nred oak", "all")) +
  ylim(c(0.5, 5.2))

gg_all <- grid.arrange(gg_syl, gg_rob, gg_rub, nrow = 3, bottom = "Tree species composition", left = "Community distance")

ggsave("figures/mcoa_composition_web3.png", gg_all, width = 4, height = 8)

##### Part 4: Co-inertia analysis with new groupings ######

# define 5 groups, herbivores, primary producers, predators, detritivores and omnivores
comm_l$primary <- comm_l$vegetation
comm_l$herbivore <- comm_l$herb
comm_l$detritivore <- cbind(comm_l$isopods, comm_l$diplopod[,-1])
comm_l$omnivore <- cbind(comm_l$carabid, comm_l$opiliones[,-1], comm_l$bird[,-1])
comm_l$predator <- cbind(comm_l$bat, comm_l$spider[,-1])

# all potential pairs of communities
comms2 <- c("primary", "herbivore", "detritivore", "omnivore", "predator")
pairs2 <- outer(comms2, comms2, paste, sep = "_")
pairs_u2 <- pairs2[upper.tri(pairs2)]

# define the trophic levels
tl2 <- data.frame(taxa = comms2,
                 tl = c(1, 2, 2, 3, 4))

# put all pairs in a data frame together with their trophic distance
pairs_d2 <- data.frame(pairs = pairs_u2, stringsAsFactors = FALSE)
pairs_d2 <- separate(pairs_d2, "pairs", c("from", "to"), sep = "_", remove = FALSE)

pairs_d2 <- merge(pairs_d2, tl2, by.x = "from", by.y = "taxa", sort = FALSE)
pairs_d2 <- merge(pairs_d2, tl2, by.x = "to", by.y = "taxa", sort=FALSE)
pairs_d2$dist <- with(pairs_d2, sqrt((tl.x - tl.y)**2))

## get percent explained variation of the first two axis in the coinertia
tt2 <- sapply(pairs_u2, function(x) get_percent_explained(x))

# RV value between each comms
rv_all2 <- sapply(pairs_u2, function(x) get_coia_rv(x, nrepet = 9999), simplify = FALSE) # this can take time to run depending on the number of repetitions
# some data wraggling to put te results in a plotable format
rv_all2 <- rbind.fill(rv_all2)
rv_all2$pair <- pairs_u2
rv_all2 <- merge(rv_all2, pairs_d2, by.x = "pair", by.y = "pairs")
rv_all2 <- arrange(rv_all2, dist, pair)

# plot
rv_all2 <- unite(rv_all2, "pair", c(to, from), sep =":")
rv_all2$pair <- factor(rv_all2$pair)
rv_all2$x <- 1:10

# the plot (figure X in the manuscript)
gg_rv2 <- ggplot(rv_all2, aes(x=x, y=rv, fill=col)) +
  geom_bar(stat = "identity", width = 0.75) +
  scale_fill_brewer(type = "qual",palette = "Set1",
                    labels = c("no sig. relation", "sig. relation"),
                    name = "RV permutation\ntest:") +
  scale_x_continuous(breaks = 1:10, labels = rv_all2$pair, expand = c(0, 0)) +
  scale_y_continuous(limits = c(0, 0.6), expand = c(0, 0)) +
  coord_flip() +
  theme(axis.text.x = element_text(hjust = 0),
        axis.text.y = element_text(vjust = 0.25)) +
  labs(x = "Pairwise community comparison",
       y = "RV value") +
  theme_bw()

ggsave("figures/coin_rv_feeding.png", gg_rv2)

# multiple COIA

## first web of interaction: all groups except for the bats:
web_1 <- "primary_herbivore_detritivore_omnivore_predator"
m_1 <- mcoa_run(web_1)

## compute the distance of each group from the plot synthetic scores
plot_info$x <- plot_xy$X
plot_info$y <- plot_xy$Y
vhb_xy <- m_1$Tl1
vhb_xy$id_plot <- rep(1:53, length(web_1))
vhb_xy$ref_x <- m_1$SynVar[rep(1:53, length(web_1)),1]
vhb_xy$ref_y <- m_1$SynVar[rep(1:53, length(web_1)),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy %>%
  group_by(id_plot) %>%
  summarise(d = sum(d)) %>%
  left_join(plot_info[,c(1,13,14,15, 16, 17)], by = "id_plot") -> vhb_dd

# fit a glm to this
m_vhb <- glm(d ~ fragm_std * speccomb, vhb_dd, family = Gamma(link="log"), contrasts = list(speccomb = "contr.sum"))

## look at residuals
ss <- simulateResiduals(m_vhb)
plot(ss) # good
testSpatialAutocorrelation(ss, x = plot_info$x, y = plot_info$y) # no spatial autocorrelation

## anova
anova(m_vhb, test = "Chisq")
## the plot of composition effects
newdat <- expand.grid(speccomb = unique(plot_info$speccomb), fragm_std = 0)

# augment per diversification path
newdat2 <- newdat[c(2, 5, 3, 4, 7, 5, 1, 4, 6, 3, 1, 4),]
newdat2$tree <- rep(c("fsyl", "qrob", "qrub"), each = 4)
# compute the model predictions
newdat2$pred <- predict(m_vhb, newdata = newdat2, type = "response")
newdat2$se <- predict(m_vhb, newdata = newdat2, type = "response", se.fit = TRUE)$se.fit

# some refinments for ordering the species somposition as we want them
newdat2$speccomb <- factor(newdat2$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))
vhb_dd$speccomb <- factor(vhb_dd$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))

# the plots
gg_syl <- ggplot(subset(vhb_dd, speccomb %in% c("fsyl", "fsyl_qrob", "fsyl_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "fsyl"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "fsyl"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("beech", "beech +\nped. oak", "beech +\nred oak", "all")) +
  labs(x = "", y = "", title = "(a)") +
  ylim(c(1.6, 6.2))

gg_rob <- ggplot(subset(vhb_dd, speccomb %in% c("qrob", "fsyl_qrob", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrob"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrob"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("ped. oak", "beech +\nped. oak", "ped. oak +\nred oak", "all")) +
  labs(x = "", y = "", title = "(b)") +
  ylim(c(1.6, 6.2))

gg_rub <- ggplot(subset(vhb_dd, speccomb %in% c("qrub", "fsyl_qrub", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrub"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrub"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  labs(x = "", y = "", title = "(c)") +
  scale_x_discrete(labels = c("red oak", "beech +\nred oak", "ped. oak +\nred oak", "all")) +
  ylim(c(1.6, 6.2))

gg_all <- grid.arrange(gg_syl, gg_rob, gg_rub, nrow = 3, bottom = "Tree species composition", left = "Community distance")

ggsave("figures/mcoa_composition_feeding.png", gg_all, width = 4, height = 8)

##### Part 5: Fourth corner analysis #######

# explore trait-environment relation via a fourth corner analysis
# load traits data
ff <- list.files("data/", pattern = "_trait")
traits_l <- lapply(ff, function(x) read.csv(paste0("data/", x)))
names(traits_l) <- gsub("_traits.csv", "", ff)

# some refinments, per taxa especiallymaking sure that species order is the
# same between the trait table and the community matrix
traits_l$bat$body_size <- with(traits_l$bat, (body_size_min + body_size_max) / 2)
traits_l$bat$forest_affinity <- factor(traits_l$bat$forest_affinity)
traits_l$bat <- traits_l$bat[,c(1, 5, 4)]
traits_l$bird$forest_affinity <- factor(traits_l$bird$forest_affinity)
traits_l$bird <- traits_l$bird[traits_l$bird$species %in%colnames(comm_l$bird),]
traits_l$carabid <- traits_l$carabid[order(traits_l$carabid$species),]
traits_l$carabid$dispersal <- factor(traits_l$carabid$dispersal)
comm_l$carabid <- comm_l$carabid[,c(1, order(colnames(comm_l$carabid[,-1])) + 1)]
comm_l$spider <- comm_l$spider[,c(1, order(colnames(comm_l$spider[,-1])) + 1)]
traits_l$diplopod <- traits_l$diplopod[order(traits_l$diplopod$species),]
traits_l$diplopod$forest_affinity <- factor(traits_l$diplopod$forest_affinity)
comm_l$diplopod <- comm_l$diplopod[,c(1, order(colnames(comm_l$diplopod[,-1])) + 1)]
traits_l$vegetation <- traits_l$vegetation[which(!is.na(traits_l$vegetation$height) & traits_l$vegetation$forest_affinity != ""),]
for(i in 2:ncol(comm_l$vegetation)){
  colnames(comm_l$vegetation)[i] <- as.character(tt_d$species_scientific[colnames(comm_l$vegetation)[i] == tt_d$n])
}
comm_l$vegetation <- comm_l$vegetation[,c(1, order(colnames(comm_l$vegetation[,-1])) + 1)]
comm_l$vegetation <- comm_l$vegetation[,c(1, which(colnames(comm_l$vegetation) %in% traits_l$vegetation$species))]
names(comm_l)[6] <- "isopod"

## an helper function
do_fourthcorner <- function(comm, ...){
  spe <- comm_l[[comm]][,-1]

  trait <- traits_l[[comm]][,2:3]

  envs <- plot_info[,c("speccomb", "fragm_std")]
  envs$speccomb <- factor(envs$speccomb)

  four <- fourthcorner(envs, spe, trait, ...)

  cat(paste0(comm, " is done!\n"))

  return(four)
}

fourth_l <- lapply(names(traits_l), function(comm) do_fourthcorner(comm,
                                                                   modeltype = 6,
                                                                   nrepet = 9999))
png("figures/fourth_corner.png", width = 800, height = 800)
par(mfrow = c(3, 3))
for(i in 1:8){
  plot(fourth_l[[i]])
  mtext(names(traits_l)[i], line = 2, adj = 0)
}
dev.off()

############ Part 6: compute sample coverage and diversity metrics

# compute sample coverage
library(iNEXT)

get_coverage <- function(comm){

  cc <- comm_l[[comm]]
  # remove plot id
  cc <- cc[,-1]
  # remove plots with no species
  cc <- cc[rowSums(cc) > 0,]
  # remove plots with only one species
  cc <- cc[apply(cc, 1, function(x) sum(x > 0)) != 1,]

  # get iNext
  ii <- iNEXT(t(cc), q = 0, datatype = "abundance", knots = 2)

  return(mean(ii$DataInfo$SC))

}

lapply(comms[-c(2, 9)], function(x) get_coverage(x))

# get plot of tightness vs diversity
library(tidyr)
get_div <- function(x){

  rich <- sum(x > 0, na.rm = TRUE)
  p <- x / sum(x, na.rm = TRUE)
  sha <- exp(- sum(p * log(p), na.rm = TRUE))
  simp <- 1 / sum(p ** 2)

  out <- data.frame(rich = rich, sha = sha, simp = simp)

  return(out)
}

dd <- ldply(comm_l, function(x) {
  out <- adply(x, 1, get_div, .expand = FALSE)
})

dd %>%
  pivot_longer(3:5, names_to = "index") %>%
  rename(id_plot = X1) %>%
  left_join(vhb_dd[,1:2]) -> dd_d

ggplot(dd_d, aes(x=d, y=value)) +
  stat_smooth(method = "lm", se = FALSE) +
  geom_point() +
  facet_grid(.id ~ index)

dd_d %>%
  group_by(.id, index) %>%
  summarise(R = cor(value, d)) %>%
  arrange(desc(R)) -> cc


#CIEISP 2007
#http://www.pfp.gob.mx/portalWebApp/ShowBinary?nodeId=/BEA%20Repository/368010//archivo

#CIESIP 2006
#http://www.ssp.gob.mx/portalWebApp/ShowBinary?nodeId=/BEA%20Repository/368009//archivo

#CIEISP 2005
#http://www.ssp.gob.mx/portalWebApp/ShowBinary?nodeId=/BEA%20Repository/368008//archivo

m07 <- c(44, 33, 61, 50, 41, 40, 51, 38, 42, 47, 38, 42)
m06 <- c(47, 36, 40, 46, 55, 44, 55, 88, 58, 65, 60, 67)
m05 <- c(33, 37, 40, 35, 38, 32, 39, 22, 34, 37, 39, 41)

source("library/utilities.r")
source("timelines/constants.r")
hom <- read.csv(bzfile("timelines/data/county-month-gue-oax.csv.bz2"))
hom <- cleanHom(hom)
hom$County <- factor(cleanNames(hom, "County"))
hom <- subset(hom, County == "Michoacán" &
                   Year.of.Murder >= 2005 &
                   Year.of.Murder <= 2007)

mich.hom <- data.frame(tot = c(m05,m06,m07, hom$Total.Murders),
           type = rep(c("SNSP", "INEGI"), each=12*3),
           month = rep(1:12),
           year = rep(2005:2007, each = 12))
mich.hom$Date <-  as.Date(paste(mich.hom$year, mich.hom$month, "15"),
                          "%Y%m%d")

Cairo(file = "CIEISP/output/michoacan.png", width=700, height=400)
print(ggplot(mich.hom, aes(as.Date(Date), tot, group = type,
                     color = type)) +
    geom_line(size = 1.2) +
    scale_x_date() +
    xlab("") + ylab("Monthly number of homicides") +
    opts(title="Differences in homicides in Michoacan") +
    geom_vline(aes(xintercept = op.mich), alpha = .7) +
    annotate("text", x = op.mich, y = 20,  hjust = 1.01, vjust = 0,
             label="Joint Operation Michoacan", ))
dev.off()


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' To perform GWAS with GLM and MLM model and get the P value of SNPs
#'
#' Build date: Aug 30, 2016
#' Last update: Aug 30, 2016
#'
#' @author Lilin Yin and Xiaolei Liu
#'
#' @param phe phenotype, n * 2 matrix
#' @param geno genotype, m * n, m is marker size, n is population size
#' @param K Kinship, Covariance matrix(n * n) for random effects; must be positive semi-definite
#' @param eigenK list of eigen Kinship
#' @param CV covariates
#' @param REML a list that contains ve and vg
#' @param cpu number of cpus used for parallel computation
#' @param vc.method the methods for estimating variance component("emma" or "he" or "brent")
#' @param verbose whether to print detail.
#'
#' @return
#' results: a m * 2 matrix, the first column is the SNP effect, the second column is the P values
#' @export
#'
#' @examples
#' phePath <- system.file("extdata", "07_other", "mvp.phe", package = "rMVP")
#' phenotype <- read.table(phePath, header=TRUE)
#' idx <- !is.na(phenotype[, 2])
#' idx <- !is.na(phenotype[, 2])
#' phenotype <- phenotype[idx, ]
#' print(dim(phenotype))
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' genotype <- deepcopy(genotype, cols=idx)
#' print(dim(genotype))
#' K <- MVP.K.VanRaden(genotype)
#'
#' mlm <- MVP.MLM(phe=phenotype, geno=genotype, K=K)
#' str(mlm)
#'

MVP.MLM <-
function(
    phe,
    geno,
    K=NULL,
    eigenK=NULL,
    CV=NULL,
    REML=NULL,
    cpu=1,
    vc.method=c("BRENT", "EMMA", "HE"),
    verbose=TRUE
){
    # R.ver <- Sys.info()[['sysname']]
    # r.open <- eval(parse(text = "!inherits(try(Revo.version,silent=TRUE),'try-error')"))

    # if (R.ver == 'Windows') cpu <- 1
    # if (r.open && cpu > 1 && R.ver == 'Darwin') {
    #     Sys.setenv("VECLIB_MAXIMUM_THREADS" = "1")
    # }

    vc.method <- match.arg(vc.method)
    n <- ncol(geno)
    m <- nrow(geno)
    ys <- as.numeric(as.matrix(phe[,2]))

    if(!is.big.matrix(geno))    stop("genotype should be in 'big.matrix' format.")
    if(sum(is.na(ys)) != 0) stop("NAs are not allowed in phenotype.")
    if(nrow(phe) != ncol(geno)) stop("number of individuals not match in phenotype and genotype.")

    if(is.null(K)){
        if(vc.method == "EMMA" | vc.method == "he")  stop("Kinship must be provided!")
        if(vc.method == "BRENT"){
            if(is.null(eigenK)) stop("eigenK must be provided!")
        }
    }else{
        # convert K to base:matrix
        K <- K[, ]
        if(is.null(eigenK)){
            logging.log("Eigen Decomposition on GRM", "\n", verbose = verbose)
            eigenK <- eigen(K, symmetric=TRUE)
        }
    }

    if (is.null(CV)) {
        X0 <- matrix(1, n)
    } else {
        CV.index <- apply(CV, 2, function(x) length(table(x)) > 1)
        CV <- CV[, CV.index, drop=FALSE]
        X0 <- cbind(matrix(1, n), CV)
    }
    X0 <- as.matrix(X0)

    if(is.null(REML)) {
        logging.log(paste("Variance components using: ", vc.method, sep=""), "\n", verbose = verbose)
        if (vc.method == "EMMA") REML <- MVP.EMMA.Vg.Ve(y=ys, X=X0, K=K)
        if (vc.method == "HE") REML <- MVP.HE.Vg.Ve(y=ys, X=X0, K=K)
        if (vc.method == "BRENT") REML <- MVP.BRENT.Vg.Ve(y=ys, X=X0, eigenK=eigenK)
        logging.log(paste("Estimated Vg and Ve: ", sprintf("%.6f", REML$vg), " ", sprintf("%.6f", REML$ve), sep=""), "\n", verbose = verbose)
    }else{
        logging.log(paste("Provided Vg and Ve: ", sprintf("%.6f", REML$vg), " ", sprintf("%.6f", REML$ve), sep=""), "\n", verbose = verbose)
    }
    if(!is.null(K)){rm(K); gc()}

    ves <- REML$ve
    vgs <- REML$vg
    lambda <- ves/vgs

    U <- eigenK$vectors * matrix(sqrt(1/(eigenK$values + lambda)), n, length(eigenK$values), byrow=TRUE); rm(eigenK); gc()

    logging.log("scanning...\n", verbose = verbose)
    mkl_env({
        results <- mlm_c(y = ys, X = X0, U = U, vgs = vgs, geno@address, verbose = verbose, threads = cpu)
    })

    return(results)
}#end of MVP.MLM function


#MR id -> complications
#ml GCC/8.2.0  OpenMPI/3.1.4 Intel/2019.1.144  IntelMPI/2018.4.274 R/3.6.0

library('MendelianRandomization')
library('ggplot2')

anno<-read.table('/data/c***/z***/anno/gencode/37/gencode.v32.GRCh37.txt',header = T,stringsAsFactors = F)

info<-read.table('/data/g***/z***/hihost_gwas/mr_id_complications/top.txt',header = T,stringsAsFactors = F,sep='\t')

info<-merge(info,anno[,c('genename','chr','left','right')],by=1)
info$chr=sub('chr','',info$chr)

p_cutoff=1e-5

#top ranked genes
info<-read.table('/data/g***/z***/hihost_gwas/mr_id_complications/top.txt',header = T,stringsAsFactors = F,sep='\t')
info<-merge(info,anno[,c('genename','chr','left','right')],by=1)
info$chr=sub('chr','',info$chr)

for(i in 1:nrow(info)){
  exp_phecode=paste0('X',info[i,'exp_phecode'])
  outcome_phecode=paste0('X',info[i,'outcome_phecode'])

  #plink clumping
  cmd=paste0('plink --bfile /data/g***/z***/biovu/23k/geno/ea --clump /data/g***/z***/hihost_gwas/asso/',exp_phecode,'.txt.gz --clump-field P --clump-p1 ',p_cutoff,' --clump-r2 0.01 --out /data/g***/z***/hihost_gwas/mr_id_complications/tmp/',exp_phecode,'_',p_cutoff)
  #system(cmd,wait = T)

  #load clumped snps
  clumped<-read.table(paste0('/data/g***/z***/hihost_gwas/mr_id_complications/tmp/',exp_phecode,'_',p_cutoff,'.clumped'),header = T,stringsAsFactors = F)

  #load exp gwas
  exp<-read.table(paste0('/data/g***/z***/hihost_gwas/asso/',exp_phecode,'.txt.gz'),header = T,stringsAsFactors = F)
  exp<-exp[(exp$SNP %in% clumped$SNP),]
  exp$beta_exp=log(exp$OR,2.718)
  exp$se_exp=exp$beta_exp/exp$Z_STAT
  exp<-exp[,c('SNP','A1','beta_exp','se_exp')]
  colnames(exp)<-c('SNP','eff_exp','beta_exp','se_exp')

  #load outcome gwas
  outcome<-read.table(paste0('/data/g***/z***/hihost_gwas/asso/',outcome_phecode,'.txt.gz'),header = T,stringsAsFactors = F)
  outcome$beta_outcome=log(outcome$OR,2.718)
  outcome$se_outcome=outcome$beta_outcome/outcome$Z_STAT
  outcome<-outcome[,c('SNP','A1','beta_outcome','se_outcome')]

  df<-merge(exp,outcome,by='SNP')

  #rm na
  df<-df[!is.na(df$beta_exp+df$beta_outcome),]

  #harmonize
  df$beta_outcome=ifelse(df$eff_exp==df$A1,df$beta_outcome,df$beta_outcome*-1)

  #flip the allele
  df$beta_outcome=ifelse(df$beta_exp>0,df$beta_outcome,df$beta_outcome*-1)
  df$beta_exp=abs(df$beta_exp)

  info[i,paste0('n_SNPs_allgenes_p_cutoff_',p_cutoff)]<-nrow(df)
  if(nrow(df)<3){next}

  #mr weighted median
  ans_median_weighted<-mr_median(mr_input(bx = df$beta_exp, bxse = df$se_exp, by = df$beta_outcome, byse = df$se_outcome),weighting = "weighted", iterations = 100)

  info[i,paste0('median_weighted_allgenes_p_cutoff_',p_cutoff,'_beta')]<-ans_median_weighted@Estimate
  info[i,paste0('median_weighted_allgenes_p_cutoff_',p_cutoff,'_pvalue')]<-ans_median_weighted@Pvalue

  #mr egger
  ans_egger<-try(mr_egger(mr_input(bx = df$beta_exp, bxse = df$se_exp, by = df$beta_outcome, byse = df$se_outcome),alpha=0.05))
  if('try-error' %in% class(ans_egger)){next}
  info[i,paste0('egger_allgenes_p_cutoff_',p_cutoff,'_beta')]<-ans_egger@Estimate
  info[i,paste0('egger_allgenes_p_cutoff_',p_cutoff,'_pvalue')]<-ans_egger@Pvalue.Est

  #generate scatter plot

  png(paste0('/data/g***/z***/hihost_gwas/mr_id_complications/plot/expo_',info[i,'exp_phecode'],'_outcome_',info[i,'outcome_phecode'],'.png'),width = 1500,height = 1500,res=400)

  scatter_p<-ggplot(df, aes(x=beta_exp, y=beta_outcome)) +
    geom_errorbar(aes(ymin=beta_outcome-se_outcome*1.96, ymax=beta_outcome+se_outcome*1.96),size=0.05,color='ivory3') +
    geom_errorbarh(aes(xmin=beta_exp-se_exp*1.96, xmax=beta_exp+se_exp*1.96),size=0.05,color='ivory3') +
    geom_point(size=1.5,color='dodgerblue4') +
    xlab(paste0("Effect size of SNP-Exposure \n",info[i,'exp_trait'])) +
    ylab(paste0("Effect size of SNP-Outcome \n",info[i,'outcome_trait']))+
    theme_classic()
  #xlim(-0.5,3)
  print(scatter_p)
  dev.off()

}

write.table(info,paste0('/data/g***/z***/hihost_gwas/mr_id_complications/result/allgenes_',p_cutoff,'.txt'),quote = F,sep='\t',row.names = F)


# Yuan Yuan, 2015-02-06
# This script check balance after propensity weighting

check.balance <- function(index.tr,index.ctr, X1, wt, printout=FALSE)
    {
        mean.tr <- sum(wt[index.tr]*X1[index.tr])/sum(wt[index.tr])
        sd.tr <- sum(wt[index.tr]*(X1[index.tr]-mean(X1[index.tr]))^2)/(sum(wt[index.tr])-1)
        mean.ctr <- sum(wt[index.ctr]*X1[index.ctr])/sum(wt[index.ctr])
        sd.ctr <- sum(wt[index.ctr]*(X1[index.ctr]-mean(X1[index.ctr]))^2)/(sum(wt[index.ctr])-1)

        std.diff <- abs(mean.tr-mean.ctr)/sqrt((sd.tr+sd.ctr)/2)
        if(printout)
            {
                print(std.diff)
            }
        return(std.diff)
    }


full_algorithm <- function(Kc, Kr, S0, S1, MW, wt, minimum_threshold) {
    # Two-way Tanimoto Algorithm
    # ===========================

    # Parameters:
    #   Kc  Integer, how many neighbors to select for consumers
    #   Kr  Integer, how many neighbors to select for resources
    #   S0  A large set of species and their preys, with column structure ['taxon', 'taxonomy', 'resource', 'non-resource']
    #   S1  The subset of S0 where we want to predict new preys, string vector with taxa name
    #   MW  Mimimum weight to accept a candidate as a prey

    # Output
    #   A vector of sets (the preys for each species)

    predictions <- matrix(nrow = length(S1), ncol = 3, data = "", dimnames = list(c(S1), c('consumer','resource_empirical','resource_predictions'))) # empty object for resource predictions
    predictions[, 'consumer'] <- S1

    pb <- txtProgressBar(min = 0,max = length(S1), style = 3)
    for(i in 1:length(S1)) { # loop through each taxon in S1
        candidates <- matrix(nrow = 0, ncol = 2, dimnames = list(c(), c('resource', 'weight')), data = NA) # empty matrix for resource candidate list for S1[i], with taxon name and weight
        resources.S1 <- unlist(strsplit(S0[S1[i], 'resource'], " \\|\\ ")) # resources of S1[i]

        # Add resources that are already listed as resources for S1[i] in predictions[, 'resource_empirical'] or
        # Find similar resources to resources for S1[i] in S1
        if(length(resources.S1) > 0) {
            empirical <- character()
            for(j in 1:length(resources.S1)) { #loop through empirical resources for S1
                if(resources.S1[j] %in% S1) {
                    empirical <- c(empirical, resources.S1[j]) # observed resource found in S1 are automatically added to the column resource_empirical
                } else { # selecting Kr most similar resources in S1
                    # Let's assume for this part that we are not compiling a different similarity measure for predators and preys.

                    similarity.resources <- similarity_full_algorithm(S0 = unique(S0[which(S0[, 'taxon'] %in% S1 | S0[, 'taxon'] == resources.S1[j]), ]), # S1 in S0 + resource for which similarity has to be measured
                                                                    S1 = resources.S1[j], # resource for which similarity has to be measured
                                                                    wt = wt,
                                                                    taxa = 'resource')

                    similar.resource <- matrix(nrow = nrow(similarity.resources), ncol = 2, dimnames = list(c(), c('resource','similarity')), data = NA) # importing K nearest neighbors resources
                    similar.resource[, 'resource'] <- names(similarity.resources[order(similarity.resources, decreasing = TRUE), ])
                    similar.resource[, 'similarity'] <- similarity.resources[order(similarity.resources, decreasing = TRUE)]
                    to.remove <- which(similar.resource[,'resource'] == resources.S1[j])
                    if(length(to.remove) > 0){ #remove resoures.S1[j] in case it gets through (just keeping it consistant with other similarity evaluation further down in the catalogue, even though it is not necessary in this portion)
                        similar.resource <- similar.resource[-which(similar.resource[,'resource'] == resources.S1[j]), ]
                    }

                    # If multiple taxa with same similarity, randomly select those that will be used as similar resources.
                    if(similar.resource[Kr+1, 'similarity'] == similar.resource[Kr, 'similarity']) {
                        same.similarity <- which(similar.resource[, 'similarity'] == similar.resource[Kr, 'similarity'])
                        similar.resource[same.similarity, ] <- similar.resource[sample(same.similarity), ]
                        similar.resource <- similar.resource[1:Kr, ]
                    } else {
                        similar.resource <- similar.resource[1:Kr, ]
                    }# if for random draw

                    for(l in 1:Kr) { # extracting resource candidates
                        if(all.equal(similar.resource[, 'similarity'], rep('0',Kr)) == TRUE) { # if similarities all == 0, break
                            break
                        } else if(similar.resource[l, 'similarity'] == '0') { # if similarity l == 0, no candidates provided
                            NULL
                            # minimum threshold try.. adding it as a Parameters.. might not make sense, have to discuss it. If we keep it, previous else ifs can be removed
                        } else if(similar.resource[l, 'similarity'] < minimum_threshold) {
                            NULL
                        } else if((similar.resource[l, 'resource'] %in% candidates[, 'resource']) == TRUE) { # if candidate is already in candidate list, add resource' with wt to its weight
                          candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight'] <- as.numeric(candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight']) + as.numeric(similar.resource[l, 'similarity'])
                        } else {
                              candidates <- rbind(candidates, similar.resource[l, ]) # if candidate is not in the list, add it resource' with wt to its weight
                        }#if3
                    }#l
                }#if
            }#j
            predictions[S1[i], 'resource_empirical'] <- paste(empirical, collapse = ' | ')
        }#if1

        # Identify similar consumers to S1[i]

        similarity.consumers <- similarity_full_algorithm(S0 = S0,
                                                        S1 = S1[i],
                                                        wt = wt,
                                                        taxa = 'consumer')

        similar.consumer <- matrix(nrow = nrow(similarity.consumers), ncol = 2, dimnames = list(c(), c('consumer','similarity')), data = NA) # importing K nearest neighbors consumers
        similar.consumer[, 'consumer'] <- names(similarity.consumers[order(similarity.consumers, decreasing = TRUE), ])
        similar.consumer[, 'similarity'] <- similarity.consumers[order(similarity.consumers, decreasing = TRUE)]
        to.remove <- which(similar.consumer[,'consumer'] == S1[i])
        if(length(to.remove) > 0){ #remove resoures.S1[j] in case it gets through (just keeping it consistant with other similarity evaluation further down in the catalogue, even though it is not necessary in this portion)
            similar.consumer <- similar.consumer[-which(similar.consumer[,'consumer'] == S1[i]), ]
        }

        # If multiple taxa with same similarity, randomly select those that will be used as similar resources.
        if(similar.consumer[Kc+1, 'similarity'] == similar.consumer[Kc, 'similarity']) {
            same.similarity <- which(similar.consumer[, 'similarity'] == similar.consumer[Kc, 'similarity'])
            similar.consumer[same.similarity, ] <- similar.consumer[sample(same.similarity), ]
            similar.consumer <- similar.consumer[1:Kc, ]
        } else {
            similar.consumer <- similar.consumer[1:Kc, ]
        }# if for random draw

        # Est-ce que la valeur de similarité a de l'importance pour l'attribution des proies?
        # If yes, we could add an argument call wt_predator.
          # if(wt_predator == FALSE) {
          #   resources <- unique of all prey species of all similar predators
          # } else {}

        for(j in 1:Kc) { #loop through consumers

            if(all.equal(similar.consumer[, 'similarity'], rep('0',Kc)) == TRUE) { # if similarities all == 0, break
                break
            } else if(similar.consumer[j, 'similarity'] == '0') { # if similarity l == 0, no candidates provided
                NULL
            } else if(similar.consumer[j, 'similarity'] < minimum_threshold) {
                NULL
            } else {

                # It's possible that consumers in the list have high taxonomic similarity, but no recorded resource
                candidate.resource <- unlist(strsplit(S0[similar.consumer[j, 'consumer'], 'resource'], " \\|\\ ")) # list of resources for consumer j
                # candidate.resource <- candidate.resource[(candidate.resource %in% resources.S1) == FALSE] # substracting candidate resources that are already listed as resources for S1[i] and hence considered in the preceding code segment

                for(k in 1:length(candidate.resource)) { # loop through resources of consumer j
                    if(length(candidate.resource) == 0) { # if candidate resource list is empty, break
                        break
                    } else if(candidate.resource[1] == "") { # if candidate list is an empty vector "", break
                        break
                    } else if(candidate.resource[k] == S1[i]) {
                    #   #// FIXME: if candidate resource is taxon for which predictions are being made, break (unless we want to allow CANIBALISM). Add argument for cannibalism allowed or not
                         NULL
                    } else if((candidate.resource[k] %in% S1) == TRUE) {
                        if((candidate.resource[k] %in% candidates[, 'resource']) == TRUE) {# if candidate is already in candidate list, add 1 to its weight
                            candidates[which(candidates[, 'resource'] == candidate.resource[k]), 'weight'] <- as.numeric(candidates[which(candidates[, 'resource'] == candidate.resource[k]), 'weight']) + 1
                        } else {
                            candidates <- rbind(candidates, c(candidate.resource[k], 1)) # if candidate is not in the list, add it with 1 to its weight
                        }#if2

                    } else {
                        similarity.resources <- similarity_full_algorithm(S0 = unique(S0[which(S0[, 'taxon'] %in% S1 | S0[, 'taxon'] == candidate.resource[k]), ]), # S1 in S0 + resource for which similarity has to be measured
                                                                        S1 = candidate.resource[k], # resource for which similarity has to be measured
                                                                        wt = wt,
                                                                        taxa = 'resource')

                        similar.resource <- matrix(nrow = nrow(similarity.resources), ncol = 2, dimnames = list(c(), c('resource','similarity')), data = NA) # importing K nearest neighbors resources
                        similar.resource[, 'resource'] <- names(similarity.resources[order(similarity.resources, decreasing = TRUE), ])
                        similar.resource[, 'similarity'] <- similarity.resources[order(similarity.resources, decreasing = TRUE)]
                        to.remove <- which(similar.resource[,'resource'] == candidate.resource[k])
                        if(length(to.remove) > 0){ #remove resoures.S1[j] in case it gets through (just keeping it consistant with other similarity evaluation further down in the catalogue, even though it is not necessary in this portion)
                            similar.resource <- similar.resource[-which(similar.resource[,'resource'] == candidate.resource[k]), ]
                        }

                        # If multiple taxa with same similarity, randomly select those that will be used as similar resources.
                        if(similar.resource[Kr+1, 'similarity'] == similar.resource[Kr, 'similarity']) {
                            same.similarity <- which(similar.resource[, 'similarity'] == similar.resource[Kr, 'similarity'])
                            similar.resource[same.similarity, ] <- similar.resource[sample(same.similarity), ]
                            similar.resource <- similar.resource[1:Kr, ]
                        } else {
                            similar.resource <- similar.resource[1:Kr, ]
                        }# if for random draw

                        for(l in 1:Kr) { # extracting resource candidates
                            if(all.equal(similar.resource[, 'similarity'], rep('0',Kr)) == TRUE) { # if similarities all == 0, break
                                break
                            } else if(similar.resource[l, 'similarity'] == '0') { # if similarity l == 0, no candidates provided
                                NULL
                                # minimum threshold try.. adding it as a Parameters.. might not make sense, have to discuss it. If we keep it, previous else ifs can be removed
                            } else if(similar.resource[l, 'similarity'] < minimum_threshold) {
                                NULL
                            } else if((similar.resource[l, 'resource'] %in% candidates[, 'resource']) == TRUE) { # if candidate is already in candidate list, add 1 to its weight
                              candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight'] <- as.numeric(candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight']) + as.numeric(similar.resource[l, 'similarity'])
                            } else {
                                  candidates <- rbind(candidates, similar.resource[l, ]) # if candidate is not in the list, add it with its weight = similarity
                            }#if3
                        }#l
                    } #if1
                }#k
            }#if
        }#j

        candidates <- candidates[which(candidates[, 'weight'] >= MW), ] # remove candidates with a weight below MW
        if(is.matrix(candidates) == TRUE) { #if it's a vector, there's only one predicted resource, no need to order
            candidates[order(candidates[, 'weight']), ] # sorts candidates according to their weight
            predictions[S1[i], 'resource_predictions'] <- paste(candidates[, 'resource'], collapse = ' | ')
        } else {
          predictions[S1[i], 'resource_predictions'] <- paste(candidates['resource'], collapse = ' | ')
        }#if
    setTxtProgressBar(pb, i)
    }#i
    close(pb)
    return(predictions)
}#full algorithm function


subroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror)

# Find the triangle of the extant triangulation in which
# lies the point currently being added.
# Called by initad.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt(3)
dimension itmp(1)
integer tau(3)
logical adjace, anticl

nerror = -1

# The first point must be added to the triangulation before
# calling trifnd.
if(j==1) {
	nerror = 11
	return
}

# Get the previous triangle:
j1     = j-1
tau(1) = j1
tau(3) = nadj(j1,1)
call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror)
if(nerror > 0) return
call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror)
if(nerror>0) {
    return
}
if(!adjace) {
        tau(3) = tau(2)
	call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# Move to the adjacent triangle in the direction of the new
# point, until the new point lies in this triangle.
ktri = 0
1       continue

# Check that the vertices of the triangle listed in tau are
# in anticlockwise order.  (If they aren't then reverse the order;
# if they are *still*  not in anticlockwise order, theh alles
# upgefucken ist; throw an error.)
call acchk(tau(1),tau(2),tau(3),anticl,x,y,ntot,eps)
if(!anticl) {
    call acchk(tau(3),tau(2),tau(1),anticl,x,y,ntot,eps)
    if(!anticl) {
        itmp(1) = j
        call intpr("Point number =",-1,itmp,1)
        call intpr("Previous triangle:",-1,tau,3)
        call rexit("Both vertex orderings are clockwise. See help for deldir.")
    } else {
        ivtmp  = tau(3)
        tau(3) = tau(1)
        tau(1) = ivtmp
    }
}

ntau  = 0 # This number will identify the triangle to be moved to.
nedge = 0 # If the point lies on an edge, this number will identify that edge.
do i = 1,3 {
        ip = i+1
        if(ip==4) ip = 1 # Take addition modulo 3.

# Get the coordinates of the vertices of the current side,
# and of the point j which is being added:
	xt(1) = x(tau(i))
	yt(1) = y(tau(i))
	xt(2) = x(tau(ip))
	yt(2) = y(tau(ip))
	xt(3) = x(j)
	yt(3) = y(j)

# Create indicator telling which of tau(i), tau(ip), and j
# are ideal points.  (The point being added, j, is ***never*** ideal.)
	if(tau(i)<=0) i1 = 1
	else i1 = 0
	if(tau(ip)<=0) j1 = 1
	else j1 = 0
	k1 = 0
	ijk = i1*4+j1*2+k1

# Calculate the ``normalized'' cross product; if this is positive
# then the point being added is to the left (as we move along the
# edge in an anti-clockwise direction).  If the test value is positive
# for all three edges, then the point is inside the triangle.  Note
# that if the test value is very close to zero, we might get negative
# values for it on both sides of an edge, and hence go into an
# infinite loop.
	call cross(xt,yt,ijk,cprd)
	if(cprd >= eps) continue
	else if(cprd > -eps) nedge = ip
	else {
		ntau = ip
		break
	}
}

# We've played ring-around-the-triangle; now figure out the
# next move:

# case 0: All tests >= 0.; the point is inside; return.
if(ntau==0) return

# The point is not inside; work out the vertices of the triangle to which
# to move.  Notation: Number the vertices of the current triangle from 1 to 3,
# anti-clockwise. Then "triangle i+1" is adjacent to the side from vertex i to
# vertex i+1, where i+1 is taken modulo 3 (i.e. "3+1 = 1").

# case 1: Move to "triangle 1"
if(ntau==1) {
	#tau(1) = tau(1)
	tau(2)  = tau(3)
	call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# case 2: Move to "triangle 2"
if(ntau==2) {
	#tau(1) = tau(1)
	tau(3)  = tau(2)
	call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# case 3: Move to "triangle 3"
if(ntau==3) {
	tau(1)  = tau(3)
	#tau(2) = tau(2)
	call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# We've moved to a new triangle; check if the point being added lies
# inside this one.
ktri = ktri + 1
if(ktri > ntri) {
    itmp(1) = j
    call intpr("Point being added:",-1,itmp,1)
    call rexit("Cannot find an enclosing triangle.  See help for deldir.")
}
go to 1

end


# ================================================================ #
# |             *** Implementation of CV
# | 1. Sequential implementation
# |    1.a local shrinkage
# |    1.b global shrinkage
# | 2. Distributed/Parallel implementation for global shrinkage
# ================================================================ #
library(lars) #, lib="/home/dabid/R/x86_64-unknown-linux-gnu-library/3.2/")

# ================================================================ #
# |                **** Helper functions ****                    | #
# ================================================================ #
lars.multi <- function(tdata,rdata,pert,prior,allowed)
{
  lars.paths <- list()
  targets <- seq(dim(tdata)[1])

  cat("Building path for target: ")
  for (i in targets)
  {
    cat(i,"")
    mindices <- which(pert[i,]==0)

    x <- rdata[,mindices] * prior[,i]
    x[which(allowed[,i]==0),]<-0;

    ##### YK patch 05-23-2017
    # results.lars <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=FALSE);
    y <- tdata[i,mindices];
    results.lars.flag <- TRUE;
    sample.indx <- length(y);
    while (results.lars.flag) {
      results.lars <- try(lars(t(x[,1:sample.indx]),y[1:sample.indx],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=FALSE));
      results.lars.flag <- class(results.lars) =='try-error';
      if (results.lars.flag) { cat(' *no soln* '); }
      sample.indx <- sample.indx-1;
    }
    #####
    #lars.paths[[i]] <- list(beta=results.lars$beta, mu=results.lars$mu, meanx=results.lars$meanx, C.Max=c(results.lars$C.Max,0))
    lars.paths[[i]] <- list(beta=results.lars$beta, mu=results.lars$mu, meanx=results.lars$meanx, C.Max=c(results.lars$lambda,0))  # for support in lars 1.2
  }
  cat("\n")

  cat("Building combined C.Max ranking\n")
  all.C.lars <- c()
  for (i in targets)
  {
    all.C.lars <- rbind(all.C.lars, cbind(lars.paths[[i]]$C.Max,rep(i,times=length(lars.paths[[i]]$C.Max)),1:length(lars.paths[[i]]$C.Max)))
  }
  R <- all.C.lars[sort.list(all.C.lars[,1],decreasing=TRUE),]
  lars.paths$R <- R
  lars.paths$targets <- targets
  lars.paths
}

# ================================================================ #
# |             **** END Helper functions ****                   | #
# ================================================================ #

# ================================================================ #
# |          **** Lochal Shrinkage functions ****                | #
# ================================================================ #

# ================================================================ #
# |          **** END Lochal Shrinkage functions ****            | #
# ================================================================ #
lars.multi.optimize <- function(tdata,rdata,pert,prior,allowed)
{
	cat(as.character(Sys.time()),"\n")
	lars.paths.cv <- lars.multi.cv(tdata,rdata,pert,prior,allowed,10)

	lars.paths <- lars.multi(tdata,rdata,pert,prior,allowed)
	B <- lars.multi.path.step(lars.paths,lars.paths.cv[[2]])

	B.adj <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata)[1])

	for (i in seq(dim(tdata)[1]))
	{
		#Scale B.adj according to prior
		B.adj[,i] <- B[[i]] * prior[,i]
	}
	rval <- list()
	rval[[1]] <- B.adj
	rval[[2]] <- lars.paths
	rval[[3]] <- lars.paths.cv
	cat(as.character(Sys.time()),"\n")
	rval
}

lars.multi.cv <- function(tdata,rdata,pert,prior,allowed,fold)
{
	all.folds <- cv.folds(dim(tdata)[2], fold)
	lars.cv.paths <- list()
	cMax <- 0;
	for (f in 1:fold)
	{
		cat("Building path for cv",f,"of",fold,"\n")
		omit <- all.folds[[f]]
		lars.cv.paths[[f]] <- lars.multi(tdata[,-omit], rdata[,-omit], pert[,-omit],prior,allowed)
		if (lars.cv.paths[[f]]$R[1,1]>cMax)
		{
			cMax <- lars.cv.paths[[f]]$R[1,1]
		}

	}

	cSteps <- c()
	mse <- c()
	bnorm <- c()

	converged <- FALSE
	P <- c(cMax/10,0)
	FP <- c(lars.multi.cv.eval(P[1],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed),lars.multi.cv.eval(P[2],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed))

	while (!converged)
	{
		Imin <- which.min(FP)
		Imax <- which.max(FP)
		if (Imin==Imax)
			converged=TRUE

		cat("P:",P,"F(P):",FP,"Max/Min",Imax,Imin,"\n")
		Phat <- P[Imin]
		Pref <- 2*Phat - P[Imax]

		if (Pref>cMax)
			FPref <- max(FP) + (Pref-cMax)^2
		else if (Pref<0)
			FPref <- max(FP) + Pref^2
		else
			FPref <- lars.multi.cv.eval(Pref,fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)

			if (FPref < FP[Imin])
			{
				#Attempt expansion
				Pexp <- 2*Pref - Phat
				FPexp <- lars.multi.cv.eval(Pexp,fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)
				if (FPexp < FPref) #Expand
				{
					cat("Expand\n")
					P[Imax] <- Pexp
					FP[Imax] <- FPexp
				}
				else #Reflect
				{
					cat("Reflect\n")
					P[Imax] <- Pref
					FP[Imax] <- FPref
				}
			}
			else
			{
				#Contract
				if (FP[Imax] < FPref)
				{
					cat("Contract (1)\n")
					P[Imax] <- (P[Imax] + Phat)/2
					FP[Imax] <- lars.multi.cv.eval(P[Imax],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)
				}
				else
				{
					cat("Contract (2)\n")
					P[Imax] <- (Pref + Phat)/2
					FP[Imax] <- lars.multi.cv.eval(P[Imax],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)
				}
			}
	}
	rval <- list()
	rval[[1]] <- lars.cv.paths
	rval[[2]] <- P[which.min(FP)]
	rval[[3]] <- min(FP)
	rval[[4]] <- all.folds
	rval
}

lars.multi.cv.eval <- function(cVal,fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed,targets=NULL)
{
		if (is.null(targets))
			targets <- seq(dim(tdata)[1])
		mse <- rep(0,times=fold)
		for (f in 1:fold)
		{
			B <- lars.multi.path.step(lars.cv.paths[[f]],cVal)
			for (i in targets)
			{
				omit <- all.folds[[f]]
				omit <- setdiff(omit,which(pert[i,]!=0))

				testx <- rdata[,omit]
				testy <- tdata[i,omit]
				testx[which(allowed[,i]==0),] <- 0
				testx <- testx * prior[,i]

				testp <- scale(t(testx) , lars.cv.paths[[f]][[i]]$meanx, FALSE) %*% matrix(B[[i]]) + lars.cv.paths[[f]][[i]]$mu
				testr <- apply((testp - testy)^2,2,mean)
				mse[f] <- mse[f] + testr
			}
			mse[f] <- mse[f]/length(targets)
		}
		totalmse <- sum(mse) / fold
		totalmse
}

lars.multi.path.step <- function(lars.paths,stepC)
{
	k <- 1
	if (length(which(lars.paths$R[,1]>stepC))>0)
	{
		k<-max(which(lars.paths$R[,1]>stepC))
	}

	B <- list()
	A <- c()
	Ai <- unique(lars.paths$R[1:k,2])
	for (i in Ai)
	{
		A <- rbind(A,c(i,lars.paths$R[max(which(lars.paths$R[1:k,2]==i)),3]))
	}

	for (i in lars.paths$targets)
	{
		indx <- which(A[,1]==i)
		if (length(indx)==0)
		{
			B[[i]] <- rep(0,times=dim(lars.paths[[i]]$beta)[2])
		}
		else
		{
			plen <- dim(lars.paths[[i]]$beta)[1]
			if (A[indx,2]==plen)
			{
				B[[i]] <- lars.paths[[i]]$beta[plen,]
			}
			else
			{
				if ( lars.paths$R[k,1] < lars.paths[[i]]$C.Max[A[indx,2]+1] )
				{
					if (A[indx,2] < plen)
						A[indx,2] <- A[indx,2] + 1
				}
				gamma <- (lars.paths[[i]]$C.Max[A[indx,2]] - lars.paths$R[k,1]) / (lars.paths[[i]]$C.Max[A[indx,2]] - lars.paths[[i]]$C.Max[A[indx,2]+1])
				u <- (lars.paths[[i]]$beta[A[indx,2]+1,] - lars.paths[[i]]$beta[A[indx,2],])
				B[[i]] <- lars.paths[[i]]$beta[A[indx,2],] + u * gamma
			}
		}
	}
	B
}

###

lars.multi.cv.singlefold <- function(tdata,rdata,pert,prior,allowed,nbr_cv_fold,seed,f)
{
	set.seed(seed)
	all.folds <- cv.folds(dim(tdata)[2], nbr_cv_fold)
	cat("Building path for cv",f,"of",nbr_cv_fold,"\n")
	omit <- all.folds[[f]]
	lars.cv.paths <- lars.multi(tdata[,-omit], rdata[,-omit], pert[,-omit],prior,allowed)
	lars.cv.paths
}

lars.single.cv <- function(tdata,rdata,pert,prior,allowed,fold,seed)
{
	targets <- seq(dim(tdata)[1])
	lars.paths.cv <- list()
	lars.paths <- list()
	B <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata))

	minFrac <- c()
  cat("Building path for target: ")
  for (i in targets)
  {
    cat(i,"")
    mindices <- which(pert[i,]==0)
    x <- rdata[,mindices] * prior[,i]
    x[which(allowed[,i]==0),]<-0;
    set.seed(seed)
    lars.paths.cv[[i]] <-  cv.lars(t(x),tdata[i,mindices],K=fold,plot.it=FALSE,trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,se=FALSE);
		minFrac[i] <- lars.paths.cv[[i]]$index[which.min(lars.paths.cv[[i]]$cv)]
		lars.paths[[i]] <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE);
		B[,i] <- predict(lars.paths[[i]],s=minFrac[i],type="coefficients",mode="fraction")$coefficients
  }
	cat("\n")
	B
}

lars.local <- function(tdata,rdata,pert,prior,allowed,skip_reg,skip_gen)
{
  cat(as.character(Sys.time()),"\n")
  B.adj <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata)[1])

  cat("Working on Gene:")
	for(i in 1:dim(tdata)[1]) {
		if (skip_gen[i] == 0) {
		 	cat(i,",")
			mindices <- which(pert[i,]==0)
			x <- rdata[,mindices] * prior[,i]
			x[which(allowed[,i]==0),]<-0;
			nindices <- which(skip_reg==0)
			x <- x[nindices,]
			lars.paths.cv <-  cv.lars(t(x),tdata[i,mindices],K=3,trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,se=FALSE, plot.it=FALSE,use.Gram=FALSE);
			minFrac <- lars.paths.cv$index[which.min(lars.paths.cv$cv)]
			lars.paths <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=FALSE);
			# lars.paths <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=TRUE);
			tempVec <- predict(lars.paths,s=minFrac,type="coefficients",mode="fraction")$coefficients
			# tempVec <- lars.paths$beta
			# print(tempVec)
			nindices <- which(skip_reg==1)
      tempCol <- c(tempVec, rep(0,length(nindices)))
      tempIndices <- c(seq_along(tempVec), nindices+.5)
      B.adj[,i] <- tempCol[order(tempIndices)]
      #Scale B.adj according to prior
			B.adj[,i] <- B.adj[,i] * prior[,i]
		}
	}
	cat("\n")

	rval <- list()
  rval[[1]] <- B.adj
  rval
}

# ====================================================================== #
# |           **** Distributed/Parallel Implementation ****            | #
# ====================================================================== #

create_lasso_global_shrinkage_parallel = function(df_expr_target
                                                 , df_expr_reg
                                                 , df_allowed
                                                 , df_perturbed
                                                 , df_prior
                                                 , seed
                                                 , p_out_dir
                                                 , nbr_cv_fold
                                                 , p_src_code){
  library("Rmpi")
  mpi.spawn.Rslaves(nslaves = nbr_cv_fold)
  mpi.bcast.Robj2slave(df_expr_target)
  mpi.bcast.Robj2slave(df_expr_reg)
  mpi.bcast.Robj2slave(df_prior)
  mpi.bcast.Robj2slave(df_allowed)
  mpi.bcast.Robj2slave(df_perturbed)
  mpi.bcast.Robj2slave(p_out_dir)
  mpi.bcast.Robj2slave(p_src_code)
  mpi.bcast.Robj2slave(seed)
  mpi.bcast.Robj2slave(nbr_cv_fold)
  mpi.remote.exec(source(paste(p_src_code, "src/build_np1/code/netprophet1/run_netprophet_parallel_single_process.r", sep="")))
  mpi.remote.exec(get_fold_nbr())
  # all.folds = cv.folds(dim(df_expr_target)[2], nbr_cv_fold)
  df_lasso_net = lars.multi.optimize.parallel(df_expr_target,df_expr_reg,df_perturbed,df_prior,df_allowed)[[1]]

  mpi.close.Rslaves()

  df_lasso_net
}

lars.multi.optimize.parallel <- function(df_expr_target,df_expr_reg,df_perturbed,df_prior,df_allowed)
{
  prior=df_prior
  allowed=df_allowed
  pert=df_perturbed
  tdata=df_expr_target
  rdata=df_expr_reg
  targets=seq(dim(tdata)[1])
  cat(as.character(Sys.time()),"\n")
  c.cvmin <- lars.multi.cv.parallel()

  # lars.paths <- lars.multi(tdata,rdata,pert,prior,allowed)
  lars.paths <- lars.multi(df_expr_target,df_expr_reg,df_perturbed,df_prior,df_allowed)
  B <- lars.multi.path.step(lars.paths,c.cvmin)

  B.adj <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata)[1])

  for (i in seq(dim(tdata)[1]))
  {
    #Scale B.adj according to prior
    B.adj[,i] <- B[[i]] * prior[,i]
  }
  rval <- list()
  rval[[1]] <- B.adj
  rval[[2]] <- lars.paths
  cat(as.character(Sys.time()),"\n")
  rval
}

lars.multi.cv.cmax.parallel <- function()
{
  cat(cv.obj$R[1,1],"\n")
  cv.obj$R[1,1]
}

lars.multi.cv.parallel <- function()
{
  cMax <- max(as.numeric(mpi.remote.exec(lars.multi.cv.cmax.parallel())))
  cat("cMax: ", cMax, "\n")
  converged <- FALSE
  P <- c(cMax/10,0)

  FP <- c(mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[1]))),mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[2]))))

  while (!converged)
  {
    Imin <- which.min(FP)
    Imax <- which.max(FP)
    if (Imin==Imax)
      converged=TRUE

    cat("P:",P,"F(P):",FP,"Max/Min",Imax,Imin,"\n")
    Phat <- P[Imin]
    Pref <- 2*Phat - P[Imax]

    if (Pref>cMax)
      FPref <- max(FP) + (Pref-cMax)^2
    else if (Pref<0)
      FPref <- max(FP) + Pref^2
    else
      FPref <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,Pref)))

    if (FPref < FP[Imin])
    {
      #Attempt expansion
      Pexp <- 2*Pref - Phat
      FPexp <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,Pexp)))
      if (FPexp < FPref) #Expand
      {
        cat("Expand\n")
        P[Imax] <- Pexp
        FP[Imax] <- FPexp
      }
      else #Reflect
      {
        cat("Reflect\n")
        P[Imax] <- Pref
        FP[Imax] <- FPref
      }
    }
    else
    {
      #Contract
      if (FP[Imax] < FPref)
      {
        cat("Contract (1)\n")
        P[Imax] <- (P[Imax] + Phat)/2
        FP[Imax] <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[Imax])))
      }
      else
      {
        cat("Contract (2)\n")
        P[Imax] <- (Pref + Phat)/2
        FP[Imax] <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[Imax])))
      }
    }
  }

  cat(P[which.min(FP)],min(FP),"\n")

  P[which.min(FP)]
}

lars.multi.cv.eval.parallel <- function(cVal)
{
  mse <- 0;
  B <- lars.multi.path.step(cv.obj,cVal)
  prior=df_prior
  allowed=df_allowed
  pert=df_perturbed
  tdata=df_expr_target
  rdata=df_expr_reg
  targets=seq(dim(tdata)[1])
  # all.folds <- cv.folds(dim(tdata)[2], nbr_cv_fold)
  for (i in targets)
  {
    omit <- all.folds[[fold]]
    omit <- setdiff(omit,which(pert[i,]!=0))

    testx <- rdata[,omit]
    testy <- tdata[i,omit]
    testx[which(allowed[,i]==0),] <- 0
    testx <- testx * prior[,i]

    testp <- scale(t(testx) , cv.obj[[i]]$meanx, FALSE) %*% matrix(B[[i]]) + cv.obj[[i]]$mu
    testr <- apply((testp - testy)^2,2,mean)
    mse <- mse + testr
  }
  mse <- mse/length(targets)
  mse
}

# ====================================================================== #
# |          **** END Distributed/Parallel Implementation ****         | #
# ====================================================================== #