Nothing
inst/ProstarApp/server/srv_ModulesSrv.R
In Prostar: Provides a GUI for DAPAR
#################### MODULES DEFINITION #################################
module_Not_a_numeric <- function(input, output, session, n){
output$msg_not_numeric <- renderUI({
n()
if (is.na(as.numeric(n()))){
tags$p("Please choose a number")
}
})
}
moduleDesignExample <- function(input, output, session, n){
output$nlevelsExample <- renderRHandsontable({
if (n == 2){
df <- data.frame(Sample.name= paste0("Sample ",as.character(1:14)),
Condition = c(rep("A", 4), rep("B", 4), rep("C", 6)),
Bio.Rep = as.integer(c(1,1,2,2,3,3,4,4,5,5,6,6,7,7)),
Tech.Rep = c(1:14),
stringsAsFactors = FALSE)
pal <- RColorBrewer::brewer.pal(3,listBrewerPalettes[1])
color_rend <- paste0("function (instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(col==1 && (row>=0 && row<=3)) {td.style.background = '",pal[1], "';}
if(col==1 && (row>=4 && row<=7)) {td.style.background = '",pal[2], "';}
if(col==1 && (row>=8 && row<=14)) {td.style.background = '",pal[3], "';}
if(col==2 && (row==0||row==1||row==4||row==5||row==8||row==9||row==12||row==13))
{td.style.background = 'lightgrey';}
if(col==3 && (row==0||row==2||row==4||row==6||row==8||row==10||row==12))
{td.style.background = 'lightgrey';}
}")
} else if (n == 3){
df <- data.frame(Sample.name= paste0("Sample ",as.character(1:16)),
Condition = c(rep( "A", 8), rep("B", 8)),
Bio.Rep = as.integer(c(rep(1,4),rep(2,4),rep(3,4),rep(4,4))),
Tech.Rep = as.integer(c(1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8)),
Analyt.Rep = c(1:16),
stringsAsFactors = FALSE)
pal <- RColorBrewer::brewer.pal(3,listBrewerPalettes[1])[1:2]
color_rend <- paste0("function (instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(col==1 && (row>=0 && row<=7)) {td.style.background = '",pal[1], "';}
if(col==1 && (row>=8 && row<=15)) {td.style.background = '",pal[2], "';}
if(col==2 && (row==0||row==1||row==2||row==3||row==8||row==9||row==10||row==11))
{td.style.background = 'lightgrey';}
if(col==3 && (row==0||row==1||row==4||row==5|| row==8||row==9||row==12||row==13))
{td.style.background = 'lightgrey';}
if(col==4 && (row==0||row==2||row==4||row==6|| row==8||row==10||row==12||row==14))
{td.style.background = 'lightgrey';}
}")
}
rhandsontable::rhandsontable(df,rowHeaders=NULL,fillHandle = list(direction='vertical', autoInsertRow=FALSE,
maxRows=nrow(rv$hot))) %>%
rhandsontable::hot_rows(rowHeights = 30) %>%
rhandsontable::hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE,
allowInsertRow = FALSE,allowInsertColumn = FALSE,
allowRemoveRow = FALSE,allowRemoveColumn = FALSE,
autoInsertRow=FALSE ) %>%
rhandsontable::hot_cols(readOnly = TRUE,renderer = color_rend)
})
}
moduleDetQuantImpValues <- function(input, output, session, quant,factor) {
output$detQuantValues_DT <- renderDataTable(server=TRUE,{
req(rv$current.obj, quant(), factor())
values <- getQuantile4Imp(Biobase::exprs(rv$current.obj), quant()/100, factor())
DT::datatable(as.data.frame(t(values$shiftedImpVal)),
rownames = FALSE,
options = list(initComplete = initComplete(),
dom = 't',
bLengthChange = FALSE))
})
}
modulePopover <- function(input, output, session, data){
ns <- session$ns
output$customPopover <- renderUI({
req(data())
div(
div(
# edit1
style="display:inline-block; vertical-align: middle; padding-bottom: 5px;",
data()$title
),
div(
# edit2
style="display:inline-block; vertical-align: middle;padding-bottom: 5px;",
if (!is.null(data()$color) && ('white' == data()$color)) {
tags$button(id=ns("q1"), tags$sup("[?]"), class="Prostar_tooltip_white")
} else {
tags$button(id=ns("q1"), tags$sup("[?]"), class="Prostar_tooltip")
},
shinyBS::bsPopover(id = ns("q1"), title = "",
content = data()$content,
placement = "right",
trigger = "hover",
options = list(container = "body")
)
)
)
})
}
#------------------------------------------------------------
moduleLegendColoredExprs <- function(input, output, session){}
#------------------------------------------------------------
moduleVolcanoplot <- function(input, output, session, data, comp, tooltip, isSwaped){
ns <- session$ns
observeEvent(data(), {
print('############ NEW DATA on rv$resAnaDiff')
})
output$quantiDT <- renderUI({
req(input$eventPointClicked)
if (is.null(rv$matAdj)){
shinyBS::bsCollapse(id = ns("collapseVolcanoInfos"), open = "Protein",multiple = TRUE,
shinyBS::bsCollapsePanel("Protein", tagList(
uiOutput(ns("Warning_Infos")),
DT::dataTableOutput(ns("Infos"))),style = "info"))
} else {
shinyBS::bsCollapse(id = ns("collapseVolcanoInfos"), open = "Protein",multiple = TRUE,
shinyBS::bsCollapsePanel("Protein", tagList(
uiOutput(ns("Warning_Infos")),
DT::dataTableOutput(ns("Infos"))),style = "info"),
shinyBS::bsCollapsePanel("Specific peptides",tagList(
uiOutput(ns("Warning_specificPeptidesInfos")),
DT::dataTableOutput(ns("specificPeptidesInfos"))), style = "primary"),
shinyBS::bsCollapsePanel("Shared peptides", tagList(
uiOutput(ns("Warning_sharedPeptidesInfos")),
DT::dataTableOutput(ns("sharedPeptidesInfos"))), style = "primary"))
}
})
output$nbSelectedItems <- renderUI({
rv$widgets$anaDiff$th_pval
rv$widgets$hypothesisTest$th_logFC
rv$current.obj
data()
if(is.null(data()$logFC) || is.null(data()$P_Value)){return(NULL)}
if (length(which(is.na(Biobase::exprs(rv$current.obj)))) > 0) {return(NULL)}
p <- NULL
p <- data()
upItemsPVal <- NULL
upItemsLogFC <- NULL
upItemsLogFC <- which(abs(p$logFC) >= as.numeric(rv$widgets$hypothesisTest$th_logFC))
upItemsPVal <- which(-log10(p$P_Value) >= as.numeric(rv$widgets$anaDiff$th_pval)
)
rv$nbTotalAnaDiff <- nrow(Biobase::exprs(rv$current.obj))
rv$nbSelectedAnaDiff <- NULL
t <- NULL
if (!is.null(rv$widgets$anaDiff$th_pval
) && !is.null(rv$widgets$hypothesisTest$th_logFC) ) {
t <- intersect(upItemsPVal, upItemsLogFC)}
else if (!is.null(rv$widgets$anaDiff$th_pval
) && is.null(rv$widgets$hypothesisTest$th_logFC) ) {
t <- upItemsPVal}
else if (is.null(rv$widgets$anaDiff$th_pval
) && !is.null(rv$widgets$hypothesisTest$th_logFC) ) {
t <- upItemsLogFC}
rv$nbSelectedAnaDiff <- length(t)
txt <- paste("Total number of ",rv$typeOfDataset, "(s) = ",
rv$nbTotalAnaDiff,"<br>",
"Number of selected ",rv$typeOfDataset, "(s) = ",
rv$nbSelectedAnaDiff,"<br>",
"Number of non selected ",rv$typeOfDataset, "(s) = ",
(rv$nbTotalAnaDiff -rv$nbSelectedAnaDiff), sep="")
HTML(txt)
})
GetSortingIndices <- reactive({
req(comp())
condition1 = strsplit(comp(), "_vs_")[[1]][1]
condition2 = strsplit(comp(), "_vs_")[[1]][2]
if (length(grep("all",condition2))==0) {
ind <- c( which(pData(rv$current.obj)$Condition==condition1),
which(pData(rv$current.obj)$Condition==condition2))
} else {
ind <- c( which(pData(rv$current.obj)$Condition==condition1),
c(1:nrow(pData(rv$current.obj)))[-(which(pData(rv$current.obj)$Condition==condition1))])
}
ind
})
GetBorderIndices <- reactive({
conds <- (pData(rv$current.obj)$Condition)[GetSortingIndices()]
## build index for border-formatting
borders_index <- unlist(lapply(unique(conds), function(x){which.max(x== conds)}))
borders_index
})
output$Warning_sharedPeptidesInfos <- renderUI({
GetDataFor_sharedPeptidesInfos()
if (nrow(GetDataFor_sharedPeptidesInfos())>153)
p(MSG_WARNING_SIZE_DT)
})
GetDataFor_sharedPeptidesInfos <- reactive({
#req(rv$current.obj)
req(comp())
#req(rv$matAdj)
ind <- GetSortingIndices()
borders_index <- GetBorderIndices()
prev.dataset <- rv$dataset[[names(rv$dataset)[last(grep(pattern='peptide', names(rv$dataset)))]]]
prot <- GetExprsClickedProtein()
prot.indice <- rownames(prot)
#print(prot.indice)
data <- getDataForExprs(prev.dataset)
data <- data[,c(ind, (ind + ncol(data)/2))]
Xspec <- rv$matAdj$matWithUniquePeptides
Xshared <- rv$matAdj$matWithSharedPeptides
i <- which(colnames(Xspec)==prot.indice)
specificPeptidesIndices <- which(Xspec[,i]==1)
allPeptidesIndices <- which(Xshared[,i]==1)
peptidesIndices <- setdiff(allPeptidesIndices, specificPeptidesIndices)
data <- data[peptidesIndices,]
data
})
output$sharedPeptidesInfos <- renderDataTable(server=TRUE,{
data <- GetDataFor_sharedPeptidesInfos()
dt <- DT::datatable(data,
#colnames=NULL,
extensions = c('Scroller', 'Buttons'),
options = list(initComplete = initComplete(),
buttons = list('copy',
list(
extend = 'csv',
filename = 'sharedPeptidesInfos'
),'print'),
dom='Bfrtip',
blengthChange = FALSE,
displayLength = 20,
ordering=FALSE,
server = FALSE,
columnDefs = list(list(targets = c(((ncol(data)/2)+1):(ncol(data))), visible = FALSE))
)) %>%
formatStyle(
colnames(data)[1:(ncol(data)/2)],
colnames(data)[((ncol(data)/2)+1):(ncol(data))],
backgroundColor = styleEqual(c("POV", "MEC"), c(rv$colorsTypeMV$POV, rv$colorsTypeMV$MEC))
) %>%
formatStyle(borders_index, borderLeft = '3px solid #000000')
dt
})
output$Warning_specificPeptidesInfos <- renderUI({
GetDataFor_specificPeptidesInfos()
if (nrow(GetDataFor_specificPeptidesInfos())>153)
p(MSG_WARNING_SIZE_DT)
})
GetDataFor_specificPeptidesInfos <- reactive({
#req(rv$current.obj)
req(comp())
#req(rv$matAdj)
ind <- GetSortingIndices()
borders_index <- GetBorderIndices()
prev.dataset <- rv$dataset[[names(rv$dataset)[last(grep(pattern='peptide', names(rv$dataset)))]]]
prot <- GetExprsClickedProtein()
prot.indice <- rownames(prot)
data <- getDataForExprs(prev.dataset)
data <- data[,c(ind, (ind + ncol(data)/2))]
Xspec <- rv$matAdj$matWithUniquePeptides
i <- which(colnames(Xspec)==prot.indice)
peptidesIndices <- which(Xspec[,i]==1)
data <- data[peptidesIndices,]
data
})
output$specificPeptidesInfos <- renderDataTable(server=TRUE,{
data <- GetDataFor_specificPeptidesInfos()
dt <- DT::datatable( data,
#colnames=NULL,
extensions = c('Scroller', 'Buttons'),
options = list(initComplete = initComplete(),
buttons = list('copy',
list(
extend = 'csv',
filename = 'specific peptides infos'
),'print'),
dom='Bfrtip',
blengthChange = FALSE,
displayLength = 20,
ordering=FALSE,
columnDefs = list(list(targets = c(((ncol(data)/2)+1):(ncol(data))), visible = FALSE))
)) %>%
formatStyle(
colnames(data)[1:(ncol(data)/2)],
colnames(data)[((ncol(data)/2)+1):(ncol(data))],
backgroundColor = styleEqual(c("POV", "MEC"), c(rv$colorsTypeMV$POV, rv$colorsTypeMV$MEC))
) %>%
formatStyle(borders_index, borderLeft = '3px solid #000000')
dt
})
##------------------------------------------------------------------------------
GetExprsClickedProtein <- reactive({
req(rv$current.obj)
req(comp())
req(input$eventPointClicked)
rv$widgets$hypothesisTest$th_logFC
rv$widgets$anaDiff$th_pval
data()
ind <- GetSortingIndices()
this.index <- as.integer(strsplit(input$eventPointClicked, "_")[[1]][1])
this.series.name <- strsplit(input$eventPointClicked, "_")[[1]][2]
data <- getDataForExprs(rv$current.obj)
data <- data[,c(ind, (ind + ncol(data)/2))]
index.g1 <- which((-log10(data()$P_Value) >= rv$widgets$anaDiff$th_pval
) & (abs(data()$logFC) >= as.numeric(rv$widgets$hypothesisTest$th_logFC)))
data.g1 <- data[index.g1,]
data.g2 <- data[-index.g1,]
switch (this.series.name,
g1=data <- data.g1[this.index+1,],
g2 = data <- data.g2[this.index+1,]
)
data
})
output$Warning_Infos <- renderUI({
GetDataFor_Infos()
if (nrow(GetDataFor_Infos())>153)
p(MSG_WARNING_SIZE_DT)
})
GetDataFor_Infos <- reactive({
req(comp())
data <- GetExprsClickedProtein()
data
})
##------------------------------------------------------------------------------
output$Infos <- renderDataTable(server=TRUE,{
req(comp())
borders_index <- GetBorderIndices()
data <- GetExprsClickedProtein()
dt <- DT::datatable(data,
extensions = c('Scroller', 'Buttons'),
options = list(initComplete = initComplete(),
buttons = list('copy',
list(
extend = 'csv',
filename = 'Infos'
),'print'),
dom='Bfrtip',
blengthChange = FALSE,
displayLength = 20,
ordering=FALSE,
header=FALSE,
columnDefs = list(list(targets = c(((ncol(data)/2)+1):(ncol(data))), visible = FALSE))
)) %>%
formatStyle(
colnames(data)[1:(ncol(data)/2)],
colnames(data)[((ncol(data)/2)+1):(ncol(data))],
backgroundColor = styleEqual(c("POV", "MEC"), c(rv$colorsTypeMV$POV, rv$colorsTypeMV$MEC))) %>%
formatStyle(borders_index, borderLeft = '3px solid #000000')
dt
})
##---------------------------------------------------------------------
output$volcanoPlot <- renderHighchart({
rv$widgets$anaDiff$th_pval
rv$widgets$hypothesisTest$th_logFC
rv$colorsVolcanoplot
data()$P_Value
#data()$logFC
tooltip()
isSwaped()
isolate({
#if (is.null(rv$widgets$hypothesisTest$th_logFC) || is.na(rv$widgets$hypothesisTest$th_logFC) ){return()}
if ((length(data()$logFC) == 0) ){return()}
withProgress(message = 'Building plot...',detail = '', value = 0, {
if (length(which(is.na(Biobase::exprs(rv$current.obj)))) > 0) { return()}
df <- data.frame(x=data()$logFC,
y = -log10(data()$P_Value),
index = 1:nrow(fData(rv$current.obj)))
if (length( tooltip()) > 0){
df <- cbind(df,fData(rv$current.obj)[ tooltip()])
}
colnames(df) <- gsub(".", "_", colnames(df), fixed=TRUE)
if (ncol(df) > 3){
colnames(df)[4:ncol(df)] <-
paste("tooltip_", colnames(df)[4:ncol(df)], sep="")
}
clickFun <-
JS(paste0("function(event) {Shiny.onInputChange('",ns("eventPointClicked"),"', [this.index]+'_'+ [this.series.name]);}"))
cond <- c(data()$condition1, data()$condition2)
rv$tempplot$volcano <- diffAnaVolcanoplot_rCharts(df,
threshold_logFC = as.numeric(rv$widgets$hypothesisTest$th_logFC),
threshold_pVal = as.numeric(rv$widgets$anaDiff$th_pval),
conditions = cond,
clickFunction=clickFun,
palette = rv$colorsVolcanoplot,
swap = isSwaped()
)
})
rv$tempplot$volcano
})
})
}
#------------------------------------------------------------
#------------------------------------------------------------
moduleDensityplot <- function(input, output, session, data) {
#outputOptions(output, 'Densityplot', suspendWhenHidden=FALSE)
output$Densityplot <- renderHighchart({
#req(rv$current.obj)
data()
print("data() in densityPlot module")
print(data())
print(GetCurrentObjName())
rv$PlotParams$paletteConditions
rv$PlotParams$legendForSamples
tmp <- NULL
isolate({
withProgress(message = 'Making plot', value = 100, {
pattern <- paste0(GetCurrentObjName(),".densityplot")
tmp <- DAPAR::densityPlotD_HC(data(),
rv$PlotParams$legendForSamples,
rv$PlotParams$paletteConditions)
future(createPNGFromWidget(rv$tempplot$boxplot,pattern))
})
})
tmp
})
}
#------------------------------------------------------------
moduleBoxplot <- function(input, output, session, data) {
observeEvent(input$choosePlot, {
switch(input$choosePlot,
boxplot={
shinyjs::hide('viewViolinPlot')
shinyjs::show('BoxPlot')
},
violinplot={
shinyjs::hide('BoxPlot')
shinyjs::show('viewViolinPlot')
}
)
})
output$BoxPlot <- renderHighchart({
#req(rv$current.obj)
data()
rv$current.obj.name
rv$PlotParams$paletteConditions
rv$PlotParams$legendForSamples
tmp <- NULL
isolate({
pattern <- paste0(GetCurrentObjName(),".boxplot")
print(paste0("palette for boxplot : ",rv$PlotParams$paletteConditions) )
print(ncol(exprs(data())))
print(str(exprs(data())))
tmp <- boxPlotD_HC(data(),
rv$PlotParams$legendForSamples,
palette=rv$PlotParams$paletteConditions)
#future(createPNGFromWidget(tmp,pattern))
})
tmp
})
output$viewViolinPlot<- renderImage({
#req(rv$current.obj)
data()
rv$PlotParams$legendForSamples
rv$PlotParams$paletteConditions
tmp <- NULL
isolate({
# A temp file to save the output. It will be deleted after renderImage
# sends it, because deleteFile=TRUE.
outfile <- tempfile(fileext='.png')
# Generate a png
# png(outfile, width = 640, height = 480, units = "px")
png(outfile)
pattern <- paste0(GetCurrentObjName(),".violinplot")
tmp <- DAPAR::violinPlotD(data(), rv$PlotParams$legendForSamples, palette=rv$PlotParams$paletteConditions)
#future(createPNGFromWidget(tmp,pattern))
dev.off()
})
# Return a list
list(src = outfile,
alt = "This is alternate text")
}, deleteFile = TRUE)
}
moduleMVPlots <- function(input, output, session, data, title, palette) {
output$plot_viewNAbyMean <- renderHighchart({
req(data())
wrapper.hc_mvTypePlot2(obj=data(), title=title(), palette = palette())
})
output$WarnForImageNA <- renderUI({
tryCatch(
{
wrapper.mvImage(data())
},
warning = function(w) { p(conditionMessage(w))},
error = function(e) {p(conditionMessage(e))},
finally = {
#cleanup-code
})
})
output$plot_showImageNA <- renderImage({
#req(wrapper.mvImage(data()))
# A temp file to save the output. It will be deleted after renderImage
# sends it, because deleteFile=TRUE.
outfile <- tempfile(fileext='.png')
png(outfile)
wrapper.mvImage(data())
dev.off()
# Return a list
list(src = outfile,
alt = "This is alternate text")
}, deleteFile = TRUE)
}
moduleFilterStringbasedOptions <- function(input, output, session) {
output$FilterStringbasedOptions <- renderUI({
rv$current.obj
if (is.null(rv$current.obj)){return()}
tagList(
h4("String based filtering options")
,hr()
,h4("Filter contaminants"),
uiOutput("id_Contaminants"),
uiOutput("choosePrefixContaminants"),
br(),
h4("Filter reverse"),
uiOutput("id_Reverse"),
uiOutput("choosePrefixReverse"),
br(),
#actionButton("resetFilterParamsButton","Reset parameters"),
actionButton("performFilteringContaminants",
"Perform string-based filtering", class = actionBtnClass)
)
})
}
moduleStaticDataTable <- function(input, output, session,table2show, withBtns, showRownames=FALSE, dom='Bt', filename='Prostar_export') {
proxy = dataTableProxy(session$ns('StaticDataTable'), session)
observe({replaceData(proxy, table2show(), resetPaging = FALSE) })
output$warningOnSize <- renderUI({
if (length(table2show())==0){return(NULL)}
if (nrow(table2show())>153)
p(MSG_WARNING_SIZE_DT)
})
output$StaticDataTable <- DT::renderDataTable(server=TRUE,{
req(rv$current.obj)
#table2show
if (length(table2show())==0){return(NULL)}
print(table2show())
isolate({
DT::datatable(table2show(),
extensions = 'Buttons',
escape = FALSE,
# rownames= showRownames,
options=list(
buttons = list(
list(
extend = 'csv',
filename = filename
),
list(
extend = 'pdf',
filename = filename
),'print'),
#initComplete = initComplete(),
dom = dom
# server = FALSE,
# autoWidth=TRUE,
#columnDefs = list(list(width='150px',targets= "_all")),
#ordering = FALSE
)
)
})
})
}
moduleInsertMarkdown <- function(input, output, session,url){
ns <- session$ns
output$insertMD <- renderUI({
print(url)
tryCatch(
{
includeMarkdown(url)
}
, warning = function(w) {
#conditionMessage(w)
tags$p("URL not found. Please check your internet connection.")
#shinyjs::info(paste("URL not found",":",conditionMessage(w), sep=" "))
}, error = function(e) {
shinyjs::info(paste("Error :","in moduleInsertMarkdown",":", conditionMessage(e), sep=" "))
}, finally = {
#cleanup-code
})
})
}
Try the Prostar package in your browser
Any scripts or data that you put into this service are public.
Prostar documentation built on April 11, 2021, 6 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#################### MODULES DEFINITION #################################
module_Not_a_numeric <- function(input, output, session, n){
output$msg_not_numeric <- renderUI({
n()
if (is.na(as.numeric(n()))){
tags$p("Please choose a number")
}
})
}
moduleDesignExample <- function(input, output, session, n){
output$nlevelsExample <- renderRHandsontable({
if (n == 2){
df <- data.frame(Sample.name= paste0("Sample ",as.character(1:14)),
Condition = c(rep("A", 4), rep("B", 4), rep("C", 6)),
Bio.Rep = as.integer(c(1,1,2,2,3,3,4,4,5,5,6,6,7,7)),
Tech.Rep = c(1:14),
stringsAsFactors = FALSE)
pal <- RColorBrewer::brewer.pal(3,listBrewerPalettes[1])
color_rend <- paste0("function (instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(col==1 && (row>=0 && row<=3)) {td.style.background = '",pal[1], "';}
if(col==1 && (row>=4 && row<=7)) {td.style.background = '",pal[2], "';}
if(col==1 && (row>=8 && row<=14)) {td.style.background = '",pal[3], "';}
if(col==2 && (row==0||row==1||row==4||row==5||row==8||row==9||row==12||row==13))
{td.style.background = 'lightgrey';}
if(col==3 && (row==0||row==2||row==4||row==6||row==8||row==10||row==12))
{td.style.background = 'lightgrey';}
}")
} else if (n == 3){
df <- data.frame(Sample.name= paste0("Sample ",as.character(1:16)),
Condition = c(rep( "A", 8), rep("B", 8)),
Bio.Rep = as.integer(c(rep(1,4),rep(2,4),rep(3,4),rep(4,4))),
Tech.Rep = as.integer(c(1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8)),
Analyt.Rep = c(1:16),
stringsAsFactors = FALSE)
pal <- RColorBrewer::brewer.pal(3,listBrewerPalettes[1])[1:2]
color_rend <- paste0("function (instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(col==1 && (row>=0 && row<=7)) {td.style.background = '",pal[1], "';}
if(col==1 && (row>=8 && row<=15)) {td.style.background = '",pal[2], "';}
if(col==2 && (row==0||row==1||row==2||row==3||row==8||row==9||row==10||row==11))
{td.style.background = 'lightgrey';}
if(col==3 && (row==0||row==1||row==4||row==5|| row==8||row==9||row==12||row==13))
{td.style.background = 'lightgrey';}
if(col==4 && (row==0||row==2||row==4||row==6|| row==8||row==10||row==12||row==14))
{td.style.background = 'lightgrey';}
}")
}
rhandsontable::rhandsontable(df,rowHeaders=NULL,fillHandle = list(direction='vertical', autoInsertRow=FALSE,
maxRows=nrow(rv$hot))) %>%
rhandsontable::hot_rows(rowHeights = 30) %>%
rhandsontable::hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE,
allowInsertRow = FALSE,allowInsertColumn = FALSE,
allowRemoveRow = FALSE,allowRemoveColumn = FALSE,
autoInsertRow=FALSE ) %>%
rhandsontable::hot_cols(readOnly = TRUE,renderer = color_rend)
})
}
moduleDetQuantImpValues <- function(input, output, session, quant,factor) {
output$detQuantValues_DT <- renderDataTable(server=TRUE,{
req(rv$current.obj, quant(), factor())
values <- getQuantile4Imp(Biobase::exprs(rv$current.obj), quant()/100, factor())
DT::datatable(as.data.frame(t(values$shiftedImpVal)),
rownames = FALSE,
options = list(initComplete = initComplete(),
dom = 't',
bLengthChange = FALSE))
})
}
modulePopover <- function(input, output, session, data){
ns <- session$ns
output$customPopover <- renderUI({
req(data())
div(
div(
# edit1
style="display:inline-block; vertical-align: middle; padding-bottom: 5px;",
data()$title
),
div(
# edit2
style="display:inline-block; vertical-align: middle;padding-bottom: 5px;",
if (!is.null(data()$color) && ('white' == data()$color)) {
tags$button(id=ns("q1"), tags$sup("[?]"), class="Prostar_tooltip_white")
} else {
tags$button(id=ns("q1"), tags$sup("[?]"), class="Prostar_tooltip")
},
shinyBS::bsPopover(id = ns("q1"), title = "",
content = data()$content,
placement = "right",
trigger = "hover",
options = list(container = "body")
)
)
)
})
}
#------------------------------------------------------------
moduleLegendColoredExprs <- function(input, output, session){}
#------------------------------------------------------------
moduleVolcanoplot <- function(input, output, session, data, comp, tooltip, isSwaped){
ns <- session$ns
observeEvent(data(), {
print('############ NEW DATA on rv$resAnaDiff')
})
output$quantiDT <- renderUI({
req(input$eventPointClicked)
if (is.null(rv$matAdj)){
shinyBS::bsCollapse(id = ns("collapseVolcanoInfos"), open = "Protein",multiple = TRUE,
shinyBS::bsCollapsePanel("Protein", tagList(
uiOutput(ns("Warning_Infos")),
DT::dataTableOutput(ns("Infos"))),style = "info"))
} else {
shinyBS::bsCollapse(id = ns("collapseVolcanoInfos"), open = "Protein",multiple = TRUE,
shinyBS::bsCollapsePanel("Protein", tagList(
uiOutput(ns("Warning_Infos")),
DT::dataTableOutput(ns("Infos"))),style = "info"),
shinyBS::bsCollapsePanel("Specific peptides",tagList(
uiOutput(ns("Warning_specificPeptidesInfos")),
DT::dataTableOutput(ns("specificPeptidesInfos"))), style = "primary"),
shinyBS::bsCollapsePanel("Shared peptides", tagList(
uiOutput(ns("Warning_sharedPeptidesInfos")),
DT::dataTableOutput(ns("sharedPeptidesInfos"))), style = "primary"))
}
})
output$nbSelectedItems <- renderUI({
rv$widgets$anaDiff$th_pval
rv$widgets$hypothesisTest$th_logFC
rv$current.obj
data()
if(is.null(data()$logFC) || is.null(data()$P_Value)){return(NULL)}
if (length(which(is.na(Biobase::exprs(rv$current.obj)))) > 0) {return(NULL)}
p <- NULL
p <- data()
upItemsPVal <- NULL
upItemsLogFC <- NULL
upItemsLogFC <- which(abs(p$logFC) >= as.numeric(rv$widgets$hypothesisTest$th_logFC))
upItemsPVal <- which(-log10(p$P_Value) >= as.numeric(rv$widgets$anaDiff$th_pval)
)
rv$nbTotalAnaDiff <- nrow(Biobase::exprs(rv$current.obj))
rv$nbSelectedAnaDiff <- NULL
t <- NULL
if (!is.null(rv$widgets$anaDiff$th_pval
) && !is.null(rv$widgets$hypothesisTest$th_logFC) ) {
t <- intersect(upItemsPVal, upItemsLogFC)}
else if (!is.null(rv$widgets$anaDiff$th_pval
) && is.null(rv$widgets$hypothesisTest$th_logFC) ) {
t <- upItemsPVal}
else if (is.null(rv$widgets$anaDiff$th_pval
) && !is.null(rv$widgets$hypothesisTest$th_logFC) ) {
t <- upItemsLogFC}
rv$nbSelectedAnaDiff <- length(t)
txt <- paste("Total number of ",rv$typeOfDataset, "(s) = ",
rv$nbTotalAnaDiff,"<br>",
"Number of selected ",rv$typeOfDataset, "(s) = ",
rv$nbSelectedAnaDiff,"<br>",
"Number of non selected ",rv$typeOfDataset, "(s) = ",
(rv$nbTotalAnaDiff -rv$nbSelectedAnaDiff), sep="")
HTML(txt)
})
GetSortingIndices <- reactive({
req(comp())
condition1 = strsplit(comp(), "_vs_")[[1]][1]
condition2 = strsplit(comp(), "_vs_")[[1]][2]
if (length(grep("all",condition2))==0) {
ind <- c( which(pData(rv$current.obj)$Condition==condition1),
which(pData(rv$current.obj)$Condition==condition2))
} else {
ind <- c( which(pData(rv$current.obj)$Condition==condition1),
c(1:nrow(pData(rv$current.obj)))[-(which(pData(rv$current.obj)$Condition==condition1))])
}
ind
})
GetBorderIndices <- reactive({
conds <- (pData(rv$current.obj)$Condition)[GetSortingIndices()]
## build index for border-formatting
borders_index <- unlist(lapply(unique(conds), function(x){which.max(x== conds)}))
borders_index
})
output$Warning_sharedPeptidesInfos <- renderUI({
GetDataFor_sharedPeptidesInfos()
if (nrow(GetDataFor_sharedPeptidesInfos())>153)
p(MSG_WARNING_SIZE_DT)
})
GetDataFor_sharedPeptidesInfos <- reactive({
#req(rv$current.obj)
req(comp())
#req(rv$matAdj)
ind <- GetSortingIndices()
borders_index <- GetBorderIndices()
prev.dataset <- rv$dataset[[names(rv$dataset)[last(grep(pattern='peptide', names(rv$dataset)))]]]
prot <- GetExprsClickedProtein()
prot.indice <- rownames(prot)
#print(prot.indice)
data <- getDataForExprs(prev.dataset)
data <- data[,c(ind, (ind + ncol(data)/2))]
Xspec <- rv$matAdj$matWithUniquePeptides
Xshared <- rv$matAdj$matWithSharedPeptides
i <- which(colnames(Xspec)==prot.indice)
specificPeptidesIndices <- which(Xspec[,i]==1)
allPeptidesIndices <- which(Xshared[,i]==1)
peptidesIndices <- setdiff(allPeptidesIndices, specificPeptidesIndices)
data <- data[peptidesIndices,]
data
})
output$sharedPeptidesInfos <- renderDataTable(server=TRUE,{
data <- GetDataFor_sharedPeptidesInfos()
dt <- DT::datatable(data,
#colnames=NULL,
extensions = c('Scroller', 'Buttons'),
options = list(initComplete = initComplete(),
buttons = list('copy',
list(
extend = 'csv',
filename = 'sharedPeptidesInfos'
),'print'),
dom='Bfrtip',
blengthChange = FALSE,
displayLength = 20,
ordering=FALSE,
server = FALSE,
columnDefs = list(list(targets = c(((ncol(data)/2)+1):(ncol(data))), visible = FALSE))
)) %>%
formatStyle(
colnames(data)[1:(ncol(data)/2)],
colnames(data)[((ncol(data)/2)+1):(ncol(data))],
backgroundColor = styleEqual(c("POV", "MEC"), c(rv$colorsTypeMV$POV, rv$colorsTypeMV$MEC))
) %>%
formatStyle(borders_index, borderLeft = '3px solid #000000')
dt
})
output$Warning_specificPeptidesInfos <- renderUI({
GetDataFor_specificPeptidesInfos()
if (nrow(GetDataFor_specificPeptidesInfos())>153)
p(MSG_WARNING_SIZE_DT)
})
GetDataFor_specificPeptidesInfos <- reactive({
#req(rv$current.obj)
req(comp())
#req(rv$matAdj)
ind <- GetSortingIndices()
borders_index <- GetBorderIndices()
prev.dataset <- rv$dataset[[names(rv$dataset)[last(grep(pattern='peptide', names(rv$dataset)))]]]
prot <- GetExprsClickedProtein()
prot.indice <- rownames(prot)
data <- getDataForExprs(prev.dataset)
data <- data[,c(ind, (ind + ncol(data)/2))]
Xspec <- rv$matAdj$matWithUniquePeptides
i <- which(colnames(Xspec)==prot.indice)
peptidesIndices <- which(Xspec[,i]==1)
data <- data[peptidesIndices,]
data
})
output$specificPeptidesInfos <- renderDataTable(server=TRUE,{
data <- GetDataFor_specificPeptidesInfos()
dt <- DT::datatable( data,
#colnames=NULL,
extensions = c('Scroller', 'Buttons'),
options = list(initComplete = initComplete(),
buttons = list('copy',
list(
extend = 'csv',
filename = 'specific peptides infos'
),'print'),
dom='Bfrtip',
blengthChange = FALSE,
displayLength = 20,
ordering=FALSE,
columnDefs = list(list(targets = c(((ncol(data)/2)+1):(ncol(data))), visible = FALSE))
)) %>%
formatStyle(
colnames(data)[1:(ncol(data)/2)],
colnames(data)[((ncol(data)/2)+1):(ncol(data))],
backgroundColor = styleEqual(c("POV", "MEC"), c(rv$colorsTypeMV$POV, rv$colorsTypeMV$MEC))
) %>%
formatStyle(borders_index, borderLeft = '3px solid #000000')
dt
})
##------------------------------------------------------------------------------
GetExprsClickedProtein <- reactive({
req(rv$current.obj)
req(comp())
req(input$eventPointClicked)
rv$widgets$hypothesisTest$th_logFC
rv$widgets$anaDiff$th_pval
data()
ind <- GetSortingIndices()
this.index <- as.integer(strsplit(input$eventPointClicked, "_")[[1]][1])
this.series.name <- strsplit(input$eventPointClicked, "_")[[1]][2]
data <- getDataForExprs(rv$current.obj)
data <- data[,c(ind, (ind + ncol(data)/2))]
index.g1 <- which((-log10(data()$P_Value) >= rv$widgets$anaDiff$th_pval
) & (abs(data()$logFC) >= as.numeric(rv$widgets$hypothesisTest$th_logFC)))
data.g1 <- data[index.g1,]
data.g2 <- data[-index.g1,]
switch (this.series.name,
g1=data <- data.g1[this.index+1,],
g2 = data <- data.g2[this.index+1,]
)
data
})
output$Warning_Infos <- renderUI({
GetDataFor_Infos()
if (nrow(GetDataFor_Infos())>153)
p(MSG_WARNING_SIZE_DT)
})
GetDataFor_Infos <- reactive({
req(comp())
data <- GetExprsClickedProtein()
data
})
##------------------------------------------------------------------------------
output$Infos <- renderDataTable(server=TRUE,{
req(comp())
borders_index <- GetBorderIndices()
data <- GetExprsClickedProtein()
dt <- DT::datatable(data,
extensions = c('Scroller', 'Buttons'),
options = list(initComplete = initComplete(),
buttons = list('copy',
list(
extend = 'csv',
filename = 'Infos'
),'print'),
dom='Bfrtip',
blengthChange = FALSE,
displayLength = 20,
ordering=FALSE,
header=FALSE,
columnDefs = list(list(targets = c(((ncol(data)/2)+1):(ncol(data))), visible = FALSE))
)) %>%
formatStyle(
colnames(data)[1:(ncol(data)/2)],
colnames(data)[((ncol(data)/2)+1):(ncol(data))],
backgroundColor = styleEqual(c("POV", "MEC"), c(rv$colorsTypeMV$POV, rv$colorsTypeMV$MEC))) %>%
formatStyle(borders_index, borderLeft = '3px solid #000000')
dt
})
##---------------------------------------------------------------------
output$volcanoPlot <- renderHighchart({
rv$widgets$anaDiff$th_pval
rv$widgets$hypothesisTest$th_logFC
rv$colorsVolcanoplot
data()$P_Value
#data()$logFC
tooltip()
isSwaped()
isolate({
#if (is.null(rv$widgets$hypothesisTest$th_logFC) || is.na(rv$widgets$hypothesisTest$th_logFC) ){return()}
if ((length(data()$logFC) == 0) ){return()}
withProgress(message = 'Building plot...',detail = '', value = 0, {
if (length(which(is.na(Biobase::exprs(rv$current.obj)))) > 0) { return()}
df <- data.frame(x=data()$logFC,
y = -log10(data()$P_Value),
index = 1:nrow(fData(rv$current.obj)))
if (length( tooltip()) > 0){
df <- cbind(df,fData(rv$current.obj)[ tooltip()])
}
colnames(df) <- gsub(".", "_", colnames(df), fixed=TRUE)
if (ncol(df) > 3){
colnames(df)[4:ncol(df)] <-
paste("tooltip_", colnames(df)[4:ncol(df)], sep="")
}
clickFun <-
JS(paste0("function(event) {Shiny.onInputChange('",ns("eventPointClicked"),"', [this.index]+'_'+ [this.series.name]);}"))
cond <- c(data()$condition1, data()$condition2)
rv$tempplot$volcano <- diffAnaVolcanoplot_rCharts(df,
threshold_logFC = as.numeric(rv$widgets$hypothesisTest$th_logFC),
threshold_pVal = as.numeric(rv$widgets$anaDiff$th_pval),
conditions = cond,
clickFunction=clickFun,
palette = rv$colorsVolcanoplot,
swap = isSwaped()
)
})
rv$tempplot$volcano
})
})
}
#------------------------------------------------------------
#------------------------------------------------------------
moduleDensityplot <- function(input, output, session, data) {
#outputOptions(output, 'Densityplot', suspendWhenHidden=FALSE)
output$Densityplot <- renderHighchart({
#req(rv$current.obj)
data()
print("data() in densityPlot module")
print(data())
print(GetCurrentObjName())
rv$PlotParams$paletteConditions
rv$PlotParams$legendForSamples
tmp <- NULL
isolate({
withProgress(message = 'Making plot', value = 100, {
pattern <- paste0(GetCurrentObjName(),".densityplot")
tmp <- DAPAR::densityPlotD_HC(data(),
rv$PlotParams$legendForSamples,
rv$PlotParams$paletteConditions)
future(createPNGFromWidget(rv$tempplot$boxplot,pattern))
})
})
tmp
})
}
#------------------------------------------------------------
moduleBoxplot <- function(input, output, session, data) {
observeEvent(input$choosePlot, {
switch(input$choosePlot,
boxplot={
shinyjs::hide('viewViolinPlot')
shinyjs::show('BoxPlot')
},
violinplot={
shinyjs::hide('BoxPlot')
shinyjs::show('viewViolinPlot')
}
)
})
output$BoxPlot <- renderHighchart({
#req(rv$current.obj)
data()
rv$current.obj.name
rv$PlotParams$paletteConditions
rv$PlotParams$legendForSamples
tmp <- NULL
isolate({
pattern <- paste0(GetCurrentObjName(),".boxplot")
print(paste0("palette for boxplot : ",rv$PlotParams$paletteConditions) )
print(ncol(exprs(data())))
print(str(exprs(data())))
tmp <- boxPlotD_HC(data(),
rv$PlotParams$legendForSamples,
palette=rv$PlotParams$paletteConditions)
#future(createPNGFromWidget(tmp,pattern))
})
tmp
})
output$viewViolinPlot<- renderImage({
#req(rv$current.obj)
data()
rv$PlotParams$legendForSamples
rv$PlotParams$paletteConditions
tmp <- NULL
isolate({
# A temp file to save the output. It will be deleted after renderImage
# sends it, because deleteFile=TRUE.
outfile <- tempfile(fileext='.png')
# Generate a png
# png(outfile, width = 640, height = 480, units = "px")
png(outfile)
pattern <- paste0(GetCurrentObjName(),".violinplot")
tmp <- DAPAR::violinPlotD(data(), rv$PlotParams$legendForSamples, palette=rv$PlotParams$paletteConditions)
#future(createPNGFromWidget(tmp,pattern))
dev.off()
})
# Return a list
list(src = outfile,
alt = "This is alternate text")
}, deleteFile = TRUE)
}
moduleMVPlots <- function(input, output, session, data, title, palette) {
output$plot_viewNAbyMean <- renderHighchart({
req(data())
wrapper.hc_mvTypePlot2(obj=data(), title=title(), palette = palette())
})
output$WarnForImageNA <- renderUI({
tryCatch(
{
wrapper.mvImage(data())
},
warning = function(w) { p(conditionMessage(w))},
error = function(e) {p(conditionMessage(e))},
finally = {
#cleanup-code
})
})
output$plot_showImageNA <- renderImage({
#req(wrapper.mvImage(data()))
# A temp file to save the output. It will be deleted after renderImage
# sends it, because deleteFile=TRUE.
outfile <- tempfile(fileext='.png')
png(outfile)
wrapper.mvImage(data())
dev.off()
# Return a list
list(src = outfile,
alt = "This is alternate text")
}, deleteFile = TRUE)
}
moduleFilterStringbasedOptions <- function(input, output, session) {
output$FilterStringbasedOptions <- renderUI({
rv$current.obj
if (is.null(rv$current.obj)){return()}
tagList(
h4("String based filtering options")
,hr()
,h4("Filter contaminants"),
uiOutput("id_Contaminants"),
uiOutput("choosePrefixContaminants"),
br(),
h4("Filter reverse"),
uiOutput("id_Reverse"),
uiOutput("choosePrefixReverse"),
br(),
#actionButton("resetFilterParamsButton","Reset parameters"),
actionButton("performFilteringContaminants",
"Perform string-based filtering", class = actionBtnClass)
)
})
}
moduleStaticDataTable <- function(input, output, session,table2show, withBtns, showRownames=FALSE, dom='Bt', filename='Prostar_export') {
proxy = dataTableProxy(session$ns('StaticDataTable'), session)
observe({replaceData(proxy, table2show(), resetPaging = FALSE) })
output$warningOnSize <- renderUI({
if (length(table2show())==0){return(NULL)}
if (nrow(table2show())>153)
p(MSG_WARNING_SIZE_DT)
})
output$StaticDataTable <- DT::renderDataTable(server=TRUE,{
req(rv$current.obj)
#table2show
if (length(table2show())==0){return(NULL)}
print(table2show())
isolate({
DT::datatable(table2show(),
extensions = 'Buttons',
escape = FALSE,
# rownames= showRownames,
options=list(
buttons = list(
list(
extend = 'csv',
filename = filename
),
list(
extend = 'pdf',
filename = filename
),'print'),
#initComplete = initComplete(),
dom = dom
# server = FALSE,
# autoWidth=TRUE,
#columnDefs = list(list(width='150px',targets= "_all")),
#ordering = FALSE
)
)
})
})
}
moduleInsertMarkdown <- function(input, output, session,url){
ns <- session$ns
output$insertMD <- renderUI({
print(url)
tryCatch(
{
includeMarkdown(url)
}
, warning = function(w) {
#conditionMessage(w)
tags$p("URL not found. Please check your internet connection.")
#shinyjs::info(paste("URL not found",":",conditionMessage(w), sep=" "))
}, error = function(e) {
shinyjs::info(paste("Error :","in moduleInsertMarkdown",":", conditionMessage(e), sep=" "))
}, finally = {
#cleanup-code
})
})
}
Try the Prostar package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.