In gerstung-lab/BarrettsProgressionRisk: Prognositc adenocarcinoma risk prediction for Barrett's Esophagus

library(BarrettsProgressionRisk)
library(knitr)
library(kableExtra)
library(ggrepel)
library(gtable)
library(grid)

knitr::opts_chunk$set(echo=FALSE, warning=FALSE, message=FALSE)

inputPath = normalizePath(params$path)
clinInfoFile = normalizePath(params$info.file)

rawFile = grep('raw', list.files(inputPath, pattern='txt', full.names=T), value=T, ignore.case=T)
corrFile = grep('corr|fitted', list.files(inputPath, pattern='txt', full.names=T), value=T,ignore.case=T)

sample.info = loadSampleInformation(clinInfoFile)

swgsObj = segmentRawData(info=sample.info, raw.data=rawFile, fit.data=corrFile, verbose=F)
pr = predictRiskFromSegments(swgsObj,verbose=F)

samples = c( sampleNames(pr,T), sampleNames(pr,F) )
blacklist = read.table(system.file("extdata", "qDNAseq_blacklistedRegions.txt", package="BarrettsProgressionRisk"), sep = '\t', header=T)

samplesdf = data.frame(matrix(samples, ncol=1))
if (length(samples) > 10)
  samplesdf = data.frame(matrix(samples, ncol=3))

This report is for research purposes only

Results {.tabset .tabset-fade .tabset-pills}

Surveillance/Treatment Recommendations {.tabset .tabset-fade .tabset-pills}

See the Technical Information tab for a description of the risk probabilities and recommendation rules.

recommendations = rx(pr)

Based on the provided samples this individual is recommended to return for r tolower(rev(recommendations$Rx)[1]).

riskCols = RColorBrewer::brewer.pal(11, "RdYlBu")[seq(1,11, 3)]
recommendations %>%
  select(`Time 1`, `Time 2`, Rx) %>%
  kable(format = "html", escape = F) %>%
  row_spec(nrow(recommendations), bold=T, color=ifelse(recommendations[nrow(recommendations),'Rule'] %in% c(1,4), 'white', 'black'), 
           background = riskCols[recommendations[nrow(recommendations),'Rule',drop=T]]) %>%
  kable_styling("bordered", full_width = F, position = 'left') 

Risk Per Endoscopy

printRisk <- function(x,low,high, risk='Unknown') {
  img = switch(risk, 
         'High'='img/Human_body_silhouette-RED.png',
         'Moderate'='img/Human_body_silhouette-YELLOW.png',
         'Low'='img/Human_body_silhouette-BLUE.png',
         'Unknown'='img/Human_body_silhouette-GREY.png')
  paste0(paste0(c("",rep(paste0('<img src="',img,'" alt="%" width="8"></img>'), x)), collapse=""), ' <b>',x, '%</b> (',low,'%-',high,'%)')
} 

preds = absoluteRiskCI(pr)
preds = preds %>% rowwise() %>% dplyr::mutate( img=printRisk(Probability*100,CI.low*100,CI.high*100,Risk) )

dplyr::select(preds, 'Endoscopy','Risk','img') %>% 
  kable(col.names=c('Endoscopy','Risk','Absolute Risk'), escape=FALSE) %>% 
  kable_styling(bootstrap_options=c('bordered',full_width=T))

patientEndoscopyPlot(pr)

Risk Per Sample

printRisk <- function(x,low,high, risk='Unknown') {
  img = switch(risk, 
         'High'='img/Human_body_silhouette-RED.png',
         'Moderate'='img/Human_body_silhouette-YELLOW.png',
         'Low'='img/Human_body_silhouette-BLUE.png',
         'Unknown'='img/Human_body_silhouette-GREY.png')
  paste0(paste0(c("",rep(paste0('<img src="',img,'" alt="%" width="8"></img>'), x)), collapse=""), ' <b>',x, '%</b> (',low,'%-',high,'%)')
} 

preds = absoluteRiskCI(pr,'sample')
preds = preds %>% rowwise() %>% dplyr::mutate( img=printRisk(Probability*100,CI.low*100,CI.high*100,Risk) )

table = dplyr::select(preds, 'Sample','Endoscopy','Pathology','Risk','img') %>% 
  kable(col.names=c('','Endoscopy','Pathology','Risk','Absolute Risk'), escape=FALSE) %>% 
  kable_styling(bootstrap_options=c('bordered',full_width=T)) 

for (endo in levels(preds$Endoscopy)) {
  rows = which(preds$Endoscopy == endo)
  table = table %>% group_rows(endo, rows[1], rows[length(rows)])  
}

table

p = patientRiskTilesPlot(pr)

legend = BarrettsProgressionRisk:::.get.legend(p)
p = p + theme(legend.position = 'none', axis.text.x = element_text(angle=45, hjust=1)) + 
  labs(title='Sample risk by endoscopy', y='Biopsy location', x='Sample Date')

gridExtra::grid.arrange(p)

gridExtra::grid.arrange(legend)

Technical information

Risks per-sample were assigned based on percentile calibrations of the probabilities across all samples used to build the model. Probabilities that fall in the blue are low risk, yellow are moderate risk, and red are high risk.

showPredictionCalibration() 

Surveillance/treatment recommendations are then assessed per pair of samples, presuming these samples come from different timepoint/endoscopies in the same patient. The following rules are applied using copy number risks, p53 IHC, and pathology where available.

filter(BarrettsProgressionRisk::rxRules, Rule != 'None') %>% 
#  mutate( Rx = cell_spec(Rx, "html", color = ifelse(Rule %in% c(1,4), 'white', 'black'), background = riskCols[Rule], bold = (Rule == 1), italic = (Rule < 3) ) )  %>% 
#  select(Rx, Description) %>%
  kable(escape=F, caption='Rules for recommending treatment') %>% 
    kable_styling("basic", full_width = F) 

Input Data {.tabset .tabset-fade .tabset-pills}

Sample files read in:

• Raw file: r rawFile
• Fitted file: r corrFile
• Pathology/p53 IHC file: r clinInfoFile

Samples

Samples provided for analysis:

table = kable(pr$segmented$sample.info %>% dplyr::select(-matches('Endoscopy')))  %>% 
  kable_styling(bootstrap_options=c('striped','condensed',full_width=T))

#table = kable(preds[,c('Sample','Risk','img')],col.names=c('','Risk','Absolute Risk'), escape=FALSE) %>% kable_styling(bootstrap_options=c('bordered',full_width=T)) 
for (endo in levels(pr$segmented$sample.info$Endoscopy)) {
  rows = which(pr$segmented$sample.info$Endoscopy == endo)
  table = table %>% group_rows(endo, rows[1], rows[length(rows)])  
}
table

For processing and predictions these samples are presumed to be from a single patient. If this is not true please provide separate directories for the raw files from each patient.

Processing pipeline {.tabset .tabset-fade .tabset-pills}

1. Exclude r nrow(blacklist) regions known to be poorly covered/highly homologous
2. Segment the data to identify CN breakpoints using the piecewise constant fit algorithm (or multi-pcf)
3. Remove any segments with fewer than 67 supporting base pairs (i.e. equivalent to 1Mb)
4. Evaluate per-sample errors and exclude samples with high error rates from risk prediction and recommendation

Quality Control

r nrow(subset(sampleResiduals(pr), Pass))/r nrow(sampleResiduals(pr)) samples have passed post-segmentation quality control with a variance cutoff less than 0.015.

sampleResiduals(pr) %>%
  mutate(
    Pass = cell_spec(Pass, "html", color=ifelse(Pass, 'green', 'red'), background=ifelse(Pass, 'green', 'red'))) %>%
  select(matches('sample'), varMAD_median, Pass) %>%
  kable(format = "html", escape = F, col.names=c('Sample','med(var(MAD(segments)))', 'QC Pass/Fail')) %>%
  kable_styling("bordered", full_width = F, position = 'left') 

Relative Copy Number Alteration Plots

These plots show the adjusted and scaled relative copy number fitted values (y-axis) plotted across the genome (chromosomes 1-22) for each sample. The bars in purple or green are regions that the model uses to predict the risk of progression. Wider bars show chromosome arms and the height for all bars reflects the relative CNA for that bin or arm.

plist = copyNumberMountainPlot(pr, annotate=T, legend=F, 'list')
do.call(gridExtra::grid.arrange, c(plist, ncol=1))

Raw segmented values

r nrow(segmentedValues(pr)) segments have been fitted across all samples, these are estimated to cover r round(pr$segmented$genome.coverage*100,2)% of the genome.

maxCol = ifelse(ncol(segmentedValues(pr)) < 8, ncol(segmentedValues(pr)) , 8)

segmentedValues(pr) %>% 
  kable(row.names=F, caption=paste('Segmented data:', nrow(segmentedValues(pr)), 'rows')) %>%
  kable_styling(bootstrap_options=c('striped','condensed',full_width=F, position='left')) %>%
  scroll_box(width = "100%", height = "400px")

Raw Segmentation Plots

These plots show the raw relative copy number fitted values from QDNAseq (red points) plotted across the genome (chromosomes 1-22) for each sample. The green show the segmented CN values that are used by the model to predict progression risk.

plotSegmentData(pr)

gerstung-lab/BarrettsProgressionRisk documentation built on June 22, 2021, 3:12 p.m.