CNVupload

helpers.R

library(flsa)
my.flsa <-function(x){
  flsa(x,lambda2=c(0.1,1,10,100,1000, 1e4,1e5,1e6))
}

medianRegions<-function(res.flsa, g){
  if(length(res.flsa)!=length(g)) stop('vectors are of different length')
  stepMedian<-round(res.flsa,1)
  whReg<-c(1,(which(diff(stepMedian)!=0))+1)
  x<-rep(0,length(res.flsa))
  x[whReg]<-1
  data.frame(m=res.flsa,n=stepMedian,g=as.character(g),reg=cumsum(x))
}

medianRegions2 <- function(res.flsa){
  stepMedian<-round(res.flsa,1)
  whReg<-c(1,(which(diff(stepMedian)!=0))+1)
  x<-rep(0,length(res.flsa))
  x[whReg]<-1
  data.frame(m=res.flsa,n=stepMedian,reg=cumsum(x))
}

appendMedianRegions<-function(Y,no=1, factor=1){
  if(factor>1) stepMedian<-round(Y$MedianRatio/factor,1)*factor
  else stepMedian<-round(Y$MedianRatio,1)
  stepGT<-as.numeric(Y$Genotype)
  whReg<-c(1,union(which(diff(stepMedian)!=0),which(diff(stepGT)!=0))+1)
  x<-rep(0,nrow(Y))
  x[whReg]<-1
  if(no==1) Y<-cbind(Y, reg=cumsum(x))  
  else Y<-cbind(Y, reg2=cumsum(x))  
  Y
}

server.R

# This is the server logic for a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com
#

library(shiny)
library(ggvis)
library(ggplot2)
library(dplyr)
library(RColorBrewer) 

source('helpers.R')
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
Chroms<-c(1:22,'X','Y')
lens  <- c(249250621, 243199373, 198022430, 191154276, 180915260, 171115067, 
           159138663, 146364022, 141213431, 135534747, 135006516, 133851895, 
           115169878, 107349540, 102531392,  90354753,  81195210,  78077248, 
           59128983,   63025520,  48129895,  51304566, 155270560,  59373566)
lens  <- data.frame(krom=c(1:22,'X','Y'),len=lens,cumLen=cumsum(lens))
lens  <- cbind(lens, start=c(1,lens$cumLen[-24]+1))
lens  <- cbind(lens, middle=(lens$cumLen+lens$start)/2)



shinyServer(function(input, output) {

  data <- reactive({
    inFile <- input$file1
    varW  <- input$windowSize
    varF  <- input$genot
    varCol  <- switch(input$genot, no=input$colorVB, yed = input$colorVP)
    
    if (is.null(inFile))
      Z<-read.table("HCC1143.arachne_ratio.txt", header=T, sep='\t')
    else
      Z<-read.table(inFile$datapath, header=T, sep='\t')
    
    Z$StartMb <- Z$Start/1e6
    if(input$filterNA) Z <- Z %>% filter(Ratio != -1)
    
    ansFLSA <- matrix(0,nrow(Z),8) 
    for(ch in c(1:22,'X','Y')){
      
      wh  <- which(Z$Chromosome==ch)
      tmpR<-Z$Ratio[wh]
      tmpFLSA<-t(my.flsa(tmpR))
      ansFLSA[wh,]<-tmpFLSA
    }
    ansFLSA <- data.frame(ansFLSA)
    names(ansFLSA)<-paste('flsa',1:8,sep='')
    Z<-cbind(Z,ansFLSA)
    Z$CopyNumber<-as.factor( Z$CopyNumber)
    
      if(varF == "yes"){
        tmp <-levels(Z$Genotype)
        Z$Genotype<- factor(Z$Genotype, levels=c("-1","A","AB",tmp[-match(c("-1","A","AB"),tmp)]))
      } 
    
    
    ans.FLSA<-aggregate(Ratio~Chromosome,data=Z,my.flsa) 
    print(head(Z))
    Z
    
    
  })
  
  rct_name_colVP <- reactive({
    as.name(input$colorVP) 
  })
  rct_name_colVB <- reactive({
    as.name(input$colorVB) 
  })
  rct_name_col <- reactive({
    as.name(input$colorValues) 
  })
  
  reactive({
    chrL<-lens$len[match(input$krom, Chroms)]
    filterLim<-(input$xint * chrL)/1e8
    flsaX<-paste('flsa',input$lambda,sep='')
    data2 <- data %>%
      filter(Chromosome == input$krom)
    data2 <- data2 %>%
      filter(StartMb > filterLim[1]) %>%
      filter(StartMb < filterLim[2]) 
    if(input$logY) data2 <- data2 %>% ggvis(~StartMb, ~log(Ratio))
    else data2 <- data2 %>%  ggvis(~StartMb, ~Ratio,opacity:=input$opac) 
    data2 <- data2 %>%  scale_numeric("x",domain= filterLim,  nice = TRUE) 
    if(input$genot=="yes") data2 <- data2 %>% add_legend("fill", orient = "right", title = input$colorVP) 
    else  data2 <- data2 %>% add_legend("fill", orient = "right", title = input$colorVB) 
    data2 <- data2 %>%      
      add_axis("y", orient="left", ticks=5) %>%
      add_axis("y", values=c(-1,1),orient = "right", properties = axis_props(
        grid = list(stroke = "black", strokeWidth = 3),
        ticks = list(stroke = "blue", strokeWidth = 2)
      )) 
    if(input$flsa) data2<- data2 %>% layer_paths(prop("y", as.name(flsaX)),stroke:='gray',strokeWidth := 3) 
    data2 <- data2 %>%
      filter(Ratio < input$ymax) %>%
      scale_numeric("y", domain = c(0, NA), nice=TRUE) # %>%
    if(input$genot=='yes') data2 <- data2 %>%  layer_points(prop(property = 'fill',x = rct_name_colVP, scale=TRUE,), size := input_slider(2, 30,label="point size")) 
    else  data2 <- data2 %>%  layer_points(prop(property = 'fill',x = rct_name_colVB, scale=TRUE,), size := input_slider(2, 30,label="point size")) 
    data2 %>%	add_tooltip(function(data){
      paste0("pos Mb: ", data$StartMb, "<br>", "Ratio: ",data$Ratio)
    }, "hover") %>%
      set_options(width = 1000) 
  })%>%
    bind_shiny("ggvis", "ggvis_ui")
  
  output$plotgg <- renderPlot({
    data <- data()
    data$chrNum<-as.character(data$Chromosome)
    data$chrNum[data$chrNum=='X']<-23
    data$chrNum[data$chrNum=='Y']<-24
    data$chrNum<-as.numeric(as.character(data$chrNum))
    data$chrNum<-as.factor(data$chrNum)
    data$cumMb <- numeric(nrow(data))
    datastart  <- as.numeric(as.character(data$Start))
    data$cumMb <- (datastart+(lens$cumLen-lens$len)[match(data$Chromosome,Chroms)])/1e6
    ggplot(data, aes(cumMb, Ratio, color=chrNum)) +
      geom_point(aes(size = log(Ratio))) +
      scale_size(range = c(0.3, 2))+
      guides(col=guide_legend(ncol=3))+
      theme(panel.grid.major.y = element_line(size = 1, colour = "burlywood4", linetype = "dashed"), 
            panel.grid.minor.y = element_line(size = 1, colour = "burlywood4", linetype = "dotted")) +
      theme(panel.background = element_rect(fill = 'white', colour = 'black')) +
      scale_y_continuous(limits = c(0, input$ymax)) + 
      scale_color_manual(values=rep(cbPalette,3)) +
      geom_vline(xintercept = c(0, lens$cumLen)/1e6, linetype="dotted") +
      geom_hline(yintercept = c(1), linetype="dashed") +
      scale_x_continuous(breaks = lens$middle/1e6,labels=Chroms, name='Chromosome Position')
  })
  
  

})

ui.R

# This is the user-interface definition of a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com
#

library(shiny)
library(ggvis)
data <- list('Upload a file'=c(1))
shinyUI(fluidPage(

  # Application title
  titlePanel("Copy Number Profile"),
  
  tabsetPanel(
    tabPanel("CN Plot",
             plotOutput("plotgg")
    ),
    
    tabPanel(
      "Plot Single Chromosome", 
      uiOutput("ggvis_ui"),
      ggvisOutput("ggvis")
    )
  ),
  # Sidebar with a slider input for number of bins
  fluidRow(
    column(3,
      fileInput('file1', 'Choose (optionally compressed) CF text File',
                accept=c('application/x-gzip','text/plain', 'text/comma-separated-values,text/plain', '.txt.gz')),
      checkboxInput("filterNA","Filter NA values",TRUE),
      sliderInput("ymax",'height of y axis',   min=2, max=500, value=5)
    ),
    column(3,
      h4("Single Chromosome settings:",style = "color:blue"),
      selectInput("krom", "Choose chromosome", c(1:22,'X','Y')),
      sliderInput("xint",'range of chr',   min=0, max=100, value=c(0,100))
      
    ),
    column(3,   
           selectInput("genot", "Genotype in file:",choices = c("yes","no"),selected = "no"),
           conditionalPanel(
             condition = "input.genot == 'no'",
             selectInput("colorVB", label = "if no Genotype column, color values plot by:", 
                         c("Copy Number" ="CopyNumber",  "none"="Chromosome"))
           ),
           conditionalPanel(
             condition = "input.genot == 'yes'",
             selectInput("colorVP", label = "if pileup color values in Chr plot by:", 
                         c("Copy Number" ="CopyNumber","Genotype"="Genotype",   "none"="Chromosome"))
           ),
      
      checkboxInput("logY","Log ratio values",FALSE)
    ),
    column(3, 
      checkboxInput("flsa","Display FLSA lines",TRUE),
      sliderInput("lambda",   "average smoothing:",   min = 1,   max = 8,   value = 4),
      sliderInput("opac", "Point Opacity:",min=0,max=0.9,value=0.5)
    )
  )
))