Skip to content

Instantly share code, notes, and snippets.

@malinost malinost/helpers.R Secret
Created Sep 1, 2015

Embed
What would you like to do?
CNVupload
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
}
# 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')
})
})
# 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)
)
)
))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.