---
title: "Mitch Report"
author: "Antony Kaspi & Mark Ziemann"
output:
  html_document:
    smart: false
theme: cosmo
---

date generated: `r Sys.Date()`

## Background

Mitch performs unidimensional and multidimensional gene set enrichment analysis. The
concept behind this dates to work by Cox and Mann
(https://doi.org/10.1186/1471-2105-13-S16-S12). This implementation is suited to R based
workflows of multi-omics datasets. This software was developed by Antony Kaspi and Mark
Ziemann. Learn more about Mitch at the website: https://github.com/markziemann/Mitch

## Input profiles

Here is the first few lines of the input profile.

```{r,checklibraries,echo=FALSE}

suppressPackageStartupMessages({
    library("mitch")
    library("gtools")
})

```


```{r,peek,echo=FALSE}

res <- readRDS(DATANAME)

# capture the dimensionality of the data                                               
d=ncol(res$input_profile)

# if working with >5 dimensions, then substitute the dimension (colnames) names with a number
if ( d>5 ) {
    mydims<-data.frame(seq_len(d))
    mydims$colnames<-attributes(res)$profile_dimensions
    colnames(mydims)<-c("dimension","contrast_name")
    print(kbl( mydims, caption = "Profile dimensions" ) %>%
    kable_styling("hover", full_width = FALSE))
    colnames(res$input_profile)<- paste("d",seq_len(d),sep="")
    colnames(res$ranked_profile)<- paste("d",seq_len(d),sep="")
    ss<-res$ranked_profile
}

head(res$input_profile) %>%
  kbl(caption="The profiling data being passed to mitch") %>%
  kable_styling("hover", full_width = FALSE)

```

Here are some metrics about the input data profile:

```{r, metrics, echo=FALSE}

if (d==1) {
    formatted<-t(as.data.frame(res$analysis_metrics[ c(1,2,3,4,5 ) ]))
} else if (d==2) {
    unformatted<-t(as.data.frame(res$analysis_metrics[ c(2,3,4,5,11,12 )  ]))
    formatted<-unformatted
    formatted[1:4]<-as.character(round(as.numeric(unformatted[1:4]) , digits=0))
    formatted[5:6]<-as.character(round(as.numeric(unformatted[5:6]) , digits=5))
} else if (d>2) {
    formatted<-t(as.data.frame(res$analysis_metrics[ c(2,3,4,5 )  ]))
}

colnames(formatted)="Profile metrics"

formatted %>%
  kbl(caption="Profiling data metrics") %>%
  kable_styling("hover", full_width = FALSE)

```

Here is a plot of the input profiles. Note the dynamic ranges.

```{r, scatterplot, echo=FALSE,fig.height = 6, fig.width = 6.5, message=FALSE, warning=FALSE}

if ( d==1 ) {
    par(mfrow=c(2,1))
    hist(res$input_profile[,1],breaks=50,main="Distribution of DE scores",xlab=paste("DE score for ",colnames(res$input_profile)))
    plot(res$input_profile[,1],xlab=paste("DE score for ",colnames(res$input_profile)),
    pch="|",frame.plot=FALSE)
    UPS=length(which(res$input_profile[,1]>0))
    DNS=length(which(res$input_profile[,1]<0))
    TOTAL=nrow(res$input_profile)
    mtext(paste(TOTAL,"genes in total,",UPS,"trending up-regulated,",DNS,"trending down-regulated"))
} else if ( d<3 ) {
    plot(res$input_profile, pch=19, col=rgb(red = 0, green = 0, blue = 0, alpha = 0.15), main="Input profiles"  )
} else {
    ggpairs_points_plot <- function(data ,mapping, ...){
        p <- ggplot(data = data, mapping = mapping) +
        geom_point(alpha=0.05) +
        geom_vline(xintercept=0,linetype="dashed") +
        geom_hline(yintercept=0,linetype="dashed")
    }
    p<-ggpairs(as.data.frame(res$input_profile), title="Scatterplot of all genes" , lower  = list(continuous = ggpairs_points_plot ))
    print( p +  theme_bw() )
}

```

Here is the contour plot of the profile including all detected genes.

```{r, contourplot, echo=FALSE,fig.height = 6, fig.width = 6.5,warning=FALSE, message=FALSE}

palette <- colorRampPalette(c("white", "yellow","orange" ,"red","darkred","black"))

#Contour of all the data
ss<-res$ranked_profile

if (d==1) {
    message("Contour plot does not apply to unidimensional analysis.")
} else if (d==2) {
    xmin=min(ss[,1])
    xmax=max(ss[,1])
    ymin=min(ss[,2])
    ymax=max(ss[,2])
    ss<-res$ranked_profile
    k<-MASS:::kde2d(ss[,1],ss[,2])
    X_AXIS=paste("Rank in contrast",colnames(ss)[1])
    Y_AXIS=paste("Rank in contrast",colnames(ss)[2])
    filled.contour(k, xlim=c(xmin,xmax),ylim=c(ymin,ymax),
    color=palette ,
    plot.title={ abline(v=0,h=0,lty=2,lwd=2,col="blue")
    title( main="Rank-rank plot of all genes",xlab=X_AXIS,ylab=Y_AXIS ) } )
} else if (d>2) {
    #pairs contour plot function
    ggpairs_func <- function(data, mapping, ...){
        p <- ggplot(data = data, mapping = mapping) +
        stat_density2d(aes(fill=..density..), geom="tile", contour = FALSE) +
        geom_vline(xintercept=0,linetype="dashed") +
        geom_hline(yintercept=0,linetype="dashed") +
        scale_fill_gradientn(colours=palette(25))

        p

    }

    #pairs contour plot
    p<-ggpairs(as.data.frame(ss), title="Contour plot of all genes after ranking" ,
    lower=list(continuous=ggpairs_func),
    diag=list(continuous=wrap("barDiag", binwidth=nrow(ss)/100)))

    print( p + theme_bw() )

    #subset contour plot
    ggpairs_contour_limit_range <- function(data ,mapping, ...){

        p <- ggplot(data = data, mapping = mapping) +
        stat_density2d(aes(fill=..density..), geom="tile", contour = FALSE) +
        geom_vline(xintercept=0,linetype="dashed") +
        geom_hline(yintercept=0,linetype="dashed") +
        scale_fill_gradientn(colours=palette(25)) +
        scale_x_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[1]))]),max(ss[,gsub("~","",as.character(mapping[1]))])) ) +
        scale_y_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[2]))]),max(ss[,gsub("~","",as.character(mapping[2]))])) )

        p

    }

    #subset points plot
    ggpairs_points_limit_range <- function(data ,mapping, ...){

        p <- ggplot(data = data, mapping = mapping) +
        geom_point(alpha=0.1) +
        geom_vline(xintercept=0,linetype="dashed") +
        geom_hline(yintercept=0,linetype="dashed") +
        scale_x_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[1]))]),max(ss[,gsub("~","",as.character(mapping[1]))])) ) +
        scale_y_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[2]))]),max(ss[,gsub("~","",as.character(mapping[2]))])) )

        p

    }

}

```

## Input genesets

Here are some metrics about the gene sets used:

```{r,input_geneset_metrics1,results="asis",echo=FALSE}

ORIGINFILE=attributes(res$input_genesets)$originfile
cat(paste("GMT file of genesets:",ORIGINFILE,"<br>"))
unformatted<-t(as.data.frame(res$analysis_metrics[c(1,6,7)]))
formatted<-as.data.frame(as.character( unformatted[1:3]) )
rownames(formatted)=rownames(unformatted)
colnames(formatted)="Gene sets metrics"

formatted %>%
  kbl(caption="Gene set metrics") %>%
  kable_styling("hover", full_width = F)

```

```{r,input_geneset_metrics2,results="asis",echo=FALSE ,fig.height = 7, fig.width = 7 ,fig.show="all"}

par(mfrow=c(3,1))
geneset_counts<-res$analysis_metrics$geneset_counts
boxplot(geneset_counts$count,horizontal=TRUE,frame=FALSE,main="Gene set size",xlab="number of member genes included in profile")
hist(geneset_counts$count,100,xlab="geneset size",main="Histogram of geneset size")
hist(geneset_counts$count,100,xlim=c(0,500),xlab="geneset size",main="Trimmed histogram of geneset size")

if ( d==2 ) {
    uu=length(which(res$input_profile[,1]>0 & res$input_profile[,2]>0))
    ud=length(which(res$input_profile[,1]>0 & res$input_profile[,2]<0))
    dd=length(which(res$input_profile[,1]<0 & res$input_profile[,2]<0))
    du=length(which(res$input_profile[,1]<0 & res$input_profile[,2]>0))
    a<-as.data.frame(c(uu,ud,dd,du))
    rownames(a)=c("top-right","bottom-right","bottom-left","top-left")
    colnames(a)="a"
    par(mfrow=c(1,1))
    xx<-barplot(a$a,names.arg=rownames(a),main="number of genes in each quadrant")
    text(x = xx, y = a$a, label = a$a , pos = 1, cex = 1)
} else if (d>2) {
    if (d<6) {
        sig<-sign(ss)
        sector_count<-aggregate(seq_len(nrow(sig)) ~ ., sig, FUN = length)
        colnames(sector_count)[ncol(sector_count)]<-"Count"

         sector_count %>%
         kbl(caption="Genes by sector") %>%
         kable_styling("hover", full_width = FALSE)
    }

}

```

```{r,input_geneset_metrics3,results="asis",echo=FALSE,message=FALSE,fig.height = 7, fig.width = 7}

if (d<2) {
    nsig=length(which(res$enrichment_result$p.adjustANOVA<0.05))
} else {
    nsig=length(which(res$enrichment_result$p.adjustMANOVA<0.05))
}

if (d==1) {
    cat("<h2>Differential pathway expression</h2><br>")
    par(mfrow=c(1,1))
    sig<-subset(res$enrichment_result,p.adjustANOVA<=0.05)

    plot(res$enrichment_result$s.dist,-log10(res$enrichment_result$pANOVA),
      xlab="s score",ylab="-log10(p-value)",
      main="volcano plot of gene set enrichments",pch=19,cex=0.8)

    points(sig$s.dist,-log10(sig$pANOVA),pch=19,cex=0.85,col="red")
    TOTAL=nrow(res$enrichment_result)
    SIG=nrow(sig)
    UP=length(which(sig$s.dist>0))
    DN=length(which(sig$s.dist<0))
    SUBHEADER=paste(TOTAL,"gene sets in total,",UP,"upregulated and ",DN,"downregulated (FDR<=0.05)")
    mtext(SUBHEADER)
}

if (d==2) {
    cat("<h2>Gene sets by quadrant</h2><br>")
    cat(paste("Number of significant gene sets (FDR<0.05)=", res$analysis_metrics$num_sets_significant,"<br>" ))
    a<-res$analysis_metrics[14]
    a<-as.data.frame(as.numeric(unlist(strsplit(as.character(a),','))),stringsAsFactors=FALSE)
    rownames(a)=c("top-right","bottom-right","bottom-left","top-left")
    colnames(a)="a"
    xx<-barplot(a$a,names.arg=rownames(a),main="number of genesets FDR<0.05")
    text(x = xx, y = a$a, label = a$a , pos = 1, cex = 1)
}

if ( nsig > 0 ) {
    if ( d>2 ) {
        if ( d<6 ) {
            cat(paste("Number of significant gene sets (FDR<0.05)=", res$analysis_metrics$num_sets_significant,"<br>" ))
            cat("<h2>Gene sets by sector</h2><br>")
            sig<-sign(res$enrichment_result[which(res$enrichment_result$p.adjustMANOVA<0.05),4:(4+d-1)])
            sector_count<-aggregate(seq_len(nrow(sig)) ~ ., sig, FUN = length)
            colnames(sector_count)[ncol(sector_count)]<-"Count"

            sector_count %>%
            kbl(caption="Gene sets by sector") %>%
            kable_styling("hover", full_width = FALSE)
        }
    }
}

```

## Interactive enrichment scatterplot

```{r,echart1d,results="asis",echo=FALSE, fig.height = 7, fig.width = 7 ,fig.show="all", message=FALSE}

if (d==1) {
    numsets=nrow(subset(res$enrichment_result,p.adjustANOVA<0.05))
    p=NULL
    if (numsets==0){
        message("No significant enrichments found.")
    } else {
        # volcano with echarts4r
        cat("Significance is calculated by -log10(p-value). All points shown are FDR<0.05.<br>")
        myres2<-subset(res$enrichment_result,p.adjustANOVA<0.05)
        myres2$significance<--log10(myres2$pANOVA)
        myres2$set<-sub(",","",myres2$set)
        XCOL=colnames(myres2)[4]
        YCOL=colnames(myres2)[6]
        colnames(myres2)[4]<-"xx"
        colnames(myres2)[6]<-"yy"

        p2<-myres2 %>%
            tibble::rownames_to_column("model") %>%
            dplyr::mutate(set = paste(set, setSize, p.adjustANOVA , sep = ",")) %>%
            e_charts(x = xx) %>%
            e_legend(show = FALSE) %>%
            e_x_axis(name = XCOL) %>%  # add x axis name
            e_y_axis(name = YCOL) %>%  # add y axis name
            e_scatter( serie = yy , bind = set , symbolSize = 10  ) %>%
            e_tooltip(formatter = htmlwidgets::JS("
                function(params){
                var vals = params.name.split(',')
                return('<strong>' + vals[0] +
                '</strong><br />s.x-axis: ' + parseFloat(params.value[0]).toFixed(2) +
                '<br />s.y-axis: ' +  parseFloat(params.value[1]).toFixed(2)) +
                '<br />setSize: ' + vals[1] +
                '<br />p-adjust ANOVA: ' + Number(vals[2]).toPrecision(2)
            }"))
    p2
    }
}

if (d==1) {
    resrows=length(res$detailed_sets)
    if (resrows>1) {
        myres2<-head(res$enrichment_result,resrows)
        myres2$significance<--log10(myres2$pANOVA)
        myres2$set<-sub(",","",myres2$set)
        XCOL=colnames(myres2)[4]
        YCOL=colnames(myres2)[6]
        colnames(myres2)[4]<-"xx"
        colnames(myres2)[6]<-"yy"

        p2<-myres2 %>%
            tibble::rownames_to_column("model") %>%
            mutate(set = paste(set, setSize, p.adjustANOVA , sep = ",")) %>%
            e_charts(x = xx) %>%
            e_legend(show = FALSE) %>%
            e_x_axis(name = XCOL) %>%  # add x axis name
            e_y_axis(name = YCOL) %>%  # add y axis name
            e_scatter( serie = yy , bind = set , symbolSize = 10  ) %>%
            e_tooltip(formatter = htmlwidgets::JS("
                function(params){
                var vals = params.name.split(',')
                return('<strong>' + vals[0] +
                '</strong><br />s.x-axis: ' + parseFloat(params.value[0]).toFixed(2) +
                '<br />s.y-axis: ' +  parseFloat(params.value[1]).toFixed(2)) +
                '<br />setSize: ' + vals[1] +
                '<br />p-adjust ANOVA: ' + Number(vals[2]).toPrecision(2)
            }"))

        cat("Significance is calculated by -log10(p-value). Top N sets shown irrespective of FDR.<br>")
    p2
    }
}

```{r,echart2d,results="asis",echo=FALSE, fig.height = 7, fig.width = 7 ,fig.show="all", message=FALSE}

echartscatter<-function(i){
    my_x=plan[i,1]
    my_y=plan[i,2]
    XCOL=colnames(myres)[3+my_x]
    YCOL=colnames(myres)[3+my_y]
    myres$set<-sub(","," ",as.character(myres$set))
    colnames(myres)[3+my_x]<-"xx"
    colnames(myres)[3+my_y]<-"yy"

    p2 <- myres %>%
        tibble::rownames_to_column("model") %>%
        mutate(set = paste(set, setSize, p.adjustMANOVA , s.dist , sep = ",")) %>%
        e_charts(x = xx , height = 300 ) %>%
        e_legend(show = FALSE) %>%
        e_x_axis(name = XCOL) %>%  # add x axis name
        e_y_axis(name = YCOL) %>%  # add y axis name
        e_scatter( serie = yy , bind = set , symbolSize = 10  ) %>%
        e_tooltip(formatter = htmlwidgets::JS("
            function(params){
            var vals = params.name.split(',')
            return('<strong>' + vals[0] +
            '</strong><br />s.x-axis: ' + parseFloat(params.value[0]).toFixed(2) +
            '<br />s.y-axis: ' +  parseFloat(params.value[1]).toFixed(2)) +
            '<br />setSize: ' + vals[1] +
            '<br />p-adjust MANOVA: ' + Number(vals[2]).toPrecision(2) +
            '<br />s.dist: ' + Number(vals[3]).toPrecision(2)
        }"))
    p2
}

if (d!=1) {
    cat("All sets with FDR<0.05. Try hovering over the points.<br>")

    numsets=nrow(subset(res$enrichment_result,p.adjustMANOVA<0.05))

    p=NULL

    if (numsets<1){

        message("No significant enrichments found.")
        p2<-list()

    } else {

        myres<-subset(res$enrichment_result,p.adjustMANOVA<0.05)

        if ( d<3 ) {

            myres2<-myres[,c(1,which(names(myres) %in% "p.adjustMANOVA"),2, 4:(4+d-1) , which(names(myres) %in% "s.dist") )]
            myres2$set<-sub(",","",myres2$set)
            XCOL=colnames(myres2)[4]
            YCOL=colnames(myres2)[5]
            colnames(myres2)[4]<-"xx"
            colnames(myres2)[5]<-"yy"

            p2 <- myres2 %>%
                tibble::rownames_to_column("model") %>%
                mutate(set = paste(set, setSize, p.adjustMANOVA , s.dist , sep = ",")) %>%
                e_charts(x = xx) %>%
                e_legend(show = FALSE) %>%
                e_x_axis(name = XCOL) %>%  # add x axis name
                e_y_axis(name = YCOL) %>%  # add y axis name
                e_scatter( serie = yy , bind = set , symbolSize = 10  ) %>%
                e_tooltip(formatter = htmlwidgets::JS("
                    function(params){
                    var vals = params.name.split(',')
                    return('<strong>' + vals[0] +
                    '</strong><br />s.x-axis: ' + parseFloat(params.value[0]).toFixed(2) +
                    '<br />s.y-axis: ' +  parseFloat(params.value[1]).toFixed(2)) +
                    '<br />setSize: ' + vals[1] +
                    '<br />p-adjust MANOVA: ' + Number(vals[2]).toPrecision(2) +
                    '<br />s.dist: ' + Number(vals[3]).toPrecision(2)
                }"))
        } else {
            plan<-combinations(n = d, r = 2, v = seq_len(d), repeats.allowed = FALSE)
            myres<-myres[,c(1, which(names(myres) %in% "p.adjustMANOVA") ,2,4:(4+d-1),
                which(names(myres) %in% "s.dist") ), which(names(myres) %in% "SD")]
            p2<-list()
            p2<-lapply( seq_len(nrow(plan)) , echartscatter)
        }
    htmltools::tagList(p2)
    }
}

if (d!=1) {
    cat("Top N sets irrespective of FDR. Try hovering over the points.<br>")
    resrows=length(res$detailed_sets)
    p=NULL

    if (resrows<1){
        message("No results found.")
    } else {
        myres<-head(res$enrichment_result,resrows)

        if ( d<3 ) {
            myres2<-myres[,c(1,which(names(myres) %in% "p.adjustMANOVA"),2, 4:(4+d-1) ,
                which(names(myres) %in% "s.dist") )]

            myres2$set<-sub(",","",myres2$set)
            XCOL=colnames(myres2)[4]
            YCOL=colnames(myres2)[5]
            colnames(myres2)[4]<-"xx"
            colnames(myres2)[5]<-"yy"

            p2<-myres2 %>%
                tibble::rownames_to_column("model") %>%
                mutate(set = paste(set, setSize, p.adjustMANOVA , s.dist , sep = ",")) %>%
                e_charts(x = xx) %>%
                e_legend(show = FALSE) %>%
                e_x_axis(name = XCOL) %>%  # add x axis name
                e_y_axis(name = YCOL) %>%  # add y axis name
                e_scatter( serie = yy , bind = set , symbolSize = 10  ) %>%
                e_tooltip(formatter = htmlwidgets::JS("
                    function(params){
                    var vals = params.name.split(',')
                    return('<strong>' + vals[0] +
                    '</strong><br />s.x-axis: ' + parseFloat(params.value[0]).toFixed(2) +
                    '<br />s.y-axis: ' +  parseFloat(params.value[1]).toFixed(2)) +
                    '<br />setSize: ' + vals[1] +
                    '<br />p-adjust MANOVA: ' + Number(vals[2]).toPrecision(2) +
                    '<br />s.dist: ' + Number(vals[3]).toPrecision(2)
                }"))
        } else {
            plan<-combinations(n = d, r = 2, v = seq_len(d), repeats.allowed = FALSE)

            myres<-myres[,c(1, which(names(myres) %in% "p.adjustMANOVA") ,2,4:(4+d-1),
                which(names(myres) %in% "s.dist") ), which(names(myres) %in% "SD")]

            p<-list()
            lapply( seq_len(nrow(plan)) , echartscatter)
        }
    htmltools::tagList(p)
    htmltools::tagList(p2)
    }
}

```

```{r,heatmap,results="asis",echo=FALSE, fig.height = 10, fig.width = 7 ,fig.show="all", message=FALSE}

if (d!=1) {
    if (resrows>2) {
        cat("<h2> A heatmap of S values for top results</h2><br>")
        hmapx<-head( res$enrichment_result[,4:(4+d-1)] ,resrows)
        rownames(hmapx)<-head(res$enrichment_result$set,resrows)
        colnames(hmapx)<-gsub("^s.","",colnames(hmapx))
        my_palette <- colorRampPalette(c("blue", "white", "red"))(n = 25)

        if(resrows<25){
            CEXROW=1
        } else if (resrows<51) {
            CEXROW=0.8
        } else if (resrows<76) {
            CEXROW=0.6
        } else if (resrows<101) {
            CEXROW=0.4
        } else {
            CEXROW=0.25
        }
        heatmap.2(as.matrix(hmapx),scale="none",margin=c(10, 25),cexRow=CEXROW,trace="none",cexCol=1,col=my_palette)
    }
}

```

```{r,effectsize,results="asis",echo=FALSE, fig.height = 7, fig.width = 7 ,fig.show="all", message=FALSE}

if (d!=1) {
    cat('<h2> A plot of effect size versus significance</h2><br>')
    cat('Significance is the -log2(p.adjustMANOVA) and effect size is the s.dist which is the hypotenuse of the s scores.<br>')
    colnames(myres)<-gsub("\\.","_",colnames(myres))
    myres<-res$enrichment_result
    myres$significance<--log2(myres$p.adjustMANOVA)
    myres$set<-sub(",","",myres$set)
    XCOL=colnames(myres)[ncol(myres)-3]
    YCOL=colnames(myres)[ncol(myres)]
    colnames(myres)[ncol(myres)-3]<-"xx"
    colnames(myres)[ncol(myres)]<-"yy"

    p2<-myres %>%
        tibble::rownames_to_column("model") %>%
        mutate(set = paste( set , setSize , p.adjustMANOVA , sep = ",")) %>%
        e_charts( x = xx) %>%
        e_legend(show = FALSE) %>%
        e_x_axis(name = XCOL) %>%  # add x axis name
        e_y_axis(name = YCOL) %>%  # add y axis name
        e_scatter( serie = yy , bind = set , symbolSize = 10  ) %>%
        e_tooltip(formatter = htmlwidgets::JS("
            function(params){
            var vals = params.name.split(',')
            return('<strong>' + vals[0] +
            '</strong><br />s.x-axis: ' + parseFloat(params.value[0]).toFixed(2) +
            '<br />s.y-axis: ' +  parseFloat(params.value[1]).toFixed(2)) +
            '<br />setSize: ' + vals[1] +
            '<br />p-adjust MANOVA: ' + Number(vals[2]).toPrecision(2)
        }"))
    p2
}

```

## Results table

```{r,results_table,results="asis",echo=FALSE}

if ( d==1 ) {
    resrows=length(res$detailed_sets)
    myres<-head(res$enrichment_result,resrows)
    myres[,c(3:ncol(myres))]<-signif(myres[,c(3:ncol(myres))],3)
} else if (d>1) {
    resrows=length(res$detailed_sets)
    myres<-head(res$enrichment_result,resrows)
    myres<-myres[,c(1:3, which(names(myres) %in% "p.adjustMANOVA"), which(names(myres) %in% "s.dist") ,4:((d*2)+3)), which(names(myres) %in% "SD")]
    myres[,3:ncol(myres)]<-signif(myres[,3:ncol(myres)],3)
}

formatted<-myres
formatted[,1]<-gsub("_"," ",myres[,1])

kbl( formatted , format="markdown", row.names=FALSE, caption = cat(paste("Top N=",resrows,"gene sets")) ,digits=100) %>%
kable_styling("hover", full_width = FALSE)

cat("<hr><br>")

```

## Results (complete table)

```{r,results_table_complete,results="asis",echo=FALSE}

myres<-res$enrichment_result

if ( d==1 ) {
    myres[,c(3:ncol(myres))]<-signif(myres[,c(3:ncol(myres))],3)
    formatted<-myres
    formatted[,1]<-gsub("_"," ",myres[,1])
} else if (d>1) {
    myres<-myres[,c(1:3, which(names(myres) %in% "p.adjustMANOVA"), which(names(myres) %in% "s.dist") ,4:((d*2)+3)), which(names(myres) %in% "SD")]
    myres[,3:ncol(myres)]<-signif(myres[,3:ncol(myres)],3)
    formatted<-myres
    formatted[,1]<-gsub("_"," ",myres[,1])
    formatted[,3:ncol(myres)]<-format(myres[,3:ncol(myres)],digits=3)
}

HEADER=paste("<br><details><summary><b>","Click HERE to show results for all gene sets","</b></summary><br><p>",sep=" " )

cat(HEADER)

kbl(formatted, format="html", row.names=FALSE, caption = "Complete results",digits=100) %>%
kable_styling("hover", full_width = FALSE)

cat("<br></p></details>")
cat("<hr><br>")

```

```{r,detailed_geneset_reports1d,results="asis",echo=FALSE,fig.height=6, fig.width=6 ,out.width = '80%',comment=NA, message=FALSE}

if (d==1) {
    cat("<h2>Detailed Gene set reports</h2><br>")
    cat('<br>')
    cat('\n')
    ss<-res$ranked_profile

    for ( i in seq_len(resrows) ) {
        mydat = NULL
        mydat<-t(myres[i,])

        cat(paste("<b>",as.character(myres[i,1]) ,"</b><br>"))

        tbl <- kbl(mydat,col.names = NULL,format='pipe',caption=NULL ) %>%
            kable_styling("hover", full_width = FALSE)

        cat(tbl)
        cat('\n\n<!-- -->\n\n')
        cat("<br>")

        # plots
        sss<-res$detailed_sets[[i]]
        set<-names(res$detailed_sets[i])
        size<-length(sss)
        par(mfrow=c(3,1))

        beeswarm(sss,vertical = FALSE,cex=0.75,xlim=c(min(ss),
        max(ss)),col="darkgray",pch=19,main=set,cex.main=1.5,
        xlab=paste("ranked DE score in:",colnames(ss)))

        mtext("beeswarm plot",cex=0.8)

        hist(sss,xlim=c(min(ss),max(ss)),breaks=15,col="darkgray",main=NULL,
        border="black",xlab=paste("ranked DE score in:",colnames(ss)))

        mtext("histogram",cex=0.8)

        plot(sss,rep(1,length(sss)),type="n",xlim=c(min(ss),max(ss)),
        frame=FALSE,axes=FALSE,ylab="",
        xlab=paste("ranked DE score in:",colnames(ss)))

        rug(sss, ticksize = 0.9)
        axis(1)
        mtext("rugplot",cex=0.8)
        cat("<br>")

        # top gene list
        setSign=sign(res$enrichment_result[i,4])

        if (setSign==-1) {
            tops<-as.data.frame(res$detailed_sets[[i]][order(res$detailed_sets[[i]])])
        } else if (setSign==1) {
            tops<-as.data.frame(res$detailed_sets[[i]][order(-res$detailed_sets[[i]])])
        }

        cat("Top enriched genes\\n")
        tops$GeneID<-rownames(tops)
        tops<-tops[,c(2,1)]
        colnames(tops)=c("GeneID","Gene Rank")
        cat("<br>")

        tbl <- kbl(head(tops,n=20L), format='pipe', row.names=FALSE,caption="Top 20 genes",digits=100) %>%
                kable_styling("hover", full_width = FALSE)

        cat(tbl)
        cat('\n\n<!-- -->\n\n')
        HEADER=paste("<br><details><summary><b>","Click HERE to show all gene set members","</b></summary><br><p>",sep=" " )
        cat(HEADER)

        tbl <- kbl(tops, format='pipe', row.names=FALSE, caption="All member genes",digits=100) %>%
                kable_styling("hover", full_width = FALSE)

        cat(tbl)
        cat('\n\n<!-- -->\n\n')
        cat("<br></p></details>")
        cat("<br><hr>")
    }
}

```

```{r,detailed_geneset_reports2d,results="asis",echo=FALSE,fig.height=5, fig.width=6 ,out.width = '80%',comment=NA, message=FALSE}

twodimplot<-function(i) {
    ll<-res$enrichment_result[i,]
    size<-ll$setSize
    sss<-res$detailed_sets[[i]]
    k<-MASS:::kde2d(sss[,1],sss[,2])
    filled.contour( k, color = palette, xlim=c(xmin,xmax),ylim=c(ymin,ymax),
    plot.title={ abline(v=0,h=0,lty=2,lwd=2,col="blue")
    title( main=ll$set , xlab=X_AXIS,ylab=Y_AXIS )})

    plot(sss, pch=19, col=rgb(red = 0, green = 0, blue = 0, alpha = 0.2),
    main=ll$set , xlim=c(xmin,xmax),ylim=c(ymin,ymax),
    xlab=X_AXIS,ylab=Y_AXIS)

    abline(v=0,h=0,lty=2,lwd=2,col="blue")
    sss_long<-melt(sss)
    colnames(sss_long) <- c("gene","contrast","value")
    colnames(ss_long) <- c("gene","contrast","value")

    p<-ggplot(ss_long,aes(contrast,value)) +
    geom_violin(data=ss_long,fill = "grey", colour = "grey") +
    geom_boxplot(data=ss_long,width=0.9,fill="grey",outlier.shape = NA) +
    geom_violin(data=sss_long,fill = "black", colour = "black") +
    geom_boxplot(data=sss_long,width=0.1,outlier.shape = NA) +
    labs(y = "Position in rank",title = ll[,1] )

    print( p + theme_bw() +
    theme( axis.text=element_text(size=14),
    axis.title=element_text(size=15),
    plot.title = element_text(size = 14)))
}


# subset contour plot
ggpairs_contour_limit_range <- function(data ,mapping, ...){
    p <- ggplot(data = data, mapping = mapping) +
    stat_density2d(aes(fill=..density..), geom="tile", contour = FALSE) +
    geom_vline(xintercept=0,linetype="dashed") +
    geom_hline(yintercept=0,linetype="dashed") +
    scale_fill_gradientn(colours=palette(25)) +
    scale_x_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[1]))]),max(ss[,gsub("~","",as.character(mapping[1]))])) ) +
    scale_y_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[2]))]),max(ss[,gsub("~","",as.character(mapping[2]))])) )
    p
}


# subset points plot
ggpairs_points_limit_range <- function(data ,mapping, ...){
    p <- ggplot(data = data, mapping = mapping) +
    geom_point(alpha=0.1) +
    geom_vline(xintercept=0,linetype="dashed") +
    geom_hline(yintercept=0,linetype="dashed") +
    scale_x_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[1]))]),max(ss[,gsub("~","",as.character(mapping[1]))])) ) +
    scale_y_continuous( limits = range(min(ss[,gsub("~","",as.character(mapping[2]))]),max(ss[,gsub("~","",as.character(mapping[2]))])) )
    p
}


ndplot<-function(i) {
    ll<-res$enrichment_result[i,]
    size<-ll$setSize
    ss<-res$ranked_profile
    sss<-res$detailed_sets[[i]]

    if ( d>5 ) {
        colnames(sss)<- paste("d",seq_len(d),sep="")
    }

    empty_cnt <- length(which(is.na(cor(sss,use="pairwise.complete.obs"))))
    if ( empty_cnt == 0 ) {

        p<-ggpairs(as.data.frame(sss), title=ll[,1], lower=list(continuous=ggpairs_contour_limit_range),
        diag=list(continuous=wrap("barDiag", binwidth=nrow(ss)/10)) )

        print( p + theme_bw() )

        p<-ggpairs(as.data.frame(sss), title=ll[,1], lower= list(continuous = ggpairs_points_limit_range ),
        diag=list(continuous=wrap("barDiag", binwidth=nrow(ss)/10)))

        print( p + theme_bw() )
    }

    sss_long<-melt(sss)
    colnames(sss_long) <- c("gene","contrast","value")
    colnames(ss_long) <- c("gene","contrast","value")

    empty_cnt <- apply(sss,2,function(x) sum(as.numeric(is.finite(x))))
    empty_cnt <- length(which(empty_cnt==0))
    if ( empty_cnt == 0 ) {

        p<-ggplot(ss_long,aes(contrast,value)) +
        geom_violin(data=ss_long,fill = "grey", colour = "grey") +
        geom_boxplot(data=ss_long,width=0.9,fill="grey",outlier.shape = NA) +
        geom_violin(data=sss_long,fill = "black", colour = "black") +
        geom_boxplot(data=sss_long,width=0.1,outlier.shape = NA) +
        labs(y = "Position in rank",title = ll[,1] )

        print( p + theme_bw() +
        theme( axis.text=element_text(size=14),
        axis.title=element_text(size=15),
        plot.title = element_text(size = 14)))
    }
}


topgenelist<-function(i) {
    ss<-res$ranked_profile
    sss<-res$detailed_sets[[i]]

    if ( d>5 ) {
        colnames(sss)<- paste("d",seq_len(d),sep="")
    }

    tl=bl=tr=br=0
    myres<-head(res$enrichment_result,resrows)
    myres<-myres[,c(1:3, which(names(myres) %in% "p.adjustMANOVA"), which(names(myres) %in% "s.dist") ,4:((d*2)+3)) , which(names(myres) %in% "s.dist")]
    myres[,3:ncol(myres)]<-signif(myres[,3:ncol(myres)],3)

    #select 2 strongest columns to highlight genes
    if( d>2 ) {
        cols<-(ncol(myres)-(2*d)+1):(ncol(myres)-(2*d)+d)
        COLS<-order(-abs(unlist((myres[i,cols]))))[1:2]
        sss<-sss[,COLS]
        cols<-cols[COLS]
        mysx=signif(myres[i,cols[1]],3)
        mysy=signif(myres[i,cols[2]],3)
    } else {
        cols=c(ncol(myres)-3,ncol(myres)-2)
        mysx=signif(myres[i,cols[1]],3)
        mysy=signif(myres[i,cols[2]],3)
    }

    if ( mysy>0 ) { tl=tl+1 ; tr=tr+1  } else { bl=bl+1 ; br=br+1 }
    if ( mysx>0 ) { tr=tr+1 ; br=br+1  } else { tl=tl+1 ; bl=bl+1 }

    if (bl==2) {
        myquad<-sss[which(sss[,1]<0 & sss[,2]<0),,drop=FALSE]
        topgenes<-myquad[order(-rank(myquad[,1]*myquad[,2])),,drop=FALSE]
    }

    if (tr==2) {
        myquad<-sss[which(sss[,1]>0 & sss[,2]>0),,drop=FALSE]
        topgenes<-myquad[order(-rank(myquad[,1]*myquad[,2])),,drop=FALSE]
    }

    if (br==2) {
        myquad<-sss[which(sss[,1]>0 & sss[,2]<0),,drop=FALSE]
        topgenes<-myquad[order(rank(myquad[,1]*myquad[,2])),,drop=FALSE]
    }

    if (tl==2) {
        myquad<-sss[which(sss[,1]<0 & sss[,2]>0),,drop=FALSE]
        topgenes<-myquad[order(rank(myquad[,1]*myquad[,2])),,drop=FALSE]
    }

    cat("<br>")
    topgenes<-as.data.frame(topgenes)
    topgenes$Gene<-as.character(rownames(topgenes))
    topgenes<-topgenes[,c(3,1,2)]

    tbl <- kbl(head(topgenes,n=20L), format='pipe', row.names=FALSE, caption="Top 20 genes", digits=100) %>%
        kable_styling("hover", full_width = FALSE)

    cat(tbl)
    cat('\n\n<!-- -->\n\n')
    HEADER=paste("<br><details><summary><b>","Click HERE to show all gene set members","</b></summary><br><p>",sep=" " )
    cat(HEADER)
    sss<-res$detailed_sets[[i]]

    tbl <- kbl(sss, format='pipe', row.names=TRUE, caption="All member genes", digits=100) %>%
        kable_styling("hover", full_width = FALSE)

    cat(tbl)
    cat('\n\n<!-- -->\n\n')
    cat("<br></p></details>")
    cat("<br><hr>")
}


#functions end here

if (d!=1) {
    cat("<h2> Detailed Gene set reports</h2><br>")
    resrows=length(res$detailed_sets)
    ss<-res$ranked_profile
    myres<-head(res$enrichment_result,resrows)
    myres<-myres[,c(1:3, which(names(myres) %in% "p.adjustMANOVA"), which(names(myres) %in% "s.dist") ,4:((d*2)+3)), which(names(myres) %in% "SD")]
    myres[,3:ncol(myres)]<-signif(myres[,3:ncol(myres)],3)
    palette <- colorRampPalette(c("white", "yellow","orange" ,"red","darkred","black"))
    ss_long<-melt(ss)
    colnames(ss_long) <- c("gene","contrast","value")

    if ( d<3 ) {
        xmin=min(ss[,1])
        xmax=max(ss[,1])
        ymin=min(ss[,2])
        ymax=max(ss[,2])

            for ( i in seq_len(resrows )) {
                mydat = NULL
                mydat$metrics<-names(myres[2:ncol(myres)])
                mydat$values<-unname(t(myres[i,2:ncol(myres)]))
                mydat<-as.data.frame(cbind(mydat$metrics,mydat$values))
                colnames(mydat)<-c("metric","value")
                cat(paste("<b>",as.character(myres[i,1]) ,"</b><br>"))

                tbl <- kbl(mydat,format='pipe', caption=as.character(t(myres[i,1]))) %>%
                    kable_styling("hover", full_width = FALSE)

                cat(tbl)
                cat('\n\n<!-- -->\n\n')
                cat("<br>")
                twodimplot(i)
                cat("<br>")
                topgenelist(i)
                cat("<hr><br>")
            }
        } else {

        for ( i in seq_len(resrows )) {
            mydat = NULL
            mydat$metrics<-names(myres[2:ncol(myres)])
            mydat$values<-unname(t(myres[i,2:ncol(myres)]))
            mydat<-as.data.frame(cbind(mydat$metrics,mydat$values))
            colnames(mydat)<-c("metric","value")
            cat(paste("<b>",as.character(myres[i,1]) ,"</b><br>"))

            tbl <- kbl(mydat,format='pipe',digits=5,caption=as.character(t(myres[i,1]))) %>%
                    kable_styling("hover", full_width = FALSE)

            cat(tbl)
            cat('\n\n<!-- -->\n\n')
            cat("<br>")
            ndplot(i)
            cat("<br>")
            topgenelist(i)
            cat("<hr><br>")
        }
    }
}

```

## Network diagram

Only used for one-dimensional analysis.

Here, the network diagram is used to depict the similarity between some of the top ranked gene sets.
It makes separate charts for up and downregulated sets.
It works best when prioritisation is done by effect size during the `mitch_calc()` step.
By default, we only show the top 20 genes, but you can use the `networkplot()` command yourself
with other options.
See `?networkplot` for more detail.
There is an element of stochasticity with regard to the network projection, so if you see a lot of
overlapping labels or labels getting cut off, you could repeat the chart generation until you get a
nice layout.
See `?networkplot` for more detail.

Below the network diagrams, you will see lists of genes that make up the up and downregulated sets
respectively.
For upregulated genes the score needs to be >2 and for downregulated genes it needs to be < -2.
This is to remove genes that have uninteresting differential expression and do not contribute
enrichment.

```{r,network,fig.height=6, fig.width=14}

if (d==1) {
  networkplot(eres=res,FDR=0.05,n_sets=20)
  network_genes(eres=res,FDR=0.05,n_sets=20)
} else {
 message("Network charts only generated in one-dimensional analysis.")
}

```

## Session information

Here is the session info with all the versions of packages used.

```{r session_info, include=TRUE, echo=TRUE, results='markup'}

sessionInfo()

```

END of report
