Commit f8b4be8e authored by Jean-Karim Heriche's avatar Jean-Karim Heriche

Working prototype including opening of image upon data point selection in plot.

parent f97b8faa
library(DT) ## R interface to the js DataTables library
library(EBImage) ## already has shiny integration functions
library(shiny)
library(shinyFiles)
library(shinyFiles) ## File and directory selectors
# library(shinycssloaders) ## Loading/busy animations
library(ggplot2)
library(plotly)
ui <- fluidPage(
......@@ -51,13 +54,19 @@ ui <- fluidPage(
tags$hr(style="border-top: 1px solid #000000;"),
## Select image root directory
shinyDirButton('dir',
label='Select image root dir',
title=''),
tags$br(),tags$br(),
"Selected image directory:",
tags$br(),
verbatimTextOutput('imageDir')
tags$div(style = "line-height: 2",
tags$b("Select image root dir"),
shinyDirButton('dir',
label='Browse...',
title=''),
tags$br(),
"Selected image directory:",
tags$br(),
verbatimTextOutput('imageDir')
),
## Select column containing image file names
uiOutput("fileColumn")
),
......@@ -67,10 +76,20 @@ ui <- fluidPage(
fluidRow(
column(9,
h3('Plot'),
plotOutput('plot', height = 500),
verbatimTextOutput('x4')
fluidRow(
h3('Plot'),
#withSpinner(
plotlyOutput('plot', height = 500, width = '100%')
# plotOutput('plot', height = 500,
# click = "plot_click",
# brush = brushOpts(id = "plot_brush", resetOnNew = TRUE),
# dblclick = "plot_dblclick"),
),
fluidRow(
verbatimTextOutput("hover"),
verbatimTextOutput("test")
)
)
),
fluidRow(
column(9,
......@@ -78,104 +97,193 @@ ui <- fluidPage(
tabPanel(
## Output : Data file
h3('Data'),
DTOutput("content")
DTOutput("dataTable")
),
tabPanel(
h3('Image'),
displayOutput("widget")
displayOutput("imageViewer")
)
)
)
)
)
)
)
server <- function(input, output) {
server <- function(input, output, session) {
## Increase max upload size to 500 MB
options(shiny.maxRequestSize=500*1024^2)
## Increase max upload size to 30 MB
options(shiny.maxRequestSize=30*1024^2)
roots = c(home = "~", wd='.')
# Select image root directory
roots = c(home = "~", wd = '.', tier2 = '/g/tier2')
shinyDirChoose(input, 'dir', roots = roots)
output$imageDir <- renderText({
dirInfo <- parseDirPath(roots, input$dir)
})
data <- reactive({
rv <- reactiveValues(data = NULL, currentRows = NULL, imgPath = NULL)
# Read uploaded data file
observeEvent(input$datafile, {
if (is.null(input$datafile)) return(NULL)
## After the user selects and uploads a data file,
## the content of the data file will be shown.
req(input$datafile)
## When reading semicolon separated files,
## having a comma separator causes `read.csv` to error
tryCatch(
{
df <- read.csv(input$datafile$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
},
error = function(e) {
## return a safeError if a parsing error occurs
stop(safeError(e))
}
)
return(df)
if (is.null(input$datafile)) return(NULL)
## After the user selects and uploads a data file,
## the content of the data file will be shown.
req(input$datafile) ## Proceed only if file selected
## When reading semicolon separated files,
## having a comma separator causes `read.csv` to error
tryCatch(
{
rv$data <- read.csv(input$datafile$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
rv$currentRows <- c(1:nrow(rv$data))
},
error = function(e) {
## Return a safeError if a parsing error occurs
stop(safeError(e))
}
)
rv
})
## Dynamically generate UI input when data is uploaded
observe({
df <- rv$data
## Get indices of data points in selected area (Box and Lasso Select tool)
brush <- event_data("plotly_selected")
if(!is.null(brush)) {
rv$currentRows <- brush$pointNumber +1
}
## Get indices of data points in zoomed-in/out area
zoom <- event_data("plotly_relayout")
if(!is.null(zoom) ) {
## Take care of cases where range is on one axis only
if (!is.null(zoom[['xaxis.range[0]']])) {
if(!is.null(zoom[['yaxis.range[0]']])) {
rv$currentRows <- which(df[, input$selectedVar[1]] >= zoom[['xaxis.range[0]']] &
df[, input$selectedVar[1]] <= zoom[['xaxis.range[1]']] &
df[, input$selectedVar[2]] >= zoom[['yaxis.range[0]']] &
df[, input$selectedVar[2]] <= zoom[['yaxis.range[1]']], arr.ind = TRUE)
} else {
rv$currentRows <- which(df[, input$selectedVar[1]] >= zoom[['xaxis.range[0]']] &
df[, input$selectedVar[1]] <= zoom[['xaxis.range[1]']] , arr.ind = TRUE)
}
} else if(!is.null(zoom[['yaxis.range[0]']])) {
rv$currentRows <- which(df[, input$selectedVar[2]] >= zoom[['yaxis.range[0]']] &
df[, input$selectedVar[2]] <= zoom[['yaxis.range[1]']] , arr.ind = TRUE)
}
else {
rv$currentRows <- c(1:nrow(rv$data))
}
}
rv$currentRows
})
## Show the data table
output$dataTable <- renderDT(rv$data[rv$currentRows,],
extensions = c('FixedHeader'),
options = list(displayModeBar = TRUE, fixedHeader = TRUE),
server = TRUE)
## Dynamically generate UI input to select variables once data is uploaded and read
output$variables <- renderUI({
checkboxGroupInput(inputId = "selectedVar",
label = "Variables to plot",
choices = names(data()))
selectizeInput(inputId = "selectedVar",
label = "Variables to plot",
multiple = TRUE,
choices = names(rv$data),
options = list(maxItems = 2))
})
output$content <- renderDT(data(), server = TRUE)
## Highlight selected rows in the plot
output$plot = renderPlot({
selectedRows <- input$content_rows_selected
## Select column containing image file names as paths relative to image dir
output$fileColumn <- renderUI({
colNames <- names(rv$data)
## Try to infer from name and set as default
found <- grepl("image|file|path", colNames, ignore.case = TRUE)
selection <- NULL
if(any(found)) {
selection <- colNames[found]
}
selectizeInput(inputId = "fileCol",
label = "Column containing image file names",
multiple = TRUE,
selected = selection,
choices = colNames,
options = list(maxItems = 1))
})
## Plot
output$plot <- renderPlotly({
selectedRows <- input$dataTable_rows_selected
selectedCols <- input$selectedVar
par(mar = c(4, 4, 1, .1))
D <- data()
D <- rv$data[rv$currentRows,]
IDs <- rownames(D) # Used to uniquely identify data points
D <- cbind(D, IDs)
## Limit selection to two columns otherwise we get a scatterplot matrix
if (length(selectedCols) == 2) {
plot(D[,selectedCols])
}
if (length(selectedRows)) {
points(D[selectedRows, selectedCols], pch = 19, cex = 1, col = "red")
p <- ggplot(data = D, aes_string(x = selectedCols[1], y = selectedCols[2], key = "IDs")) +
labs(x = eval(selectedCols[1]), y = eval(selectedCols[2])) +
geom_point(colour = "black") +
geom_point(data = D[selectedRows,],
aes_string(x = selectedCols[1], y = selectedCols[2], key = "IDs"),
colour = "red") +
coord_cartesian(expand = TRUE)
ggplotly(p, tooltip = "none") %>%
config(p = ., staticPlot = FALSE, doubleClick = "reset+autosize", displayModeBar = TRUE, workspace = TRUE, sendData = FALSE, displaylogo = FALSE,
modeBarButtonsToRemove = list("sendDataToCloud", "lasso2d", "select2d", "hoverCompareCartesian")) ## Control Plotly's tool bar
}
})
output$x4 = renderPrint({
s = input$selectedVar
if (length(s)) {
cat('These variables were selected:\n\n')
cat(s, sep = ', ')
}
})
image.file <- '/home/heriche/canonical_mitotic_cell.png'
## Show values for data point close to cursor
## We don't want to use Plotly's tool tip because it obscures data points
output$hover <- renderPrint({
hover <- event_data("plotly_hover")
if(is.null(hover)) NULL else cat(unlist(hover$key), " : ", paste(rv$data[unlist(hover$key),input$selectedVar]))
})
## Get image associated with selected data point
observe({
click <- event_data("plotly_click")
if(!is.null(click)) {
rv$imgPath <- as.character(rv$data[unlist(click$key),input$fileCol])
}
})
## Read image corresponding to clicked data point
img <- reactive({
readImage(image.file)
## Deal with eventual Windows-style paths
if(!is.null(input$dir)) {
rootDir <- file.path(strsplit(parseDirPath(roots, input$dir),'\\\\'))
}
if(!is.null(rv$imgPath)){
filePath <- file.path(rootDir, strsplit(rv$imgPath, '\\\\'))
readImage(filePath)
}
})
## Interactive image display with EBImage
output$widget <- renderDisplay({
output$imageViewer <- renderDisplay({
image <- img()
if(!is.null(image)) {
display(img(), method = 'browser')
}
})
## TODO
## Pixel coordinates of where the cursor is
}
## Run the application
shinyApp(ui = ui, server = server, options = list("port" = 4722))
## Supply desired port to runApp() because it ignores options in shinyApp()
shinyApp(ui = ui, server = server)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment