require(GRanges)
require(biovizBase)
require(ggbio)
data(hg19IdeogramCyto, package = "biovizBase")
# chr20<-sites %>% filter(CHR==20)

getOption("biovizBase")$cytobandColor

# chr20a <- sites %>%
#   mutate(Type=gsub("cpg_", "", Category2),
#     SEQA=substr(Sequence, cbp-i, cbp+i),
#     SEQB=substr(Sequence, cbp*3-i, cbp*3+i),
#     Motif=paste0(SEQA, "(", SEQB, ")"))

site_ranges <- GRanges(
  seqnames=paste0("chr",full_data$sites$CHR),
  ranges=IRanges(start=full_data$sites$POS, end=full_data$sites$POS)
)

s2 <- nearest(site_ranges, hg19IdeogramCyto)
sites <- cbind(full_data$sites, as.data.frame(hg19IdeogramCyto[s2])[-c(1:5)])

sites$name <- as.character(sites$name)
sites$gieStain <- as.character(sites$gieStain)
# sites$band <- paste0(sites$CHR,sites$name)

sites$bin <- ceiling(sites$POS/binw)

i<-1
cbp<-5
band_counts <- sites %>%
  mutate(Sequence=substr(Motif,1,9)) %>%
  mutate(Type=gsub("cpg_", "", Category2),
    SEQA=substr(Motif, cbp-i, cbp+i),
    SEQB=substr(Motif, cbp*3-i, cbp*3+i),
    Motif=paste0(SEQA, "(", SEQB, ")"),
    band=paste0(CHR, name)) %>%
  filter(band!="18p11.1") %>%
  group_by(CHR, band, gieStain, Type, Motif) %>%
  summarise(n=n())

window_counts <- sites %>%
  mutate(Type=gsub("cpg_", "", Category2),
    SEQA=substr(Motif, cbp-i, cbp+i),
    SEQB=substr(Motif, cbp*3-i, cbp*3+i),
    Motif=paste0(SEQA, "(", SEQB, ")"),
    band=paste0(CHR, name)) %>%
  filter(band!="18p11.1") %>%
  group_by(CHR, bin, Type, Motif) %>%
  summarise(n=n())

wc.m <- window_counts %>%
  ungroup() %>%
  mutate(ID=CHR+bin/binw) %>%
  mutate(b1=ifelse(substr(Type, 1, 1)=="A", "A", "C")) %>%
  mutate(b2=ifelse(b1=="A", substr(Type, 4, 4), substr(Type, 5, 5))) %>%
  mutate(Type=paste0(b1, "_", b2)) %>%
  mutate(subtype=paste0(Type, ".", substr(Motif,1,3))) %>%
  dplyr::select(ID, subtype, n) %>%
  spread(subtype, n, fill=0)

write.table(wc.m,
  "/net/snowwhite/home/jedidiah/NMF_M_spectra.txt",
  col.names=T, row.names=F, sep="\t", quote=F)

# chr20bins<-read.table("/net/bipolar/jedidiah/mutation/output/3bp_1000k_singletons_full/chr20.motif_counts_binned.txt", header=T, stringsAsFactors=F)
band_motif_counts <- read.table(paste0(parentdir,
    "/output/3bp_1000k_singletons_full/full_motif_counts_band.txt"),
  header=F, stringsAsFactors=F, skip=1)

names(band_motif_counts)<-c("CHR", "START", "END", "name", "gieStain", "Motif", "Count")

band_motif_counts <- band_motif_counts %>%
  mutate(CHR = gsub("chr", "", CHR),
    Length = END-START,
    band=paste0(CHR, name))

band_dat <- merge(band_counts, band_motif_counts, by=c("CHR", "band", "gieStain", "Motif"))
band_dat$ERV_rel_rate <- band_dat$n/band_dat$Count

pca_input <- band_dat %>%
# filter(Type=="AT_CG") %>%
  mutate(normrate=scale(ERV_rel_rate),
    subtype=paste0(Type, "_", Motif)) %>%
  dplyr::select(CHR, band, gieStain, START, Length, subtype, ERV_rel_rate) %>%
  spread(subtype, ERV_rel_rate)

total_band_counts <- band_counts %>%
  group_by(CHR, band) %>%
  summarise(nERVs=sum(n))

pca_input[is.na(pca_input)] <- 0
pcdat <- prcomp(scale(pca_input[,-c(1,2,3,4,5)]))
pcd2 <- cbind(pca_input[,1:5], as.data.frame(pcdat$x)) # %>% mutate(band=paste0(CHR,name))

pcd2 <- merge(pcd2, total_band_counts, by=c("CHR", "band"))

pcd2$gieStain <- as.factor(pcd2$gieStain)
levels(pcd2$gieStain) <- c("acen", "gneg", "gpos25", "gpos50", "gpos75", "gpos100", "gvar")

# tsnedat<-tsne(chr20_atcg_pca[,-c(1,2,3,4,5)], initial_dims=30, perplexity=30, max_iter=500)
# pcdat<-prcomp(scale(chr20_atcg_pca[,3:10]))
# tsnedat2<-tsne(pcdat$x, initial_dims=30, perplexity=30, max_iter=500)
tsnedat <- tsne(pcdat$x[,1:15], initial_dims=15, perplexity=10, max_iter=5000)
# cumsum((pcdat$sdev)^2) / sum(pcdat$sdev^2)
pcd2 <- cbind(pcd2, as.data.frame(tsnedat))

# pcd2.sav<-pcd2
pcd2.pc.clust <- pcd2 %>%
  # filter(gieStain=="acen" | grepl("9p2", band) | grepl("8p2", band) | grepl("^2q21", band) | grepl("^2q22", band))
  # filter(grepl("9p2", band) | grepl("8p2", band) | (PC2< -5 & PC1< -10))
  filter((PC2< -3.5 & PC1< 0))

clust1 <- pcd2 %>%
  filter((V1 > -25 & V1 < 25 & V2 > 65 & V2< 90)) %>%
  mutate(cluster="clust1")

clust2 <- pcd2 %>%
  filter((V1 > 15 & V1 < 30 & V2 > 50 & V2< 65)) %>%
  mutate(cluster="clust2")

clust3 <- pcd2 %>%
  filter((V1 > 40 & V1 < 75 & V2 > 10 & V2< 40)) %>%
  mutate(cluster="clust3")

clust4 <- pcd2 %>%
  filter((V1 > 62 & V1 < 100 & V2 > -50 & V2< -20)) %>%
  mutate(cluster="clust4")

clusterdat <- bind_rows(list(clust1, clust2, clust3, clust4))

pcd.path <- pcd2 %>%
  filter(CHR==8)# | (V2>30 & V1<0))

fullcols <- getOption("biovizBase")$cytobandColor

giemsacols <- fullcols[names(fullcols) %in% unique(pcd2$gieStain)]
giemsacols["gvar"] <- "#C6A6E6"
# giemsacols <- unlist(giemsacols)

ggplot()+
  geom_point(data=pcd2, aes(x=PC1, y=PC2, fill=gieStain, size=log10(nERVs)),
         colour="black",pch=21, alpha=0.8)+
  # geom_label_repel(data=pcd2.pc.clust, max.iter=5000, xlim=c(0, NA), ylim=c(NA, 5), fill="white", alpha=1, inherit.aes=F,
  #   aes(x=PC1, y=PC2, label = band, colour=factor(CHR)),
  # box.padding = unit(0.6, "lines")) +
  # scale_color_brewer(type='div', palette=2)+
  scale_fill_manual(values=giemsacols)+
  scale_colour_manual(values=myPaletteCatN(8))+
  # geom_path(data=pcd.path, aes(x=PC1, y=PC2), linetype=2)+
  theme_bw()+
  theme(#legend.title=element_blank(),
    # legend.key.size = unit(1.1, "cm"),
    axis.text.x=element_text(size=14),
    axis.text.y=element_text(size=14),
    axis.title.y = element_text(size=16),
    axis.title.x=element_text(size=16))+
  guides(colour=FALSE,
    fill = guide_legend(override.aes = list(size=6)))
ggsave(paste0(parentdir, "/images/chr20_bin_pca.png"), height=12, width=12)

ggplot(data, aes_string(x="V1", y="V2", color=var_cluster)) +
geom_point(size=0.25) +
guides(colour=guide_legend(override.aes=list(size=6))) +
xlab("") + ylab("") +
ggtitle("") +
theme_light(base_size=20) +
theme(axis.text.x=element_blank(),
      axis.text.y=element_blank(),
      legend.direction = "horizontal",
      legend.position = "bottom",
      legend.box = "horizontal") +
  scale_colour_brewer(palette = palette)

  tsne_dist <- dist(pcd2[,c("V1", "V2")])
  cl <- hclust(tsne_dist)
cl2 <- kmeans(scale(pcd2[,c("V1", "V2")]), 4)

pcd2$tsne_clust <- factor(cl2$cluster)
  ## Creating hierarchical cluster model, and assigning the result to the data used to create the tsne
  fit_cluster_hierarchical=hclust(dist(scale(d_tsne_1)))

  ## setting 3 clusters as output
  pcd2$tsne_clust = factor(cutree(cl, k=4))

ggplot()+
  geom_point(data=pcd2, aes(x=V1, y=V2, fill=gieStain, size=log10(nERVs)),
         colour="black",
         pch=21, alpha=0.8)+
  # geom_label_repel(data=pcd2.tsne.clust1, max.iter=5000, xlim=c(NA, 0), ylim=c(NA, -55), fill="white", alpha=1, inherit.aes=F,
  #   aes(x=V1, y=V2, label = band, colour=factor(CHR)),
  # box.padding = unit(0.6, "lines")) +
  # geom_label_repel(data=pcd2.tsne.clust2, max.iter=5000, xlim=c(NA, -25), ylim=c(-60,-10), fill="white", alpha=1, inherit.aes=F,
  #   aes(x=V1, y=V2, label = band, colour=factor(CHR)),
  # box.padding = unit(0.1, "lines")) +
  # geom_label_repel(data=pcd2.cent.clust, max.iter=5000, xlim=c(NA, -50), ylim=c(30,NA), fill="white", alpha=1, inherit.aes=F,
  #   aes(x=V1, y=V2, label = band, colour=factor(CHR)),
  # box.padding = unit(0.6, "lines")) +
  # scale_color_brewer(type='div', palette=2)+
  scale_fill_manual(values=giemsacols)+
  # scale_colour_manual(values=c(iwhPalette, myPaletteCatN(8)))+
  # geom_path(data=pcd.path, aes(x=PC1, y=PC2), linetype=2)+
  theme_bw()+
  theme(#legend.title=element_blank(),
    # legend.key.size = unit(1.1, "cm"),
    axis.text.x=element_text(size=14),
    axis.text.y=element_text(size=14),
    axis.title.y = element_text(size=16),
    axis.title.x=element_text(size=16))+
  guides(colour=FALSE,
    fill = guide_legend(override.aes = list(size=6)))
ggsave(paste0(parentdir, "/images/chr20_bin_tsne.png"), height=12, width=12)

clusterdat$midpt <- clusterdat$START+clusterdat$Length/2

clust_markers <- GRanges(seqnames=paste0("chr", clusterdat$CHR),
                       ranges=IRanges(start=clusterdat$midpt,
                         end=clusterdat$midpt),
                       cluster=clusterdat$cluster,
                       yval=15)
data(hg19Ideogram, package = "biovizBase")
seqlengths(clust_markers) <- seqlengths(hg19Ideogram)[names(seqlengths(clust_markers))]
hg19 <- keepSeqlevels(hg19IdeogramCyto, paste0("chr", c(1:22, "X", "Y")))

# clustchrs <- hg19
clustchrs<-hg19[seqnames(hg19) %in% unique(seqnames(clust_markers)),]
seqlengths(clustchrs) <- seqlengths(hg19Ideogram)[names(seqlengths(clustchrs))]

maskbed<-read.table(paste0(parentdir, "/reference_data/testcov.bed"), header=F, stringsAsFactors=F)
names(maskbed)<-c("CHR", "START", "END", "name", "gieStain", "V1", "V2", "V3", "pctmask")
maskbed<-maskbed %>% filter(!grepl("X|Y", CHR))
mask_markers <- GRanges(seqnames=maskbed$CHR,
                       ranges=IRanges(start=maskbed$START,
                         end=maskbed$END),
                        pctmask=maskbed$pctmask)
seqlengths(mask_markers) <- seqlengths(hg19Ideogram)[names(seqlengths(mask_markers))]

harbed<-read.table(paste0(parentdir, "/reference_data/2xHARs.hg19.sort.bed"), header=F, stringsAsFactors=F)
names(harbed)<-c("CHR", "START", "END", "ID", "VAL")
harbed<-harbed %>% filter(!grepl("X|Y", CHR))

# harbed <- harbed %>% arrange(desc(VAL)) %>% head(50)

har_markers <- GRanges(seqnames=harbed$CHR,
                       ranges=IRanges(start=harbed$START,
                         end=harbed$START),
                         ID=harbed$ID,
                         yval=15
                        )
seqlengths(har_markers) <- seqlengths(hg19Ideogram)[names(seqlengths(har_markers))]

p <- ggplot(clustchrs)+
  layout_karyogram(cytoband = TRUE)+
  geom_text(label=name)
  scale_fill_manual(values=c(giemsacols, stalk="#cd3333"))
p <- p+
  layout_karyogram(mask_markers,
    geom = "rect",
    ylim = c(10, 20),
    aes(alpha=pctmask, colour=NA), fill="black")+
  layout_karyogram(clust_markers,
    geom = "point",
    ylim = c(10, 20),
    aes(x=start, y=yval, color = cluster))+
  scale_colour_manual(values=myPaletteCatN(8)[4:8])+
  layout_karyogram(har_markers,
    geom = "point",
    ylim = c(0, 10),
    aes(x=start, y=yval, color = "black"))+
  guides(fill=FALSE,
    colour = guide_legend(override.aes=list(fill="white")))
p
ggsave(paste0(parentdir, "/images/chr20_cluster_karyo.png"), height=8, width=8)
# , size=6
# , xlim=c(-25, NA)

ggplot(chr20_atcg, aes(x=BIN, y=ERV_rel_rate, fill=Motif, colour=Motif, group=Motif))+
  geom_bar(stat="identity")+
  # geom_point()+
  # geom_line()+
  facet_wrap(~Motif)
ggsave(paste0(parentdir, "/images/chr20_rates_stacked.png"))

###############################################################################
# Analysis by 1Mb bin
###############################################################################
mct3a <- get_mct_b(bins1Mb)

# Count singletons per 3-mer subtype bin
bin_counts <- full_data$sites %>%
  mutate(Type=gsub("cpg_", "", Category2),
    SEQA=substr(Motif, cbp-i, cbp+i),
    SEQB=substr(Motif, cbp*3-i, cbp*3+i),
    Motif=paste0(SEQA, "(", SEQB, ")")) %>%
  group_by(CHR, BIN, Type, Motif) %>%
  summarise(n=n())

bin_counts <- merge(bin_counts, mct3a, by=c("CHR", "BIN", "Motif")) %>%
  mutate(ERV_rel_rate=n/nMotifs,
  subtype=paste0(Type, "_", Motif))

# Coerce from long to wide format
bins_wide <- bin_counts  %>%
  dplyr::select(CHR, BIN, subtype, n) %>%
  spread(subtype, n, fill=0) %>%
  mutate(sumVar = rowSums(.[3:98])) %>%
  mutate_at(vars(contains("_")), funs(./sumVar)) %>%
  dplyr::select(-sumVar)

# Run PCA on bin matrix
bins_pca <- prcomp(scale(bins_wide[,-c(1:2)]))

# Cumulative variance explained by 96 PCs
# bin_cumvar <- cumsum((bins_pca$sdev)^2) / sum(bins_pca$sdev^2)

# Data frame containing bin IDs and components
# bins_wide_pcs <- cbind(bins_wide[,c(1:2)], as.data.frame(bins_pca$x))

# Run NMF on bin matrix; get top signature for each bin
bins_nmf <- nmf(bins_wide[,-c(1:2)], 5, nrun=3)
bins_pred <- predict(bins_nmf, "rows", prob=T)

sigloads <- coef(bins_nmf) %>%
  data.frame %>%
  mutate(signature = paste0("X",row_number())) %>%
  mutate(sumVar = rowSums(.[1:96])) %>%
  mutate_at(vars(contains("_")), funs(./sumVar)) %>%
  gather(subtype, contribution, -c(signature, sumVar)) %>%
  separate(subtype, into=c("Type", "Motif"), 5) %>%
  mutate(Motif=substr(Motif,2,4))

# sigloads <- get_loads(bins_wide[,-c(1:2)], bins_nmf)
# plot_loads(sigloads)
# ggsave(paste0(parentdir, "/images/sigloads_bin.png"))

# Add predicted NMF class to data frame
# bins_wide_c <- cbind(bins_wide_c, sig=bins_pred[[1]])
bins_nmf_plotdat <- data.frame(bins_wide[,c(1:2)],
    basis(bins_nmf),
    sig=bins_pred[[1]]) %>%
  mutate(sum=X1+X2+X3,
    X1a=X1/sum,
    X2a=X2/sum,
    X3a=X3/sum)

# chrp_c <- merge(chrp_c, bins_nmf_plotdat, by=c("CHR", "BIN"))

bins_nmf_long <- bins_nmf_plotdat %>%
  gather(cluster, prob, X1a:X3a) %>%
  arrange(CHR, BIN) %>%
  group_by(cluster) %>%
  mutate(window=row_number(),
    CHR.BIN=paste0(CHR, "_", BIN),
    prob_m=rollmedian(prob, 5, fill=NA),
    # prob_m=prob,
    log_prob=log(prob_m)) %>%
  filter(log_prob > -5)

write.table(sigloads, "/net/csgsites/mutation/share/sigloads.txt", col.names=T, row.names=F, sep="\t", quote=F)
write.table(bins_nmf_long, "/net/csgsites/mutation/share/bin_sig_prob.txt", col.names=T, row.names=F, sep="\t", quote=F)
write.table(ind_nmf_long, "/net/csgsites/mutation/share/ind_sig_prob.txt", col.names=T, row.names=F, sep="\t", quote=F)

labs <- bins_nmf_long %>%
  group_by(CHR) %>%
  summarise(start=min(window),
    end=max(window),
    window=ceiling(start+(end-start)/2)) %>%
  mutate(fillcol=ifelse(CHR%%2==0, "even", "odd"))

iwhPalette5 <- c("#9555b4", "#98be57", "#514143", "#c7624e", "#92b5b5")
ggplot()+
  # facet_wrap(~CHR, ncol=1, scales="free_y", strip.position="right")+
  geom_rect(data=labs, aes(xmin=start, xmax=end, ymin=0, ymax=1, fill=fillcol), alpha=0.5)+
  # geom_point(data=bins_nmf_long,
  #   aes(x=window, y=prob, colour=cluster, group=cluster), alpha=0.6)+
  geom_line(data=bins_nmf_long,
    aes(x=window, y=prob_m, colour=cluster, group=cluster), alpha=0.6)+
  # geom_bar(stat="identity")+
  # geom_smooth(method = "lm", formula = y ~ splines::bs(x, 3), se = FALSE)+
  # geom_smooth(method="loess", span=0.2)+
  scale_fill_manual(values=c("grey40", "grey50"), guide=FALSE)+
  scale_colour_manual(values=iwhPalette5)+
  scale_y_continuous(expand=c(0,0))+
  scale_x_continuous(expand=c(0,0), breaks=labs$window, labels=labs$CHR)+
  # ylab("log(cluster probability)")+
  ylab("signature contribution")+
  theme_bw()+
  # theme(axis.text.x=element_blank())+
  theme(legend.position="bottom",
    axis.title.x=element_blank())
ggsave(paste0(parentdir, "/images/by_bin2.png"), width=12, height=8)

bins_nmf_long %>%
  # filter(CHR==16) %>%
ggplot(aes(x=BIN, y=prob, colour=cluster, fill=cluster, group=cluster))+
  facet_wrap(~CHR, ncol=1, scales="free_y", strip.position="right")+
  # geom_point()+
  # geom_bar(stat="identity")+
  # geom_smooth(method = "lm", formula = y ~ splines::bs(x, 3), se = FALSE)+
  geom_smooth(method="loess", span=0.2)+
  theme_bw()+
  theme(axis.text.x=element_blank())+
  theme(legend.position="bottom")
ggsave(paste0(parentdir, "/images/by_bin.png"), width=12, height=18)

ggplot()+
  geom_point(data=bins_wide_c, aes(x=PC1, y=PC2),
    colour="black",pch=21, alpha=0.8)+
  theme_bw()+
  theme(axis.text.x=element_text(size=14),
    axis.text.y=element_text(size=14),
    axis.title.y = element_text(size=16),
    axis.title.x=element_text(size=16))+
  guides(colour=FALSE,
    fill = guide_legend(override.aes = list(size=6)))
ggsave(paste0(parentdir, "/images/bin_pca.png"), height=12, width=12)

clust_markers <- GRanges(seqnames=paste0("chr", pcd2$CHR),
                       ranges=IRanges(start=pcd2$BIN*binw-binw,
                         end=pcd2$BIN*binw),
                       sig=pcd2$sig,
                       yval=15)
data(hg19Ideogram, package = "biovizBase")
seqlengths(clust_markers) <- seqlengths(hg19Ideogram)[names(seqlengths(clust_markers))]
hg19 <- keepSeqlevels(hg19IdeogramCyto, paste0("chr", c(1:22, "X", "Y")))

# clustchrs <- hg19
clustchrs<-hg19[seqnames(hg19) %in% unique(seqnames(clust_markers)),]
seqlengths(clustchrs) <- seqlengths(hg19Ideogram)[names(seqlengths(clustchrs))]

p <- ggplot(clustchrs)+
  layout_karyogram(cytoband = TRUE, label=name)+
  layout_karyogram(cytoband=FALSE, geom="text", label=name)
    # scale_fill_manual(values=c(giemsacols, stalk="#cd3333"))
p <- p+
  layout_karyogram(clust_markers,
    geom = "rect",
    size=6,
    ylim = c(10, 20),
    aes(x=start, color = factor(sig)))+
  scale_colour_manual(values=myPaletteCatN(8)[1:4])+
  guides(fill=FALSE,
    colour = guide_legend(override.aes=list(fill="white")))

ggsave(paste0(parentdir, "/images/nmf_cluster_karyo.png"), height=8, width=8)

# IDs PC1 vs PC2
ggplot()+
  geom_point(data=pcd2, aes(x=PC1, y=PC2),
         colour="black",pch=21, alpha=0.8)+
  theme_bw()+
  theme(axis.text.x=element_text(size=14),
    axis.text.y=element_text(size=14),
    axis.title.y = element_text(size=16),
    axis.title.x=element_text(size=16))+
  guides(colour=FALSE,
    fill = guide_legend(override.aes = list(size=6)))
ggsave(paste0(parentdir, "/images/id_pca.png"), height=12, width=12)


\name{hc_points-GenomicHilbertCurve-method}
\alias{hc_points,GenomicHilbertCurve-method}
\title{
Add points to the Hilbert curve
}
\description{
Add points to the Hilbert curve
}
\usage{
\S4method{hc_points}{GenomicHilbertCurve}(object, gr,
    np = max(c(2, 10 - hc_level(object))), size = unit(1, "char"),
    pch = 1, gp = gpar(), mean_mode = c("w0", "absolute", "weighted", "max_freq"),
    shape = "circle")
}
\arguments{

  \item{object}{a \code{\link{GenomicHilbertCurve-class}} object}
  \item{gr}{a \code{\link[GenomicRanges:GRanges-class]{GRanges}} object which contains the genomic regions to be mapped to the curve}
  \item{np}{pass to \code{\link{hc_points,HilbertCurve-method}}}
  \item{size}{size of points when \code{np <= 1}, pass to \code{\link{hc_points,HilbertCurve-method}}}
  \item{pch}{shape of the points when \code{np <= 1}, pass to \code{\link{hc_points,HilbertCurve-method}}}
  \item{gp}{graphic parameters of the points when \code{np <= 1}, pass to \code{\link{hc_points,HilbertCurve-method}}}
  \item{mean_mode}{pass to \code{\link{hc_points,HilbertCurve-method}}}
  \item{shape}{shape of the points when \code{np >= 2}, pass to \code{\link{hc_points,HilbertCurve-method}}}

}
\details{
It is basically a wrapper of \code{\link{hc_points,HilbertCurve-method}}.
}
\value{
Refer to \code{\link{hc_points,HilbertCurve-method}}
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
require(circlize)
require(GenomicRanges)
bed = generateRandomBed(nr = 100)
gr = GRanges(seqnames = bed[[1]], ranges = IRanges(bed[[2]], bed[[3]]))
hc = GenomicHilbertCurve()
hc_points(hc, gr, gp = gpar(fill = rand_color(length(gr))))
}


library(rgutenberg)

book <- rgutenberg()
book

wordcloud(book)


#script to create interactive Shiny maps for comparison of modelled vs observed land cover
#reads file created by CRAFTYsummary.r

rm(list=ls())

#script only creates Shiny for a single year (set here, year must be in the input data file)
yr<-2005

library(tidyverse)
library(sf)
library(RColorBrewer)  #for plotting
library(shiny)
library(leaflet)

#this directory should exist and contain the CRAFTYmunisServCap.csv
scenario <- "Testing_2018-08-16c"
runID <- "0-0"

#input/putput variables
cDat <- readr::read_csv(paste0("Data/",scenario,"/",runID,"/",scenario,"_CRAFTYmunisLC.csv"))

#note following shp was created using simplyfying_shapefiles.r
BRmunis <- st_read("Data/Vector/BRmunis_sim10_simple2.shp")

cDat_map <- left_join(BRmunis, filter(cDat, Year == yr), by = c("CD_GEOCMUn" ="muniID"))
cDat_map <- cDat_map %>% mutate(muniID = CD_GEOCMUn)

#if paltype == "numeric", mypal should be a RColorBrewer palette, e.g. "BuPu" or "Greens"
#if paltype == "factor", mypal should be a character vector of names colours
plotPolys <- function(mypal = "Greens", paltype = "numeric", shp = BR2000, data = cDat_map$diffcPropLC1, muni = cDat_map$muniID, label = "null")
{

  #print("pal")
  if(paltype == "numeric")
  {
    pal <- colorNumeric(
      palette = mypal,
      domain = data)
  }

  if(paltype == "factor")
  {
    pal <- colorFactor(
      palette = mypal,
      domain = data)
  }

  pop <- paste0("Value: ", data, "<br/>","muniID: ", muni)

  leaflet(shp) %>% addTiles() %>%
    addPolygons(color = ~pal(data), weight = 1, smoothFactor = 0.5,
                opacity = 1.0, fillOpacity = 0.75,
                highlightOptions = highlightOptions(color = "white", weight = 2,
                                                    bringToFront = TRUE),
                popup = pop
    )  %>%

    addLegend(pal = pal, values = ~data, title = label)
}

#shiny output
#####
ui<-fluidPage(
            mainPanel(
              selectInput("inpt", "Select Map:", c("diffcPropNat" = "LC1",
                "diffcPropOAg" = "OAg",
                "diffcPropAg" = "LC3",
                "diffcPropOth"="LC4",
                "diffcPropPas"="LC5",
                "ObsMode" = "oM",
                "ModMode" = "mM",
                "ModeError" = "eM",
                "CellsCorrectProp" = "ccp"))
  ),
  leafletOutput("plot",height = "800px")
)

server<- function(input, output){

 #approach below using plotPolys resets the map perspective when a new later is selected (ALL polys are redrawn)
 #in future, to maintain perspective when changing layers, consider leafletProxy() https://stackoverflow.com/q/44309409
 #https://www.rdocumentation.org/packages/leaflet/versions/2.0.1/topics/leafletProxy

  output$plot<-renderLeaflet({

    if(input$inpt=="LC1"){
      plotPolys(mypal = "RdYlGn", paltype = "numeric", shp = cDat_map, data = cDat_map$diffcProp1,
        muni = cDat_map$muniID, label = "Nature Prop Diffc")
    }

    else if(input$inpt=="LC2"){
      plotPolys(mypal ="RdYlGn", paltype = "numeric", shp = cDat_map, data = cDat_map$diffcProp2,
        muni = cDat_map$muniID, label = "Other Agri Prop Diffc")
    }

    else if(input$inpt=="LC3"){
      plotPolys(mypal = "RdYlGn", paltype = "numeric", shp = cDat_map, data = cDat_map$diffcProp3,
        muni = cDat_map$muniID, label = "Agriculture Prop Diffc")
    }

    else if(input$inpt=="LC4"){
      plotPolys(mypal = "RdYlGn", paltype = "numeric", shp = cDat_map, data = cDat_map$diffcProp4,
        muni = cDat_map$muniID, label = "Other Prop Diffc")
    }

    else if(input$inpt=="LC5"){
      plotPolys(mypal = "RdYlGn", paltype = "numeric", shp = cDat_map, data = cDat_map$diffcProp5,
                muni = cDat_map$muniID, label = "Pasture Prop Diffc")
    }

    else if(input$inpt=="oM"){
      map_pal <- c("darkgreen", "darkcyan", "green", "grey", "khaki")
      plotPolys(mypal = map_pal, paltype = "factor", shp = cDat_map, data = cDat_map$ObsMode,
        muni = cDat_map$muniID, label = "Observed Mode")
    }

    else if(input$inpt=="mM"){
      map_pal <- c("darkgreen", "darkcyan", "green", "grey", "khaki")
      plotPolys(mypal = map_pal, paltype = "factor", shp = cDat_map, data = cDat_map$ModMode,
        muni = cDat_map$muniID, label = "Model model")
    }

    else if(input$inpt=="eM"){
      map_pal <- c("darkgreen","red")
      plotPolys(mypal = map_pal, paltype = "factor", shp = cDat_map, data = cDat_map$diffcMode,
        muni = cDat_map$muniID, label = "Mode Difference?")
    }

    else if(input$inpt=="ccp"){
      plotPolys(mypal = "Reds", paltype = "numeric", shp = cDat_map, data = cDat_map$cellDiffcProp,
        muni = cDat_map$muniID, label = "Cell Diffc (Prop)")
    }

  })
}
shinyApp(ui=ui, server=server)


#' dmrff.meta
#'
#' Identify differentially methylated regions by meta-analysing multiple studies
#' using variance-weighted fixed effects meta-analysis.
#'
#' @param objects List of objects generated by \code{\link{dmrff.pre}}
#' for each participating EWAS.
#' @param p.cutoff Unadjusted p-value cutoff for membership in a candidate DMR
#' (Default: 0.05).
#' @param maxgap Maximum distance between consecutive features (Default: 500bp).
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing all candidate regions and their summary statistics.
#'
#' @examples
#' pre1 <- dmrff.pre(est1, se1, p1, meth1, ...)
#' pre2 <- dmrff.pre(est2, se2, p2, meth2, ...)
#' ...
#' pre9 <- dmrff.pre(est9, se9, p9, meth9, ...)
#' meta <- dmrff.meta(list(pre1, pre2, ..., pre9))
#' meta$dmrs[which(meta$dmrs$p.adjust < 0.05), ]
#'
#' @export
dmrff.meta <- function(objects, maxgap=500, p.cutoff=0.05, verbose=T) {
    stopifnot(is.list(objects))
    stopifnot(length(objects) > 1)

    ## sort object data by genomic position (rho is already sorted, see dmrff.pre)
    for (i in 1:length(objects)) {
        idx <- order(objects[[i]]$chr, objects[[i]]$pos)
        objects[[i]]$sites <- objects[[i]]$sites[idx]
        objects[[i]]$chr <- objects[[i]]$chr[idx]
        objects[[i]]$pos <- objects[[i]]$pos[idx]
        objects[[i]]$estimate <- as.numeric(objects[[i]]$estimate[idx])
        objects[[i]]$se <- as.numeric(objects[[i]]$se[idx])
    }

    ## identify a set of CpG sites in every dataset
    sites <- objects[[1]]$sites
    for (i in 2:length(objects))
        sites <- intersect(sites, objects[[i]]$sites)

    ## extract CpG site summary statistics
    estimate <- sapply(objects, function(obj)
                       obj$estimate[match(sites, obj$sites)])
    se <- sapply(objects, function(obj)
                 obj$se[match(sites, obj$sites)])

    ## meta-analysis CpG site associations
    ma <- ivwfe.ma(estimate, se)
    idx <- match(sites, objects[[1]]$sites)
    ma$chr <- objects[[1]]$chr[idx]
    ma$pos <- objects[[1]]$pos[idx]

    ## identify candidate regions
    candidates <- dmrff.candidates(ma$estimate, ma$p.value, ma$chr, ma$pos,
                                   maxgap=maxgap, p.cutoff=p.cutoff,
                                   verbose=verbose)

    ## shrink candidate regions and meta-analyze statistics
    compute.dmr.stats <- function(start.idx,end.idx) {
        stats <- sapply(1:length(objects), function(i) {
            start.idx <- which(objects[[i]]$sites == sites[start.idx])
            end.idx <- which(objects[[i]]$sites == sites[end.idx])
            idx <- start.idx:end.idx
            if (length(idx) > ncol(objects[[i]]$rho))
                return(c(B=0,S=1))
            ivwfe.stats(objects[[i]]$estimate[idx],
                        objects[[i]]$se[idx],
                        rho=extract.rho(objects[[i]]$rho[idx,,drop=F]))
        })
        ivwfe.ma(stats["B",,drop=F], stats["S",,drop=F])
    }
    compute.dmr.z <- function(start.idx,end.idx) {
        compute.dmr.stats(start.idx, end.idx)$z
    }
    stats <- shrink.candidates(candidates$start.idx,
                               candidates$end.idx,
                               compute.dmr.z)

    full <- do.call(rbind, mclapply(1:nrow(stats), function(i) {
        compute.dmr.stats(stats$start.idx[i], stats$end.idx[i])
    }))

    stats$B <- NA
    stats$S <- NA
    stats$estimate <- full[,"estimate"]
    stats$se <- full[,"se"]

    list(ewas=ma,
         dmrs=collate.stats(stats, ma$chr, ma$pos))
}

#' dmrff.cohort
#'
#' Identify differentially methylated regions
#' within an individual dataset with a `pre` object.
#'
#' @param object Object generated by \code{\link{dmrff.pre}} for the dataset.
#' @param p.cutoff Unadjusted p-value cutoff for membership in a candidate DMR
#' (Default: 0.05).
#' @param maxgap Maximum distance between consecutive features (Default: 500bp).
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing all candidate regions and their summary statistics.
#'
#' @examples
#' pre <- dmrff.pre(est, se, p, meth, ...)
#' dmrs <- dmrff.cohort(pre)
#' dmrs[which(dmrs$p.adjust < 0.05), ]
#'
#' @export
dmrff.cohort <- function(object, maxgap=500, p.cutoff=0.05, verbose=T) {
    idx <- order(object$chr, object$pos)
    object$sites <- object$sites[idx]
    object$chr <- object$chr[idx]
    object$pos <- object$pos[idx]
    object$estimate <- as.numeric(object$estimate[idx])
    object$se <- as.numeric(object$se[idx])
    object$p.value <- 2*pnorm(abs(object$estimate/object$se), lower.tail=F)

    candidates <- dmrff.candidates(estimate=object$estimate,
                                   p.value=object$p.value,
                                   chr=object$chr,
                                   pos=object$pos,
                                   maxgap=maxgap,
                                   p.cutoff=p.cutoff,
                                   verbose=verbose)

    stats <- shrink.candidates(candidates$start.idx, candidates$end.idx,
                               function(start.idx,end.idx) {
                                   idx <- start.idx:end.idx
                                   if (length(idx) > ncol(object$rho)) return(0)
                                   ivwfe.getz(object$estimate[idx], object$se[idx],
                                              rho=extract.rho(object$rho[idx,,drop=F]))
                               })

    full <- do.call(rbind, mclapply(1:nrow(stats), function(i) {
        idx <- stats$start.idx[i]:stats$end.idx[i]
        if (length(idx) > ncol(object$rho)) return(c(B=0,S=1))
        ivwfe.stats(object$estimate[idx], object$se[idx],
                    rho=extract.rho(object$rho[idx,,drop=F]))
    }))

    stats$estimate <- stats$B <- full[,"B"]
    stats$se <- stats$S <- full[,"S"]

    collate.stats(stats, object$chr, object$pos)
}

extract.rho <- function(pre) {
    n <- nrow(pre)
    rho <- diag(x=1.05, n)
    if (n > 1)
        for (i in 1:(n-1)) {
            vals <- pre[i,1:(n-i)]
            rho[i,(i+1):n] <- vals
            rho[(i+1):n,i] <- vals
        }
    rho
}


#!/usr/bin/env Rscript

require(sys)
require(data.table)

vcffile="08CallSNPsNovo/markers.vcf.gz"
syncfile="output.sync"

cmd="bcftools"
args=c("query","-f","%CHROM\t%POS\t%REF\t%ALT[\t%RO:%AO]\n",vcffile)
exec_wait(cmd,args,std_out="foo.txt",std_err="bcftools.err")

dt=fread("foo.txt")
names(dt)[1:4]=c("CHROM","POS","REF","ALT")
dt=melt(dt,id.vars=names(dt)[1:4],variable.name="POP",value.name="COUNTS")
dt[,c("COUNT1","COUNT2"):=tstrsplit(COUNTS,':')]
dt[,COUNTS:=NULL]
dt[,c("COUNT1","COUNT2"):=.(as.integer(COUNT1),as.integer(COUNT2))]
bases=c('A','C','G','T','N')
dt=na.omit(dt[REF%in%bases & ALT%in%bases])
mkcstring=function(r,a,c1,c2)
{
  cvec=c(A=0L,C=0L,G=0L,T=0L,N=0L,DEL=0L)
  cvec[c(r,a)]=c(c1,c2)
  return(paste(cvec,collapse=':'))
}
dt[,cstring:=mkcstring(REF,ALT,COUNT1,COUNT2),
   by=.(CHROM,POS,POP)]
fwrite(na.omit(dcast(dt,CHROM+POS+REF~POP,value.var="cstring")),
       file=syncfile,
       sep='\t',
       col.names=FALSE)


dewPoint <- function(celsius, humidity) {
    .Call('biometeoR_dewPoint', PACKAGE = 'biometeoR', celsius, humidity)
}


#Libraries to import
library(ggplot2)
library(reshape2)
library(cowplot)

#Read in files, then grab the time points from a header
c3 <- read.table("timeseries_cluster-eps_0.16-num_3.csv",sep=",",header=TRUE)
c6 <- read.table("timeseries_cluster-eps_0.16-num_6.csv",sep=",",header=TRUE)
c8 <- read.table("timeseries_cluster-eps_0.16-num_8.csv",sep=",",header=TRUE)
tp <- read.table("timeseries_cluster-eps_0.16-num_3.csv",sep=",")[1,6:ncol(c3)]
all <- read.table("all_clusters-eps_0.16.csv",sep=",")
tp.totals <- colSums(all[,7:ncol(all)])

#Melt the data
c3 <- melt(t(c3[,6:ncol(c3)]))
c3$value <- c3$value/tp.totals
c6 <- melt(t(c6[,6:ncol(c6)]))
c6$value <- c6$value/tp.totals
#Numbering starts at 1 for each cluster, so add the previous max
c6$Var2 <- c6$Var2 + max(c3$Var2)
c8 <- melt(t(c8[,6:ncol(c8)]))
c8$Var2 <- c8$Var2 + max(c6$Var2)
c8$value <- c8$value/tp.totals
clusters <- rbind(c3, c6, c8)

#Make a data frame
df <- data.frame(Sequence=clusters$Var2, Abundance=clusters$value, TSC=as.factor(c(rep(3,dim(c3)[1]),rep(6,dim(c6)[1]),rep(8,dim(c8)[1]))), Time=rep(as.vector(t(tp)),dim(clusters)[1]/length(tp)))
levels(df$TSC)<-c("TSC 3", "TSC 6", "TSC 8")

#<3 ggplot
p<-ggplot(df, aes(x=Time,y=Abundance,color=as.factor(TSC),Group=Sequence))+geom_line(alpha=0.7)
p<-p+xlab("Time (days)")+ylab("Sequence Relative Abundance")+theme(legend.position='none')+facet_grid(TSC~.,scales="free_y")

ggsave("Figure3.pdf",p,width=4,height=5)


#!/usr/bin/env Rscript

library("R.utils")
source("http://www.bioconductor.org/biocLite.R")
library("affy")
library("simpleaffy")
library("scales")
library("limma")
library("SAGx")
library("Hmisc")
library("Heatplus")
library("gplots")
library("cluster")
library("GEOquery")
library("topGO")
library("gridExtra")

#cwd = getwd() # this works from the command line but not in RStudio
cwd = "/Users/kyclark/work/abe516-project1"
setwd(cwd)
data_dir = file.path(cwd, 'data')
if (!dir.exists(data_dir)) {
  stop(paste0("Missing data dir ", data_dir))
}

figures_dir = file.path(cwd, 'figures')
if (!dir.exists(figures_dir)) {
  dir.create(figures_dir)
}

tables_dir = file.path(cwd, 'tables')
if (!dir.exists(tables_dir)) {
  dir.create(tables_dir)
}

dat = ReadAffy(celfile.path = "data")
num_samples = length(dat)
groups = c("C", "Bs", "Efs", "Efm")
fl <- factor(c(rep('0', 2), rep('1', 3), rep('2', 3), rep('3', 3), rep('0', 2)),
             labels=groups)

printf("There are %s features in %s samples\n", length(featureNames(dat)), num_samples)

#
# Raw plots
#
printf("Examing raw values\n")
palette(brewer_pal(type = "seq", palette = "Set2")(length(groups)))
png(filename = file.path(figures_dir, "raw-box-plot.png"))
boxplot(dat, names = fl, main = "Raw", las = 2, col = fl)
invisible(dev.off())

png(filename = file.path(figures_dir, "raw-ma-plot.png"), width = 600, height = 800)
par(mfrow = c(5,3))
MAplot(dat, plot.method = "smoothScatter")
invisible(dev.off())

dat.rmabg = bg.correct(dat, "rma")
dat.norm = normalize(dat.rmabg, "quantiles")
png(filename = file.path(figures_dir, "norm-box-plot.png"))
boxplot(dat.norm, main = "Normalized", las = 2, col = as.factor(groups))
invisible(dev.off())

png(filename = file.path(figures_dir, "norm-ma-plot.png"), width = 600, height = 800)
par(mfrow = c(5,3))
MAplot(dat.norm, plot.method = "smoothScatter")

#
# Rather than manually running each error-correcting step, we can use "expresso"
#
print("Running expresso")
eset <- expresso(dat,
                 bgcorrect.method = "rma",
                 normalize.method = "quantiles",
                 pmcorrect.method = "pmonly",
                 summary.method   = "medianpolish")

design <- model.matrix(~ 0 + fl) # original
colnames(design) = groups
#
# To get the metadata we want to see in the output, it's necessary to use the SOFT file
# ftp://ftp.ncbi.nlm.nih.gov/geo/series/GSE95nnn/GSE95636/soft/GSE95636_family.soft.gz
# The GEOquery library provides a "getGEO" function that will download this and
# provide us with the corrected expression data.
#
gset <- getGEO("GSE95636", GSEMatrix = TRUE, AnnotGPL = TRUE)
if (length(gset) > 1) idx <- grep("GPL200", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]
gset$description <- fl
design <- model.matrix(~ description + 0, gset)
colnames(design) <- levels(fl)

fit <- lmFit(gset, design)
contrast.matrix <- makeContrasts(Efm-C, Efs-C, Bs-C, Efs-Bs, Efm-Efs, levels = design)
fit1 <- contrasts.fit(fit, contrast.matrix)
fit2 <- eBayes(fit1)
tt.all = topTable(fit2,
                  adjust = "fdr",
                  p.value = 0.05,
                  lfc = 1,
                  sort.by = "B",
                  number = 250)
write.table(tt.all,
            file = file.path(tables_dir, "top_overall.tab"),
            row.names = FALSE,
            sep = "\t")

for (coef in 1:5) {
  filename = file.path(tables_dir, paste0("top250-c", coef, ".tab"))
  printf("Writing '%s'\n", filename)
  tt = topTable(fit2,
                coef = coef,
                adjust = "fdr",
                sort.by = "B",
                lfc = 1,
                number = 250)

  write.table(tt, file = filename, row.names = F, sep = "\t")
}

results = decideTests(fit2,
                      adjust = "fdr",
                      p = 0.05,
                      lfc = 1)

summary(results)

printf("Writing Venn diagrams\n")
png(filename = file.path(figures_dir, "venn.png"), width = 800, height = 400)
par(mfrow = c(1, 2))
#vennDiagram(results, main = "Diff Exp Genes")
vennDiagram(results, include = "down", main = "Down Regulated")
vennDiagram(results, include = "up", main = "Up Regulated")
invisible(dev.off())

printf("Writing volcano plots\n")
png(filename = file.path(figures_dir, "volcano.png"),
    width = 800,
    height = 800)
par(mfrow = c(2,3))
volcanoplot(fit2,
            coef = 1,
            main = "E_faecium-Control",
            names = row.names(fit2$coefficients),
            highlight = 10)
volcanoplot(fit2,
            coef = 2,
            main = "B_subtilis-Control",
            names = row.names(fit2$coefficients),
            highlight = 10)
volcanoplot(fit2,
            coef = 3,
            main = "E_faecium-B_subtilis",
            names = row.names(fit2$coefficients),
            highlight = 10)
volcanoplot(fit2,
            coef = 4,
            main = "E_faecium-E_faecalis",
            names = row.names(fit2$coefficients),
            highlight = 10)
volcanoplot(fit2,
            coef = 5,
            main = "E_faecium-E_faecalis",
            names = row.names(fit2$coefficients),
            highlight = 10)
invisible(dev.off())

#
# Find the top GO functions; many of the function fields have multiple
# functions separated by "///", so we split on that; additionally, some
# of the function names are very long, so we remove (gsub) everything after
# a comma to get a usable name. As there are so many, we use only those
# occuring with a frequency greater than X
#
go_functions = sub(",.*", "",
                   unlist(strsplit(tt.all$GO.Function, '///', fixed = T)))
function_count = as.data.frame(table(go_functions))
colnames(function_count) = c("func", "freq")
top_functions = function_count[function_count$freq > 3,]

#
# There are too many processes to show, so we need to filter
# to those with a frequency greater than X
#
go_processes = unlist(strsplit(tt.all$GO.Process, '///', fixed = T))
process_count = as.data.frame(table(go_processes))
colnames(process_count) = c("process", "freq")
top_processes = process_count[process_count$freq > 3,]

#
# This code is ugly, but it's necessary to force ggplot to keep the order
#
top_functions$func = factor(top_functions$func,
                            levels = top_functions$func[order(top_functions$freq)])
top_processes$process = factor(top_processes$process,
                               levels = top_processes$process[order(top_processes$freq)])

#
# ggplot doesn't play nicely with par, so we have to use gridExtra
#
png(filename = file.path(figures_dir, "go.png"),
    width = 800,
    height = 600)
p1 = ggplot(data=top_functions, aes(x=func, y=freq)) +
  geom_bar(stat="identity", fill="#56B4E9", colour="black") +
  coord_flip()
p2 = ggplot(data=top_processes, aes(x=process, y=freq)) +
  geom_bar(stat="identity", fill="#56B4E9", colour="black") +
  coord_flip()
grid.arrange(p1, p2, ncol=2, nrow = 1)
invisible(dev.off())

#
# Genomic location
#
locs = unlist(strsplit(tt.all$Chromosome.annotation, '///', fixed = T))
chromosome = sub('Chromosome ', '', sub(',.*', '', locs))
png(filename = file.path(figures_dir, 'chromosomes.png'))
qplot(chromosome)
invisible(dev.off())

#
# Clustering
#
printf("Cluster analysis\n")
#get the expression matrix form eset
eset.expr = exprs(eset)
#extract overall differential expressed genes from expression matrix
DE.all = eset.expr[rownames(tt.all),]
#compute distance matrix
dist.cor = as.dist(1 - cor(t(DE.all)))
#hierarchical clustering
hcfit = hclust(dist.cor, method = 'ave')

#
# Using gap statistic to determine k in HC
#
png(filename = file.path(figures_dir, "gapstat.png"),
    width = 800,
    height = 800)
k = 6
Gap = rep(0,k)
se = rep(0,k)
for (i in 2:k) {
  mem = cutree(hcfit, i)
  result = gap(DE.all, class=mem)
  Gap[i] = result[1]
  se[i] = result[2]
}
errbar(1:k, Gap, Gap-se, Gap+se, xlab = "Number of clusters")
lines(1:k, Gap)
invisible(dev.off())

#
# Using silhoutte width to determine k
#
png(filename = file.path(figures_dir, "silhouette.png"),
    width = 800,
    height = 800)
k = 10
sil = rep(0,k)
for (i in 2:k){
  mem = cutree(hcfit,i)
  aa = silhouette(mem, dist(DE.all))
  sil[i] = mean(aa[,3])
}
plot(1:k,sil)
lines(1:k,sil)
invisible(dev.off())

#
# Heatmap
#
png(filename = file.path(figures_dir, "heatmap.png"),
    width = 800,
    height = 800)
c2 = cutree(hcfit,k=2)
colnames(DE.all) = c(rep('E. coli', 2),
                     rep('B. subtilis', 3),
                     rep('E. faecalis', 3),
                     rep('E. faecium', 3),
                     rep('E. coli', 2))
heatmap_plus(t(scale(t(DE.all))),
             clus = c2,
             addvar = design,
             col = greenred(20))
invisible(dev.off())

#
# plot the resulting dendrogram
#
png(filename = file.path(figures_dir, "dendrogram.png"),
    width = 800,
    height = 400)
plot(hcfit)
invisible(dev.off())

# cut the tree at height 1.25
hcfit1 = cutree(hcfit, h = 1.25)

# generate 2 clusters and save them in a table
clus = table(names(hcfit1), hcfit1)
write.table(clus,
            file = file.path(tables_dir, "clus.tab"),
            row.names = TRUE,
            sep = "\t")
invisible(dev.off())

printf("All done!\n")


#!/usr/bin/env Rscript
#
#  phyloseq_ordinations.r - generate ordination graphics through phyloseq
#
#  Version 1.0.0 (December 24, 2015)
#
#  Copyright (c) 2014-- Lela Andrews
#
#  This software is provided 'as-is', without any express or implied
#  warranty. In no event will the authors be held liable for any damages
#  arising from the use of this software.
#
#  Permission is granted to anyone to use this software for any purpose,
#  including commercial applications, and to alter it and redistribute it
#  freely, subject to the following restrictions:
#
#  1. The origin of this software must not be misrepresented; you must not
#     claim that you wrote the original software. If you use this software
#     in a product, an acknowledgment in the product documentation would be
#     appreciated but is not required.
#  2. Altered source versions must be plainly marked as such, and must not be
#     misrepresented as being the original software.
#  3. This notice may not be removed or altered from any source distribution.
#

## Load libraries
library(phyloseq)
library(ggplot2)
library(scales)
library(grid)
library(plyr)
theme_set(theme_bw())

## Recieve input files from bash
args <- commandArgs(TRUE)

otufile=(args[1])
mapfile=(args[2])
treefile=(args[3])
factor=(args[4])

## Load data into phyloseq
map=import_qiime_sample_data(mapfile)
tree=read_tree(treefile)
otus=import_biom(otufile,parseFunction=parse_taxonomy_greengenes)
mergedata=merge_phyloseq(otus,tree,map)
MD=mergedata

## Filter taxa not present at least 5 times in at least 10% of samples
md0 = genefilter_sample(MD, filterfun_sample(function(x) x > 5), A = 0.1 * nsamples(MD))
MD1=prune_taxa(md0, MD)

## Ordinate command
MD.ord <- ordinate(MD1, "NMDS", "bray")

## Make taxa-only ordination (NMDS)
p1 = plot_ordination(MD1, MD.ord, type = "taxa", color = "Class", title = "Faceted taxonomic ordination (NMDS)")
## Output pdf graphic
pdf(paste0(factor, "_taxa-only_NMDS.pdf"))
plot(p1)
dev.off()

## Make faceted version of taxa-only ordination
#p1 + facet_wrap(~Class, 2)
## Output pdf graphic
pdf(paste0(factor, "_taxa-only-faceted_NMDS.pdf"))
plot(p1 + facet_wrap(~Class, 2))
dev.off()

## Make samples-only ordination (NMDS)
p2 = plot_ordination(MD1, MD.ord, type = "samples", color = factor, title = "Samples ordination (NMDS)")
## Output pdf graphic
pdf(paste0(factor, "_samples-only_NMDS.pdf"))
plot(p2)
dev.off()

## Samples-only ordination with polygon fill
#p21 = p2 + geom_polygon(aes(fill = factor)) + geom_point(size = 5) + ggtitle("Samples ordination with fill (NMDS)")
## Output pdf graphic
#pdf(paste0(factor, "_samples-only-polygon_NMDS.pdf"))
#plot(p21)
#dev.off()

## Make biplot
p3 = plot_ordination(MD1, MD.ord, type = "biplot", color = factor, shape = "Class", title = "Biplot")
#MD1.shape.names = get_taxa_unique(MD1, "Class")
#MD1.shape <- 15:(15 + length(MD1.shape.names) - 1)
#names(MD1.shape) <- MD1.shape.names
#MD1.shape["samples"] <- 16
#p3 + scale_shape_manual(values = MD1.shape)
## Output pdf graphic
pdf(paste0(factor, "_biplot_NMDS.pdf"))
plot(p3)
dev.off()

## Make splitplot
p4 = plot_ordination(MD1, MD.ord, type = "split", color = "Class", shape = factor, title = "split") + geom_point(size = 5)
## Output pdf graphic
pdf(paste0(factor, "_split-biplot_NMDS.pdf"))
plot(p4)
dev.off()

## Composite faceted ordination
dist = "bray"
ord_meths = c("DCA", "CCA", "RDA", "DPCoA", "NMDS", "MDS", "PCoA")
plist = llply(as.list(ord_meths), function(i, physeq, dist) {
    ordi = ordinate(physeq, method = i, distance = dist)
    plot_ordination(physeq, ordi, "samples", color = factor)
}, MD1, dist)
names(plist) <- ord_meths
pdataframe = ldply(plist, function(x) {
    df = x$data[, 1:2]
    colnames(df) = c("Axis_1", "Axis_2")
    return(cbind(df, x$data))
})
names(pdataframe)[1] = "method"
p5 = ggplot(pdataframe, aes(Axis_1, Axis_2, color = factor, fill = factor))
p5 = p5 + geom_point(size = 4) + geom_polygon()
p5 = p5 + facet_wrap(~method, scales = "free")
p5 = p5 + scale_fill_brewer(type = "qual", palette = "Set1")
p5 = p5 + scale_colour_brewer(type = "qual", palette = "Set1")
## Output pdf graphic
pdf(paste0(factor, "_composite_ordinations.pdf"))
plot(p5)
dev.off()

## Change pdf resolution like this (doesnt change text size):
#pdf("network.pdf", height = 12, width = 12)

## .png output instead
#png('network.png', height="12")
#plot(networkout)
#dev.off()


library(class)
dataset <- read.csv('/home/filip/Desktop/MachineLearning/dataset.csv')
cases = dataset$cases
deaths = dataset$deaths
deaths


library(data.table)
library(rstan)
library(lognorm)
library(dplyr)

args = list(
        seed = 42,
        chain = 1,
        outdir= "~/Box\ Sync/2020/R0t/results/ifr_by_age_prior",
        indir = "~/git/R0t",
        cmdstan = 1,
        #stanModelFile = 'base_age_prior_ifr_200820a7_cmdstanv',
        stanModelFile = 'base_age_prior_ifr_200820b5_cmdstanv',
        job_tag= 'new_data_spain_England',
        job_id='41286'
)

args$job_dir <- file.path(args$outdir,paste0(args$stanModelFile,'-',args$job_tag,'-',args$job_id))

outfile.base <- paste0(args$job_dir, "/",  args$stanModelFile , "-", args$job_tag)

# Outputs of the log normal fit from 28/08/2020
load(file.path(args$job_dir, paste0(basename(args$job_dir), '_stanout.RData')) )

fit = rstan:::sflist2stanfit(list(fit))

# divergences
sampler_params <- get_sampler_params(fit, inc_warmup = FALSE)
sampler_params_chain1 <- sampler_params[[1]]
sum(sampler_params_chain1[,"divergent__"])

file <- paste0(outfile.base, "-convergence_diagnostics.rds")
cat("write ", file)
summary.par <- summary(fit)$summary
neff <- as.numeric(summary.par[, which(colnames(summary.par) == "n_eff")])
neff_range = prettyNum(round(range(neff)),big.mark=",")
Rhat <- summary.par[, which(colnames(summary.par) == "Rhat")]
Rhat_range <- round(range(Rhat), digits = 4)
saveRDS(list(neff_range, Rhat_range), file = file, version = 2)

age_predict <- c(0, seq(2.5, 97.5, 5))
fits <- as.data.table(summary.par)
fits[, variable:= rownames(summary.par)]
colnames(fits)[4:8] <-  c('CL','IL','M','IU','CU')
fits[, age.idx:= gsub('.*\\[([0-9]+)\\].*','\\1',variable)]
tmp <- fits[, which(variable==age.idx)]
set(fits, tmp, 'age.idx', NA_character_)
set(fits, NULL, 'age.idx', fits[, as.integer(age.idx)])
fits <- merge(fits, data.table(age.idx=seq_along(age_predict), age=age_predict), by='age.idx', all.x=TRUE)

#	make trace plot
color_scheme_set("mix-blue-red")
target.pars <- c('gp','alpha','alpha0','alpha1','beta','beta0','beta1','obs_rnd','study_rnd','age_rnd','sero_p')
target.pars <- names(fit)[ grepl(paste(paste0('^',target.pars),collapse = '|'),names(fit)) ]
p <- rstan::traceplot(fit, pars= target.pars, inc_warmup=TRUE, ncol = 1)
outfile <- file.path(args$outdir, paste0(basename(args$outdir), '_traceplot.pdf'))
cat('\n write pairs plot', outfile)
ggsave(file=outfile,p,w=20, h=length(target.pars)*3,limitsize = FALSE)

# make pair plot
target.pars <- c('gp','alpha','alpha0','alpha1','beta','beta0','beta1','obs_rnd','age_rnd','study_rnd')
target.pars <- names(fit)[ grepl(paste(paste0('^',target.pars),collapse = '|'),names(fit)) ]
color_scheme_set("mix-blue-red")
tmp <- rstan::extract(fit, pars=target.pars )
tmp <- unlist(tmp)
tmp <- matrix(tmp, ncol=length(target.pars), byrow=FALSE)
colnames(tmp) <- target.pars
#p <- mcmc_pairs(tmp, diag_fun = "dens", off_diag_fun = "hex")
p <- mcmc_pairs(tmp, diag_fun = "dens")
outfile <- file.path(args$job_dir, paste0(basename(args$job_dir), '_pairsplot.pdf'))
cat('\n write pairs plot', outfile)
ggsave(file=outfile, p, w=20, h=20, limitsize = FALSE)

# divergent chains
divergent <- get_sampler_params(fit, inc_warmup=FALSE)[[1]][,'divergent__']
sum(divergent)

params_cp9 <- as.data.frame(extract(fit, permuted=FALSE))
names(params_cp9) <- gsub("chain:1.", "", names(params_cp9), fixed = TRUE)
names(params_cp9) <- gsub("[", ".", names(params_cp9), fixed = TRUE)
names(params_cp9) <- gsub("]", "", names(params_cp9), fixed = TRUE)
params_cp9$iter <- 1:9000

params_cp9$divergent <- divergent

div_params_cp <- params_cp9[params_cp9$divergent == 1,]
nondiv_params_cp <- params_cp9[params_cp9$divergent == 0,]

pdf(file = file.path(args$outdir, "pairs_plot_study_rnde.1_study_rnde_sd_9.pdf"))
plot(nondiv_params_cp$study_rnde.1, log(nondiv_params_cp$study_rnde_sd),
     col="#8F2727", pch=16, cex=0.8, xlab="study_rnde.2", ylab="log(study_rnde_sd)")
points(div_params_cp$study_rnde.1, log(div_params_cp$study_rnde_sd),
       col="green", pch=16, cex=0.8)
dev.off()

pdf(file = file.path(args$outdir, "pairs_plot_study_rnde1.2_study_rnde_sd2_9.pdf"))
plot(nondiv_params_cp$study_rnde2.1, log(nondiv_params_cp$study_rnde_sd2),
     col="#8F2727", pch=16, cex=0.8, xlab="study_rnde2.2", ylab="log(study_rnde_sd2)")
points(div_params_cp$study_rnde2.1, log(div_params_cp$study_rnde_sd2),
       col="green", pch=16, cex=0.8)
dev.off()

pdf(file = file.path(args$outdir, "pairs_plot_study_rnde_sd-study_rnde_sd2-9.pdf"))
plot(log(nondiv_params_cp$study_rnde_sd), log(nondiv_params_cp$study_rnde_sd2),
     col="#8F2727", pch=16, cex=0.8, xlab="log(study_rnde_sd)", ylab="log(study_rnde_sd2)")
points(log(div_params_cp$study_rnde_sd), log(div_params_cp$study_rnde_sd2),
       col="green", pch=16, cex=0.8)
dev.off()


library(Rcpp)
library(ascr)
library(spatstat)
## Sourcing functions.
source("fit-cuerate-scr.r")
sourceCpp("fit-cuerate-scr.cpp")

## Loading in fitted models.
load("fit-cuerate.RData")

set.seed(1234)
## Speed of sound (metres per second).
speed.sound <- 330
## Number of detectors.
n.traps <- nrow(traps)
## The x- and y-limits of the mask area.
xlim <- range(mask[, 1])
ylim <- range(mask[, 2])
## The area of a bounding box that covers the mask.
a.bb <- diff(xlim)*diff(ylim)

## Setting parameter values.
D <- fit.cuerate$results[1, 1]
lambda0 <- fit.cuerate$results[2, 1]
sigma <- fit.cuerate$results[3, 1]
lambda.c <- fit.cuerate$results[4, 1]
sigma.toa <- fit.cuerate$results[5, 1]/1000
pars <- c(D = D, lambda0 = lambda0, sigma = sigma, lambda.c = lambda.c, sigma.toa = sigma.toa)
## Start values for scr.fit.
start <- c(D = D, g0 = lambda0, sigma = sigma,
           lambda_c = lambda.c, sigma_toa = sigma.toa*1000)
## Expected number of animals within the mask bounding box.
e.n.animals <- D/10000*a.bb

## Number of simulation iterations.
n.sims <- 1000
## Initialising matrix to store point estimates.
ests1 <- matrix(0, nrow = n.sims, ncol = 4)
ests2 <- matrix(0, nrow = n.sims, ncol = 5)
## Initialising array to store confidence intervals.
cis1 <- array(0, dim = c(n.sims, 4, 2))
cis2 <- array(0, dim = c(n.sims, 5, 2))
## Initialising number of detected animals.
n.detected <- numeric(n.sims)
## Loop for simulation.
for (i in 1:n.sims){
    ## Simulated number of animals in the bounding box.
    n.animals <- rpois(1, e.n.animals)
    ## Simulated locations of animals.
    animal.locs <- cbind(runif(n.animals, xlim[1], xlim[2]),
                         runif(n.animals, ylim[1], ylim[2]))
    ## Distance matrix for each animal-microphone pairing.
    animal.dists <- crossdist(animal.locs[, 1], animal.locs[, 2],
                       traps[, 1], traps[, 2])
    ## Detection probabilities for each animal-microphone pairing.
    det.p <- 1 - exp(-lambda0*exp(-animal.dists^2/(2*sigma^2)))
    ## Number of calls made by each animal.
    n.calls <- rpois(n.animals, lambda.c)
    ## Initialising vector of indicators for detection.
    animal.detected <- logical(n.animals)
    ## Simulating the capture history matrix for each individual.
    capt.list <- vector(mode = "list", length = n.animals)
    for (j in 1:n.animals){
        capt.list[[j]] <- matrix(0, nrow = n.calls[j], ncol = n.traps)
        for (k in seq_along(numeric(n.calls[j]))){
            capt.list[[j]][k, ] <- rbinom(n.traps, 1, det.p[j, ])
        }
        animal.detected[j] <- sum(capt.list[[j]]) > 0
    }
    n.detected[i] <- sum(animal.detected)
    ## Removing undetected animals.
    capt.list <- capt.list[animal.detected]
    animal.locs <- animal.locs[animal.detected, ]
    ## For each animal detected, removing undetected calls.
    for (j in 1:n.detected[i]){
        capt.list[[j]] <- capt.list[[j]][apply(capt.list[[j]], 1, sum) > 0, , drop = FALSE]
    }
    ## Combining submatrices into one big matrix.
    capt <- matrix(0, nrow = 0, ncol = n.traps)
    for (j in 1:n.detected[i]){
        capt <- rbind(capt, capt.list[[j]])
    }
    ## Number of detected calls by each animal.
    n.calls.detected <- sapply(capt.list, nrow)
    ## Determining animal IDs.
    ids <- rep(1:n.detected[i], times = sapply(capt.list, nrow))
    ## Creating a matrix of call locations.
    call.locs <- matrix(0, nrow = sum(n.calls.detected), ncol = 2)
    call.locs[, 1] <- rep(animal.locs[, 1], times = n.calls.detected)
    call.locs[, 2] <- rep(animal.locs[, 2], times = n.calls.detected)
    ## Distance matrix for each detected call-microphone pairing.
    call.dists <- crossdist(call.locs[, 1], call.locs[, 2],
                            traps[, 1], traps[, 2])
    ## Simulating times of arrival. Note that source time doesn't
    ## matter, see Borchers et al (2015), so here we assume all
    ## animals called at time zero.
    call.toa <- call.dists/speed.sound +
        matrix(rnorm(length(call.dists), 0, sigma.toa),
               ncol = ncol(call.dists), nrow = nrow(call.dists))
    ## Setting call.toa to zero for undetected calls.
    call.toa[capt == 0] <- 0
    ## Fitting model in ascr.
    capt.ascr <- list(bincapt = capt, toa = call.toa)
    fit1 <- fit.ascr(capt = capt.ascr, traps = traps, mask = mask, detfn = "hhn", trace = FALSE)
    ## Fitting new model.
    fit2 <- cuerate.scr.fit(capt, ids, traps, mask, detfn = "hhn",
                            toa = call.toa, start = start, trace = FALSE)
    ## Saving point estimates.
    ests1[i, ] <- coef(fit1)
    ests2[i, ] <- fit2$results[, 1]
    ## Saving confidence intervals.
    cis1[i, , 1] <- confint(fit1)[, 1]
    cis1[i, , 2] <- confint(fit1)[, 2]
    cis2[i, , 1] <- fit2$results[, 3]
    cis2[i, , 2] <- fit2$results[, 4]
    ## Plotting results as they come in.
    ests1.Dc <- ests1[1:i, 1]
    ests2.Dc <- ests2[1:i, 1]*ests2[1:i, 4]
    par(mfrow = c(1, 2))
    boxplot(ests1.Dc, ests2.Dc, ylim = c(0, max(c(ests1.Dc, ests2.Dc))), names = c("CD", "AD"))
    abline(h = D*lambda.c, lty = "dashed")
    ests2.D <- ests2[1:i, 1]
    boxplot(ests2.D, names = "new", ylim = c(0, max(ests2.D)))
    abline(h = D, lty = "dashed")
}

save.image("sim-results.RData")


#!/usr/bin/Rscript

# attempt to load a library implementing the Bradley-Terry model for inferring rankings based on
# comparisons; if it doesn't load, try to install it through R's in-language package management;
# otherwise, abort and warn the user
# https://www.jstatsoft.org/v48/i09/

# Add the repo to the R search path
options(repos = list(CRAN="http://cran.rstudio.com/"))

loaded <- library(BradleyTerry2, quietly=TRUE, logical.return=TRUE)
if (!loaded) { write("warning: R library 'BradleyTerry2' unavailable; attempting to install locally...", stderr())
              install.packages("BradleyTerry2")
              loadedAfterInstall <- library(BradleyTerry2, quietly=TRUE, logical.return=TRUE)
              if(!loadedAfterInstall) { write("error: 'BradleyTerry2' unavailable and cannot be installed. Aborting.", stderr()); quit() }
}
# similarly, but for the library to parse command line arguments:
loaded <- library(argparser, quietly=TRUE, logical.return=TRUE)
if (!loaded) { write("warning: R library 'argparser' unavailable; attempting to install locally...", stderr())
              install.packages("argparser")
              loadedAfterInstall <- library(argparser, quietly=TRUE, logical.return=TRUE)
              if(!loadedAfterInstall) { write("error: 'argparser' unavailable and cannot be installed. Aborting.", stderr()); quit() }
}
p <- arg_parser("sort a list using comparative rankings under the Bradley-Terry statistical model; see https://www.gwern.net/Resorter", name="resorter")
p <- add_argument(p, "--input", short="-i",
                  "input file: a CSV file of items to sort: one per line, with up to two columns. (eg both 'Akira\\n' and 'Akira, 10\\n' are valid).", type="character")
p <- add_argument(p, "--output", "output file: a file to write the final results to. Default: printing to stdout.")
p <- add_argument(p, "--verbose", "whether to print out intermediate statistics", flag=TRUE)
p <- add_argument(p, "--queries", short="-n", default=NA,
                  "Maximum number of questions to ask the user; defaults to N*log(N) comparisons. If already rated, 𝒪(n) is a good max, but the more items and more levels in the scale and more accuracy desired, the more comparisons are needed.")
p <- add_argument(p, "--levels", short="-l", default=5, "The highest level; rated items will be discretized into 1-l levels, so l=5 means items are bucketed into 5 levels: [1,2,3,4,5], etc")
p <- add_argument(p, "--quantiles", short="-q", "What fraction to allocate to each level; space-separated; overrides `--levels`. This allows making one level of ratings narrower (and more precise) than the others, at their expense; for example, one could make 3-star ratings rarer with quantiles like `--quantiles '0 0.25 0.8 1'`. Default: uniform distribution (1--5 → '0.0 0.2 0.4 0.6 0.8 1.0').")
p <- add_argument(p, "--no-scale", flag=TRUE, "Do not discretize/bucket the final estimated latent ratings into 1-l levels/ratings; print out inferred latent scores.")
p <- add_argument(p, "--progress", flag=TRUE, "Print out mean standard error of items")
argv <- parse_args(p)

# read in the data from either the specified file or stdin:
if(!is.na(argv$input)) { ranking <- read.csv(file=argv$input, stringsAsFactors=TRUE, header=FALSE); } else {
    ranking <- read.csv(file=file('stdin'), stringsAsFactors=TRUE, header=FALSE); }

# turns out noisy sorting is fairly doable in 𝒪(n * log(n)), so do that plus 1 to round up:
if (is.na(argv$queries)) { n <- nrow(ranking)
                           argv$queries <- round(n * log(n) + 1) }

# if user did not specify a second column of initial ratings, then put in a default of '1':
if(ncol(ranking)==1) { ranking$Rating <- 1; }
colnames(ranking) <- c("Media", "Rating")
# A set of ratings like 'foo,1\nbar,2' is not comparisons, though. We *could* throw out everything except the 'Media' column
# but we would like to accelerate the interactive querying process by exploiting the valuable data the user has given us.
# So we 'seed' the comparison dataset based on input data: higher rating means +1, lower means −1, same rating == tie (0.5 to both)
comparisons <- NULL
for (i in 1:(nrow(ranking)-1)) {
 rating1 <- ranking[i,]$Rating
 media1 <- ranking[i,]$Media
 rating2 <- ranking[i+1,]$Rating
 media2 <- ranking[i+1,]$Media
 if (rating1 == rating2)
  {
     comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0.5, "win2"=0.5))
  } else { if (rating1 > rating2)
           {
            comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=1, "win2"=0))
            } else {
              comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0, "win2"=1))
                   } } }
# the use of '0.5' is recommended by the BT2 paper, despite causing quasi-spurious warnings:
# > In several of the data examples (e.g., `?CEMS`, `?springall`, `?sound.fields`), ties are handled by the crude but
# > simple device of adding half of a 'win' to the tally for each player involved; in each of the examples where this
# > has been done it is found that the result is similar, after a simple re-scaling, to the more sophisticated
# > analyses that have appeared in the literature. Note that this device when used with `BTm` typically gives rise to
# > warnings produced by the back-end glm function, about non-integer 'binomial' counts; such warnings are of no
# > consequence and can be safely ignored. It is likely that a future version of `BradleyTerry2` will have a more
# > general method for handling ties.
suppressWarnings(priorRankings <- BTm(cbind(win1, win2), Media.1, Media.2, data = comparisons))

if(argv$verbose) {
  print("higher=better:")
  print(summary(priorRankings))
  print(sort(BTabilities(priorRankings)[,1]))
}

set.seed(2015-09-10)
cat("Comparison commands: 1=yes, 2=tied, 3=second is better, p=print estimates, s=skip, q=quit\n")
for (i in 1:argv$queries) {

 # with the current data, calculate and extract the new estimates:
 suppressWarnings(updatedRankings <- BTm(cbind(win1, win2), Media.1, Media.2, br=TRUE, data = comparisons))
 coefficients <- BTabilities(updatedRankings)
 # sort by latent variable 'ability':
 coefficients <- coefficients[order(coefficients[,1]),]

 if(argv$verbose) { print(i); print(coefficients); }

 # select two media to compare: pick the media with the highest standard error and the media above or below it with the highest standard error:
 # which is a heuristic for the most informative pairwise comparison. BT2 appears to get caught in some sort of a fixed point with greedy selection,
 # so every few rounds pick a random starting point:
 media1N <- if (i %% 3 == 0) { which.max(coefficients[,2]) } else { sample.int(nrow(coefficients), 1) }
 media2N <- if (media1N == nrow(coefficients)) { nrow(coefficients)-1; } else { # if at the top & 1st place, must compare to 2nd place
   if (media1N == 1) { 2; } else { # if at the bottom/last place, must compare to 2nd-to-last
    # if neither at bottom nor top, then there are two choices, above & below, and we want the one with highest SE; if equal, arbitrarily choose the better:
    if ( (coefficients[,2][media1N+1]) > (coefficients[,2][media1N-1])  ) { media1N+1 } else { media1N-1 } } }

 targets <- row.names(coefficients)
 media1 <- targets[media1N]
 media2 <- targets[media2N]

 if (argv$`progress`) { cat(paste0("Mean stderr: ", round(mean(coefficients[,2]))), " | "); }
 cat(paste0("Is '", as.character(media1), "' greater than '", as.character(media2), "'? "))
 rating <- scan("stdin", character(), n=1, quiet=TRUE)

 switch(rating,
        "1" = { comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=1, "win2"=0)) },
        "3" = { comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0, "win2"=1)) },
        "2" = { comparisons <- rbind(comparisons, data.frame("Media.1"=media1, "Media.2"=media2, "win1"=0.5, "win2"=0.5))},
        "p" = { estimates <- data.frame(Media=row.names(coefficients), Estimate=coefficients[,1], SE=coefficients[,2]);
                print(comparisons)
                print(warnings())
                print(summary(updatedRankings))
                print(estimates[order(estimates$Estimate),], row.names=FALSE) },
        "s" = {},
        "q" = { break; }
        )
}

# results of all the questioning:
if(argv$verbose) { print(comparisons); }

suppressWarnings(updatedRankings <- BTm(cbind(win1, win2), Media.1, Media.2, ~ Media, id = "Media", data = comparisons))
coefficients <- BTabilities(updatedRankings)
if(argv$verbose) { print(rownames(coefficients)[which.max(coefficients[2,])]);
                 print(summary(updatedRankings))
                 print(sort(coefficients[,1])) }

ranking2 <- as.data.frame(BTabilities(updatedRankings))
ranking2$Media <- rownames(ranking2)
rownames(ranking2) <- NULL

if(!(argv$`no_scale`)) {

    # if the user specified a bunch of buckets using `--quantiles`, parse it and use it,
    # otherwise, take `--levels` and make a uniform distribution
    quantiles <- if (!is.na(argv$quantiles)) { (sapply(strsplit(argv$quantiles, " "), as.numeric))[,1]; } else {
      seq(0, 1, length.out=(argv$levels+1)); }
    ranking2$Quantile <- with(ranking2, cut(ability,
                                    breaks=quantile(ability, probs=quantiles),
                                    labels=1:(length(quantiles)-1),
                                    include.lowest=TRUE))
    df <- subset(ranking2[order(ranking2$Quantile, decreasing=TRUE),], select=c("Media", "Quantile"));
    if (!is.na(argv$output)) { write.csv(df, file=argv$output, row.names=FALSE) } else { print(df); }
} else { # return just the latent continuous scores:
         df <- data.frame(Media=rownames(coefficients), Estimate=coefficients[,1]);
         if (!is.na(argv$output)) { write.csv(df[order(df$Estimate, decreasing=TRUE),], file=argv$output, row.names=FALSE); } else {
             print(finalReport); }
       }

cat("\nResorting complete")


#' @export
FindInformativeLoci <- function(outlierThresh, numOutliers, informativeThresh) {
  ######## Function to plot and calculate informative loci based on outlier threshold and difference threshold #####

  ######## Defaults ##########
  #  outlierThresh <- 0.1  ### level of divergence determining that individual as outlier
  #  numOutliers <- 4      ### number of outliers allowed per locus
  #  informativeThresh <- 0.0055

  if(missing(outlierThresh)){outThresh <- 0.1} else {outThresh <- outlierThresh}
  if(missing(numOutliers)){numOutThresh <- 4} else {numOutThresh <- numOutliers}
  if(missing(informativeThresh)){infoThresh <- 0.0055} else {infoThresh <- informativeThresh}
  alleleCheckMat <- matrix(nrow=numLoci,ncol=2)
  sdOutsCheckMat <- matrix(nrow=numLoci, ncol=2)
  sdDifs <- matrix(nrow=numLoci,ncol=1)
  outMat <- matrix(nrow=numLoci,ncol=2)
  dipTemp <- c()
  tetTemp <- c()
  for (i in 1:numLoci){
    locusMat <- allMat[allMat[,1]==testLoci[i],]
    sdDifs[i] <- sd(locusMat[,4])
    dipTemp <- locusMat[locusMat[,3]==2,4]
    dipSdTemp <- locusMat[locusMat[,3]==2,5]
    outMat[i,1] <- sum(dipTemp > outThresh)
    dipTemp <- dipTemp[dipTemp <= outThresh]
    tetTemp <- locusMat[locusMat[,3]==4,4]
    tetSdTemp <- locusMat[locusMat[,3]==4,5]
    outMat[i,2] <- sum(tetTemp > outThresh)
    tetTemp <- tetTemp[tetTemp <= outThresh]
    alleleCheckMat[i,1] <- mean(dipTemp)
    alleleCheckMat[i,2] <- mean(tetTemp)
    sdOutsCheckMat[i,1] <- mean(dipSdTemp)
    sdOutsCheckMat[i,2] <- mean(tetSdTemp)
  }
  alleleDifMat <- alleleCheckMat[,2] - alleleCheckMat[,1]
  iLoci <- c()
  InfsPDFPath = paste (c(str1,"/PloidyRFiles/InformativeLocigraph.pdf"), collapse = "")
  pdf(file = InfsPDFPath )
  plot(1:testLoci[length(testLoci)],rep(0,testLoci[length(testLoci)]), ylim=c(-.025,.03),cex=.01, xlab = "Locus", ylab = "Level of Divergence")
  for (i in 1:numLoci){
    if(sum(outMat[i,]) <= numOutThresh){
      if(alleleDifMat[i] != "NaN"){
        if(alleleDifMat[i] >= infoThresh){
          color <- "blue"
          iLoci<- rbind(iLoci, as.numeric(testLoci[i]))
          text(testLoci[i]+9,alleleDifMat[i],testLoci[i])
        }
        else{
          color <- "black"
        }
      }
      else{}

    }
    else{
      color = "red"
    }
    points(testLoci[i], alleleDifMat[i], col = color)
  }

  ##################################   RANKING   ##############################################################
  rankMat	<- matrix(nrow=length(iLoci),ncol=2)
  for (i in 1:length(iLoci)){
    rankMat[i,1] <- iLoci[i,]
    rankMat[i,2] <- alleleDifMat[which(testLoci==iLoci[i,])]
  }
  rankMat <- rankMat[sort.list(rankMat[,2],decreasing=TRUE),]
  cutMat <- rankMat
  assign("iLoci", iLoci, globalenv())
  assign("alleleCheckMat",alleleCheckMat,globalenv())
  assign("alleleDifMat",alleleDifMat,globalenv())
  assign("cutMat", cutMat, globalenv())
  assign("rankMat", cutMat, globalenv())
  assign("sdOutsCheckMat", sdOutsCheckMat, globalenv())
  write.table(sdOutsCheckMat, file = paste(c(str1,"/PloidyRFiles/sdOutsCheckMat.csv"), collapse = ""), row.names=FALSE, 		col.names=FALSE, sep=",")
  dev.off()
  cat(c("Writing:" , paste(c(str1,"/PloidyRFiles/InformativeLociGraph.pdf"), collapse = ""), "\n"))
}


#!/usr/bin/Rscript
#Rscript script common-path jaspar-dir id output
#example:
#Rscript pwmmatch.r /cluster/thashim/basepiq/common.r /cluster/thashim/basepiq/pwms/jaspar.txt 141 /cluster/thashim/basepiq/tmp/pwmout.RData

options(echo=TRUE)
args <- commandArgs(trailingOnly = TRUE)
print(args)

commondir = args[1]
jaspardir = args[2]
id = as.double(args[3])
outdir = args[4]

if(file.exists(paste0(outdir,id,'.pwmout.RData'))){
  stop("pwm file already exists")
}

source(commondir)

####
# load PWMs
####

#pwmin = 'pwms/'

importJaspar <- function(file=myloc) {
  vec <- readLines(file)
  vec <- gsub("\\[|\\]", "", vec)
  start <- grep(">", vec); end <- grep(">", vec) - 1
  pos <- data.frame(start=start, end=c(end[-1], length(vec)))
  pwm <- sapply(seq(along=pos[,1]), function(x) vec[pos[x,1]:pos[x,2]])
  pwm <- sapply(seq(along=pwm), function(x) strsplit(pwm[[x]], " {1,}"))
  pwm <- lapply(seq(along=start), function(x) matrix(as.numeric(t(as.data.frame(pwm[(pos[x,1]+1):pos[x,2]]))[,-1]), nrow=4, dimnames=list(c("A", "C", "G", "T"), NULL)))
  names(pwm) <- gsub(">", "", vec[start])
  return(pwm)
}
pwmtable <- importJaspar(jaspardir)

pwmnum = id
pwmin = pwmtable[[pwmnum]]
pwmname = names(pwmtable)[pwmnum]

####
# end input script
# assert: existence of pwmin and pwmname
####

####
# motif match

pwmnorm=t(t(pwmin)/colSums(pwmin))
#informbase=colSums((log(pwmnorm+0.01)-log(1/4))*pwmnorm) #
#pwmnorm = pwmnorm[,(informbase > basecut)]
ipr=log(pwmnorm)-log(1/4)
pwmgen=(t(t(pwmin)/colSums(pwmin)))^(0.7)

#generate nkmer motif match candidates
str=apply(pwmgen,2,function(j){
    sample(1:4,nkmer,prob=j,replace=T)
})

scores=rowSums(sapply(1:ncol(str),function(i){
    ipr[str[,i],i]
}))

#filter by motif match cutoff
passcut= which(scores > motifcut)
print(length(passcut))

basenames=rownames(pwmin)
strs=sapply(passcut,function(i){
    paste0(basenames[str[i,]],collapse='')
})
ustrs=unique(strs)
uscores=as.double(scores[passcut][match(ustrs,strs)])
if(match.rc){
  ustrs=as.character(reverseComplement(DNAStringSet(ustrs)))
}

if(length(ustrs)>0){

#calculate chr offsets
chrstr = seqnames(genome)

#find motif matches
pd=PDict(ustrs)
coords.list=lapply(chrstr,function(i){
    print(i)
    mpd=matchPDict(pd,genome[[i]])
})

coords.pwm=sapply(coords.list,function(i){
    ci=countIndex(i)
    cid=which(ci>0)
    do.call(c,lapply(cid,function(j){
        rep(uscores[j],ci[j])
    }))
})

allpwm=do.call(c,coords.pwm)
pwmcut2=sort(allpwm,decreasing=T)[min(length(allpwm),maxcand)]
rm(allpwm)
print(pwmcut2)

coords=lapply(1:length(coords.list),function(i){
    unlist(coords.list[[i]])[coords.pwm[[i]] > pwmcut2]
})

coords.pwm=lapply(coords.pwm,function(i){i[i>pwmcut2]})

#coords=lapply(coords.list,unlist)

clengths=sapply(coords,length)
coords.short=coords[clengths>0]
names(coords.short)=chrstr[clengths>0]
ncoords=chrstr[clengths>0]#names(coords)
coords2=sapply(coords.short,flank,width=wsize,both=T)

save(coords,coords.pwm,ipr,pwmin,pwmname,ustrs,chrstr,clengths,coords.short,ncoords,coords2,file=paste0(outdir,id,'.pwmout.RData'))

}else{
clengths=0
save(clengths,file=paste0(outdir,id,'.pwmout.RData'))
}

#
#####


# Functions for the core statistical analysis

# ====================================================================
# Exported Functions

# --------------------------------------------------------------------
#' Detect differentially methylated regions (DMRs) from windowed read counts from MBD-isolated genome sequencing (MiGS/MBD-seq) and similar techniques
#'
#' After the counts have been pre-processed, this function performs all the analysis. Detailed results from intermediate steps are stored in the output list object to analyze method performance and provide input for the summary, export, and plotting functions.
#' @param samp Sample data.frame from readSampleInfo()
#' @param counts Preprocessed count data from getCounts()
#' @param reads Preprocessed reads/fragments data from getReads()
#' @param poifdr False discovery rate to use during initial filtering and frequency calling. Changing this value will change the threshold used for calling the presence of methylation.
#' @param stageone.p P-value cutoff for the pairwise testing in stage one.
#' @param anodev.p P-value cutoff for the analysis of deviance (ANODEV) in stage two testing.
#' @param post.p P-value cutoff for post-tests in stage two testing.
#' @param freq Fraction of samples within groups that must agree with respect to methylation status in order for "frequent" to be "TRUE" in the output DMR list.
#' @param minsize Minimum size of DMRs to report (in bp)
#' @param joindist Extend significant windows into DMRs over non-significant stage one windows between them up to this distance large (in bp)
#' @param adjust.var Name of a column present in "samp" that will be used as a covariate adjustment in the stage two ANODEV generalized linear model (GLM)
#' @param nperms Optional, perform this number of permutations after calling DMRs. Will create a data.table called "FDR" in the output list. See also maPerm(), maPermMerge(), and maPermFdr() for manual permutation running and FDR calculation.
#' @param perm.boot If nperms > 0 and if TRUE, perform bootstrapping (sampling with replacement). Otherwise, perform permutations (sampling without permutations)
#' @param ncore Number of parallel processes to use
#' @return A list containing detailed results from each stage of the analysis.
#' @export
methylaction <- function(samp, counts, reads, poifdr=0.1, stageone.p=0.05, anodev.p=0.05, post.p=0.05, freq=2/3, minsize=150, joindist=200, adjust.var=NULL, nperms=0, perm.boot=F, ncore=1)
{
	cov <- NULL
	stagetwo.method <- "co"
	winsize <- width(counts)[1]

	ngroups <- length(unique(samp$group))
	message("Starting analysis for a ",ngroups," group comparision")
	samp <- data.table(samp)
	if(sum(samp[,length(sample),by=group]$V1 > 1)!=ngroups){stop("Each group must contain more than one replicate")}
	groups <- unique(samp$group)
	if(!is.null(adjust.var)){if(!(adjust.var %in% colnames(samp))){stop("No column with name equal to adjust.var found in samp")}}

	args <- list(samp=samp, stagetwo.method=stagetwo.method, winsize=winsize, poifdr=poifdr, stageone.p=stageone.p, freq=freq, joindist=joindist, anodev.p=anodev.p, adjust.var=adjust.var, post.p=post.p, minsize=minsize, nperms=nperms, perm.boot=perm.boot, ncore=ncore, start=Sys.time())

	# Do Initial Filtering
	fdr.filter <- methylaction:::filter(counts, samp, poifdr)

	# Get Signal Bins Only
	message("Filtering to Signal Windows")
	filter.pass <- rowSums(t(t(as.matrix(values(counts)))>fdr.filter$cuts))>0

	# Compute Size Factors based on Filtered Regions - will always use these for all subsequent tests
	message("Computing size factors")
	sizefactors <- estimateSizeFactorsForMatrix(as.matrix(values(counts[filter.pass])))

	# Make list dividing up the data
	# Normalize counts first
	message("Saving Normalized Counts")
	cds <- newCountDataSet(as.matrix(values(counts[filter.pass])),samp$group)
	sizeFactors(cds) <- sizefactors
	normcounts <- counts(cds,normalized=TRUE)

	zero <- rowSums(as.matrix(values(counts)))==0
	wingr <- GRanges(seqnames(counts),IRanges(start(counts),end(counts)))
	windows <- list()
	windows$zero <- wingr[zero]
	windows$filtered <- wingr[!filter.pass & !zero]
	windows$signal <- counts[filter.pass]
	windows$signal.norm <- wingr[filter.pass]
	values(windows$signal.norm) <- normcounts

	rm(filter.pass, cds, normcounts, zero, wingr, counts)
	gc()

	# Testing Stage 1
	test.one <- methylaction:::testOne(samp=samp,bins=windows$signal,signal.norm=windows$signal.norm,chrs=unique(as.vector(seqnames(windows$signal))),sizefactors=sizefactors,stageone.p=stageone.p,joindist=joindist,minsize=minsize,ncore=ncore)

	# Testing Stage 2 + Methylation Modeling
	test.two <- methylaction:::testTwo(samp=samp, cov=cov, reads=reads, stagetwo.method=stagetwo.method, regions=test.one$regions, sizefactors=sizefactors, fragsize=fragsize, winsize=winsize, anodev.p=anodev.p, freq=freq, adjust.var=adjust.var, post.p=post.p, fdr.filter=fdr.filter, ncore=ncore)

	fdr <- NULL
	maperm <- NULL

	ma <- list(dmr=test.two$dmrcalled, fdr=fdr, args=args, data=list(windows=windows, fdr.filter=fdr.filter, sizefactors=sizefactors, test.one=test.one, test.two=test.two, maperm=maperm))

	# Remove some things from the output to reduce the size
	ma$data$test.two$dmrcalled <- NULL
	values(ma$data$windows$filtered) <- NULL
	#ma$data$windows$signal <- NULL

	if(nperms>0)
	{
		# call to maPerm to do the actual permutations
		ma$data$maperm <- methylaction:::maPerm(ma=ma,reads=reads,nperms=nperms,perm.boot=perm.boot,save=FALSE,ncore=ncore)
		ma$fdr <- methylaction:::maPermFdr(ma=ma,maperm=ma$data$maperm,recut.p=0.05)
	}

	# Output results
	#ma <- list(fdr.filter=fdr.filter, sizefactors=sizefactors, windows=windows, test.one=test.one, test.two=test.two)
	ma$args$end <- Sys.time()
	ma$args$hours <- as.numeric(difftime(ma$args$end,ma$args$start,units="hours"))

	message("Output list size in memory=",methylaction:::sizein(ma))
	return(ma)
}
# --------------------------------------------------------------------
# ====================================================================

# ====================================================================
# Internal Functions

# --------------------------------------------------------------------
# Initial Filtering
filter <- function(counts, samp, poifdr)
{
	# Initial Filtering
	message("Computing window count frequencies")
	countints <- 0:10
	histo <- do.call(rbind,lapply(countints, FUN=function(x) {message(x);colSums(as.matrix(values(counts))==x);}))
	histo <- rbind(histo,colSums(as.matrix(values(counts))>max(countints)))
	rownames(histo) <- c(countints,paste0(">",max(countints)))
	counts.tab <- lapply(1:ncol(histo),function(x) data.frame(count=countints[-1],freq=histo[2:length(countints)-1,x]))
	names(counts.tab) <- colnames(histo)

	# This filtering equation based on code by Yaomin Xu
	dpt.poi <- function(histo, counts.tab,cutoff=poifdr)
	{
		est.pois.lambda <- function(tab)
		{
			f1 <- with(tab, freq[count==1])
			f2 <- with(tab, freq[count==2])
			2*f2/f1
		}
		est.fdr <- function(n,tb)
		{
			lambda <- est.pois.lambda(tb)
			n.total <- with(tb, freq[count==1])/dpois(1, lambda)
			n.total*dpois(n,lambda)/with(tb, freq[count == n])
		}
		fdr <- sapply(counts.tab, function(x) sapply(counts.tab[[1]]$count, est.fdr, tb=x))
		ifsatisfy <- fdr < cutoff
		cuts <- apply(ifsatisfy, MARGIN=2, FUN=function(x) max(seq(1,length(x))[!x]))
		list(histo=histo,fdr=round(fdr,5),cuts=cuts)
	}
	fdr.filter <- dpt.poi(histo, counts.tab, cutoff=poifdr)
	return(fdr.filter)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# Stage one testing
testOne <- function(samp,bins,signal.norm,chrs,sizefactors,stageone.p=0.05,minsize=150,joindist=200,ncore=3)
{
	message("Begin stage one testing")

	# Perform pairwise tests
	bins.mat <- as.matrix(values(bins))

	# Compute all the pairwise comps
	comps <- methylaction:::getGroupComps(unique(samp$group))
	dotest <- function(x)
	{
		a <- x[1]
		b <- x[2]
		message("Testing ",a," vs ",b)
		out <- methylaction:::testDESeq(bins.mat,samp$group,a=a,b=b,prefix=paste0("deseq-",a," vs ",b),sizefactors=sizefactors,ncore=ncore)
		return(out)
	}
	testres <- apply(comps$combos,1,dotest)
	names(testres) <- comps$strings

	if(!all(sapply(testres,nrow)==length(bins))){stop("Ran out of memory during testing, try reducing ncore")}

	message("Calling Patterns")
	patt <- methylaction:::callPatternsN(res=testres,cutoff=stageone.p,samp=samp)

	# Make means columns
	colgroups <- lapply(unique(samp$group),function(x) samp[group==x,]$sample)
	names(colgroups) <- unique(samp$group)
	counts.means <- do.call(cbind, lapply(colgroups, function(i) rowMeans(as.matrix(values(signal.norm[,i])))))
	colnames(counts.means) <- paste0(levels(samp$group),".mean")

	# Combine so we get these in the output
	patt <- data.table(counts.means,patt)

	# join adjacent equivalent patterns
	message("Reduction by pattern and disjoing regions")
	bins.gr <- bins
	values(bins.gr) <- NULL
	bins.gr$pattTestOne <- patt$patt

	# split out by pattern
	allone <- paste(as.character(rep(1,length(unique(samp$group)))),collapse="")
	sigpatt <- bins.gr[!(bins.gr$pattTestOne %in% c("ambig","000or111",allone))]
	pattrows <- sigpatt$pattTestOne
	values(sigpatt) <- NULL
	bins.bypatt <- split(sigpatt,pattrows)

	# reduce each pattern with itself within the gap distance
	bins.red <- lapply(bins.bypatt,reduce,min.gapwidth=joindist)
	for(i in 1:length(bins.red)){bins.red[[i]]$pattTestOne <- names(bins.red)[i]}

	# only keep reduced ranges if minsize or larger
	bins.red <- lapply(bins.red,function(x) x[width(x)>=minsize])

	# deal with conflicting extensions using disjoin()
	bins.red.gr <- do.call(c,unname(bins.red))
	regions.gr <- disjoin(bins.red.gr)
	regions <- regions.gr[width(regions.gr)>=minsize]

	# output: genomic ranges to pass to stage 2

	patterns <- bins
	values(patterns) <- patt

	test.one <- list(patterns=patterns, regions=regions)

	return(test.one)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# stage two testing
testTwo <- function(samp,cov,reads,stagetwo.method="co",regions,sizefactors,fragsize,winsize,anodev.p,adjust.var,post.p, fdr.filter, freq,ncore)
{
	message("Begin stage two testing")

	message("Recounting in regions with method=",stagetwo.method)

	if(stagetwo.method=="co")
	{
		recounts <- as.matrix(values(getCounts(samp=samp,reads=reads,ranges=regions,ncore=ncore)))
	} else
	{
		stop("Bad stagetwo.method type")
	}

	# Do an ANOVA-like framework
	# First test for ANY difference with an ANOVA-style DESeq test (ANODEV since these are GLM based negative binomial tests)
	# Adjust this for multiple testing
	# Move on the significant windows to post testing, adjust within each test only then
	# Call pattern based on these values
	testDESeqANODEV<- function(recounts,groups,covar, ncore)
	{
		# chunk up data to allow parallel testing for large data sets
		chunkids <- (seq(nrow(recounts))-1) %/% 500

		dotest <- function(rows)
		{
			singleton <- FALSE
			if(nrow(recounts[rows,,drop=F])==1)
			{
				# Workaround for estimateDispersions - will not work and can not test if only one feature, so duplicate the feature we have as an estimation in the singleton case
				singleton <- TRUE
				thecounts <- rbind(recounts[rows,,drop=F],recounts[rows,,drop=F])
				cds <- newCountDataSet(thecounts,groups)
			} else
			{
				# make master object container
				cds <- newCountDataSet(recounts[rows,,drop=F],groups)
			}

			# make master object container
			#cds <- newCountDataSet(recounts[rows,,drop=F],groups)

			# estimate the size factors for the library
			# do we want to use size factors from previously for the whole library?
			sizeFactors(cds) <- sizefactors

			# pull back DEseq normalized counts - use for visualization
			# probably want to make the WIG files out of these
			#head( counts( cds, normalized=TRUE ) )

			# estimate the dispersions for each gene
			message("Estimating dispersions")
			cds <- suppressWarnings(estimateDispersions(cds,fitType="local",sharingMode="gene-est-only"))

			# perform the testing
			# compare model w/ factor versus null model
			if(!is.null(covar))
			{
				message("Fitting full GLM w/ adjustments")
				resFull <- fitNbinomGLMs( cds, modelFormula=count~groups+covar)
				message("Fitting reduced GLM w/ adjustments")
				resReduced <- fitNbinomGLMs( cds, modelFormula=count~covar)
				message("Performing test")
				res <- nbinomGLMTest(resFull, resReduced)
				if(singleton==TRUE)
				{
					res <- res[1]
				}
				return(res)

			} else {
				message("Fitting full GLM")
				resFull <- fitNbinomGLMs( cds, modelFormula=count~groups)
				message("Fitting reduced GLM")
				resReduced <- fitNbinomGLMs( cds, modelFormula=count~1)
				message("Performing test")
				res <- nbinomGLMTest(resFull, resReduced)
				if(singleton==TRUE)
				{
					res <- res[1]
				}
				return(res)
			}
		}
		finalres <- mclapply(0:max(chunkids),function(x) {message("Testing chunk ",x," of ",max(chunkids));dotest(chunkids==x);},mc.cores=ncore)
		finalres <- do.call(c,finalres)
		return(finalres)
	}

	if(is.null(adjust.var))
	{
		covar <- NULL
	} else {
			message("Adding adjustment for variable \"", adjust.var,"\" into the GLM")
			covar <- factor(as.data.frame(samp)[,adjust.var,drop=T])
	}

	anodev <- testDESeqANODEV(recounts=recounts,groups=samp$group,covar=covar,ncore=ncore)
	anodev.padj <- p.adjust(anodev,method="fdr")
	#table(anodev<0.1)
	# Filter out if it does not pass the ANODEV

	#df <- data.frame(noadj=p.adjust(anodev1,method="fdr")<0.001,adj=p.adjust(anodev,method="fdr")<0.001)
	#table(rowSums(df))

	regions$anodev.p <- anodev
	regions$anodev.padj <- anodev.padj

	# Get norm counts
	cds <- newCountDataSet(recounts,samp$group)
	sizeFactors(cds) <- sizefactors
	#values(regions) <- cbind(as.data.frame(values(regions)),counts(cds,normalized=TRUE))
	normcounts <- counts(cds,normalized=TRUE)

	anodev.keep <- (anodev.padj<anodev.p) & !(is.na(anodev.padj))

	if(sum(anodev.keep)==0){message("Found no DMRs in stage two ANODEV")}
	if(sum(anodev.keep)==0){out<-"NoDmrs"; return(out);}

	test.two <- list()
	test.two$ns <- regions[!anodev.keep]
	test.two$ns.counts <- regions[!anodev.keep]
	values(test.two$ns.counts) <- normcounts[!anodev.keep,]

	regions.sig <- regions[anodev.keep]
	recounts.sig <- recounts[anodev.keep,,drop=F]

	# a vs b
	comps <- methylaction:::getGroupComps(unique(samp$group))
	dotest <- function(x)
	{
		a <- x[1]
		b <- x[2]
		message("Testing ",a," vs ",b)
		#s <- strsplit(x,"")[[1]]
		out <- methylaction:::testDESeq(counts=recounts.sig,groups=samp$group,a=a,b=b,prefix=paste0("deseq-",a," vs ",b),sizefactors=sizefactors,ncore=ncore)
		return(out)
	}
	testres <- apply(comps$combos,1,dotest)
	names(testres) <- comps$strings

	if(!all(sapply(testres,nrow)==nrow(recounts.sig))){stop("Ran out of memory during testing, try reducing ncore")}

	patt <- methylaction:::callPatternsN(res=testres, cutoff=post.p, samp=samp)

	test.two$sig <- regions[anodev.keep]
	values(test.two$sig) <- patt
	test.two$sig.counts <- regions[anodev.keep]
	values(test.two$sig.counts) <- normcounts[anodev.keep,,drop=F]

	#as.data.frame(table(patt$patt))

	dmr <- data.frame(chr=seqnames(regions.sig),start=start(regions.sig),end=end(regions.sig),width=width(regions.sig),anodev.padj=regions.sig$anodev.padj,pattern=patt$patt)

	# Output list of sig DMRs

	# Make frequency columns
	colgroups <- lapply(unique(samp$group),function(x) samp[group==x,]$sample)
	names(colgroups) <- unique(samp$group)

	# Freq Calling via POI
	#cuts <- as.matrix(width(dmr)/50) %*% cuts
	cnt <- recounts.sig/(dmr$width/winsize)

	#meth <- t(t(counts)>cuts)
	# call yes/no for each sample based on poi cuts
	meth <- t(t(cnt)>fdr.filter$cuts)

	# call freqs
	meth.freq <- do.call(cbind, lapply(colgroups, function(i) rowSums(meth[,i,drop=F])))

	# call percentages
	meth.per <- t(t(meth.freq)/as.vector(table(samp$group)))
	colnames(meth.per) <- paste0(colnames(meth.per),".per")

	# Make means columns - for the per window counts
	perwin.means <- do.call(cbind, lapply(colgroups, function(i) rowMeans(cnt[,i,drop=F])))
	colnames(perwin.means) <- paste0(levels(samp$group),".perwin.mean")

	# Add pairwise p-values and fold changes
	pair.p <- do.call(cbind,lapply(testres,function(x) x$pval))
	colnames(pair.p) <- paste0(colnames(pair.p),".p")

	addFc <- function(mydmrs,offset=0.00001)
	{
		dat <- mydmrs
		mygroups <- as.character(unique(samp$group))
		pairs <- t(combn(mygroups,2))

		pairs.fc <- lapply(1:nrow(pairs),function(x) {
			a <- pairs[x,][2]
			b <- pairs[x,][1]

			avec <- dat[,colnames(dat)==paste0(a,".perwin.mean")]+offset
			bvec <- dat[,colnames(dat)==paste0(b,".perwin.mean")]+offset

			fc <- log2(avec/bvec)
			#table(is.infinite(fc))
			#table(is.na(fc))
			return(fc)
		})
		names(pairs.fc) <- paste0(pairs[,2],"_over_",pairs[,1],".log2fc")

		newcols <- do.call(cbind,pairs.fc)

		mydmrs <- cbind(dat,as.data.frame(newcols))
		return(mydmrs)
	}

	dmrfreq <- cbind(dmr,pair.p,cnt,perwin.means,meth.freq,meth.per)
	#dmrfreq$dmrid <- 1:nrow(dmr)

	dmrfreq <- addFc(mydmrs=dmrfreq)

	# Want to know sharpness - should be all 0 groups are no more than 1/3 meth, and all 1 groups are no less than 2/3 meth
	patts <- as.character(unique(dmrfreq$pattern))
	allone <- paste(as.character(rep(1,length(unique(samp$group)))),collapse="")
	patts <- patts[!(patts %in% c("ambig","000or111",allone))]

	sharpnessN <- function(patt,meth=freq,unmeth=(1-freq))
	{
		myfreq <- dmrfreq[dmrfreq$patt==patt,paste0(unique(samp$group),".per")]

		chars <- strsplit(patt,"")[[1]]
		checkit <- chars
		checkit[chars=="0"] <- unmeth
		checkit[chars=="1"] <- meth

		lt <- t(t(myfreq)<=checkit)
		gt <- t(t(myfreq)>=checkit)

		# Call each group as sharp or not, they must all be sharp to call the site as sharp
		sharp <- rowSums(cbind(lt[,chars=="0",drop=F],gt[,chars=="1",drop=F]))==length(unique(samp$group))

		ret <- dmrfreq[dmrfreq$pattern==patt,,drop=F]
		ret$frequent <- sharp
		ret
	}
	sharpness <- function(patt,meth=freq,unmeth=(1-freq))
	{
		myfreq <- dmrfreq[dmrfreq$pattern==patt,c("benign.per","low.per","high.per")]
		chars <- strsplit(patt,"")[[1]]
		checkit <- chars
		checkit[chars=="0"] <- unmeth
		checkit[chars=="1"] <- meth

		lt <- t(t(myfreq)<=checkit)
		gt <- t(t(myfreq)>=checkit)

		# Call each group as sharp or not, they must all be sharp to call the site as sharp
		sharp <- rowSums(cbind(lt[,chars=="0",drop=F],gt[,chars=="1",drop=F]))==3

		ret <- dmrfreq[dmrfreq$pattern==patt,]
		ret$frequent <- sharp
		ret
	}

	res <- lapply(patts,sharpnessN)
	dmrcalled <- do.call(rbind,unname(res))
	dmrcalled$dmrid <- 1:nrow(dmrcalled)

	# Make means columns
	counts.means <- do.call(cbind, lapply(colgroups, function(i) rowMeans(recounts.sig[,i,drop=F])))
	colnames(counts.means) <- paste0(unique(samp$group),".mean")

	# Final output!
	dmr <- cbind(dmr,counts.means)

	test.two$dmr <- makeGRanges(dmr)
	test.two$dmrcalled <- makeGRanges(dmrcalled)

	return(test.two)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# DEseq for 1 pairwise test
testDESeq <- function(counts,groups,a,b,prefix,sizefactors,ncore)
{
	# chunk up data to allow parallel testing for large data sets
	chunkids <- (seq(nrow(counts))-1) %/% 50000

	# need to use the same size factors for everything

	dotest <- function(rows)
	{
		singleton <- FALSE
		if(nrow(counts)==1)
		{
			# Workaround for estimateDispersions - will not work and can not test if only one feature, so duplicate the feature we have as an estimation in the singleton case
			singleton <- TRUE
			counts <- rbind(counts,counts)
			cds <- newCountDataSet(counts,groups)
		} else
		{
			# make master object container
			cds <- newCountDataSet(counts[rows,,drop=F],groups)
		}

		# estimate the size factors for the library
		#cds <- estimateSizeFactors(cds)
		sizeFactors(cds) <- sizefactors

		# estimate the dispersions for each gene
		#message("Estimating dispersions")
		cds <- suppressWarnings(estimateDispersions(cds,fitType="local",sharingMode="gene-est-only"))
		#cds <- suppressWarnings(estimateDispersions(cds,fitType="local",sharingMode="gene-est-only"))
		#cds<-estimateDispersions(cds,method="pooled-CR",sharingMode="gene-est-only",fitType="local")

		# perform the testing
		#message("Performing test")
		res <- nbinomTest(cds,a,b)

		if(singleton==TRUE)
		{
			res <- res[1,,drop=F]
		}

		return(res)
	}
	finalres <- mclapply(0:max(chunkids),function(x) {message("Testing chunk ",x," of ",max(chunkids));dotest(chunkids==x);},mc.cores=ncore)
	finalres <- rbindlist(finalres)
	finalres[,id:=NULL]
	finalres[,padj:=NULL]

	# Remove NA p-value by setting to 0 (when b mean is 0) or 1, whichever is appropriate

	return(finalres)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# Function to generate all pairwise comparisions for a set of groups
# Where groups is a vector of group IDs (unique)
getGroupComps <- function(groups)
{
	ngroups <- length(groups)
	combos <- t(combn(1:ngroups,m=2))
	combos <- t(apply(combos,1,function(x) groups[x]))
	combostrings <- apply(combos,1,function(x) paste0(x[1],"_vs_",x[2]))
	return(list(combos=combos,strings=combostrings))
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# Function to generate all possible pattern codes given nGroups
getGroupPatterns <- function(ngroups)
{
	ones <- 0:ngroups

	# Function to return all combinations for a given number of "1" digits in the pattern
	# We will apply over all possible numbers of "1" digits to get all the pattern codes
	digits <- function(x)
	{
		if(x==0)
		{
			return(rep(0,ngroups))
		} else if (x==ngroups)
		{
			return(rep(1,ngroups))
		} else
		{
			pool <- c(rep(0,ngroups-x),rep(1,x))
			perms <- gtools::permutations(n=ngroups,r=ngroups,v=pool,set=FALSE)
			perms <- unique(perms)
			return(perms)
		}
	}
	codes <- lapply(ones,digits)
	codes <- do.call(rbind,codes)
	return(codes)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# Decision table
getDecisionTable <- function(mygroups,human=FALSE)
{
	codes <- getGroupPatterns(length(mygroups))

	getRule <- function(x)
	{
		#message(x)
		#x <- codes[2,]
		combos <- t(combn(1:length(mygroups),m=2))
		namecombos <- t(apply(combos,1,function(y) mygroups[y]))
		combos <- t(apply(combos,1,function(y) x[y]))
		namecombos <- apply(namecombos,1,function(x) paste0(x[1],"_vs_",x[2]))

		test <- function(z)
		{
			if((z[1]==0)&(z[2]==0))
			{
				if(human==TRUE)
				{
					return("NS")
				} else
				{
					return(0)
				}
			} else if((z[1]==1)&(z[2]==0))
			{
				if(human==TRUE)
				{
					return("SIG decrease")
				} else
				{
					return(-1)
				}
			} else if((z[1]==0)&(z[2]==1))
			{
				if(human==TRUE)
				{
					return("SIG increase")
				} else
				{
					return(1)
				}
			} else if((z[1]==1)&(z[2]==1))
			{
				if(human==TRUE)
				{
					return("NS")
				} else
				{
					return(0)
				}
			}
		}
		rule <- apply(combos,1,test)
		names(rule) <- namecombos
		rule <- matrix(rule,nrow=1)
		colnames(rule) <- namecombos
		rule <- data.frame(pattern=paste(x,collapse=""),rule)
		return(rule)
	}
	codes.split <- split(codes,row(codes))
	ja <- lapply(codes.split,getRule)
	ja <- do.call(rbind,ja)
	return(ja)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
# call patterns genome wide, generalized to n-groups
callPatternsN <- function(res,cutoff=0.05,samp)
{
	# add directions to testres
	getDirection <- function(x)
	{
		x$direction <- 0
		x[baseMeanA<baseMeanB,]$direction <- 1
		x[x$baseMeanA>x$baseMeanB,]$direction <- -1
		return(x)
	}
	res <- lapply(res,getDirection)

	# combine columns accross comparisons
	getCols <- function(x)
	{
		out <- data.table(p=x$pval,l2fc=x$log2FoldChange,sig=x$pval<cutoff,dir=x$direction)
		out[is.na(p),sig:=FALSE]
		return(out)
	}
	tests <- lapply(res,getCols)

	# filter using decision codes:
	# -1 = sig down
	# 0 = NS
	# 1 = sig up

	getCodes <- function(x)
	{
		x[,code:=dir]
		x[sig==FALSE,code:=0]
		return(x)
	}
	tests <- lapply(tests,getCodes)

	# Call pattern codes based on the decision codes
	dc <- methylaction:::getDecisionTable(unique(samp$group))

	str <- lapply(tests,function(x) x$code)
	str <- do.call(cbind,str)

	tests <- lapply(names(tests),function(x) setnames(tests[[x]],paste0(x,"_",colnames(tests[[x]]))))
	mypatt <- do.call(cbind,tests)
	mypatt[,patt:="ambig"]

	for(i in 1:nrow(dc))
	{
		message("Deciding pattern: ",dc[i,]$pattern)
		x <- as.vector(t(dc[i,-1]))
		dec <- t(t(str)==x)
		yespatt <- rowSums(dec)==ncol(dec)
		mypatt[yespatt,patt:=dc[i,]$pattern]
	}

	mypatt[patt=="000",]$patt <- "000or111"
	mypatt$patt <- as.character(mypatt$patt)
	mypatt
}
# --------------------------------------------------------------------

# ====================================================================