Commit 45e96f1a authored by Jean-Karim Heriche's avatar Jean-Karim Heriche

Implemented plate viewer with interactivity.

parent 086902cb
......@@ -301,7 +301,7 @@ input_data_server <- function(input, output, session) {
"colsToHide" = input$colsToHide, "groupLabels" = input$groupLabels, "roiX" = input$roiX,
"roiY" = input$roiY, "roiFrame" = input$roiFrame, "imgRoot" = rv$inputChoices[["imgRoot"]],
"fileCol1" = input$fileCol1, "fileCol2" = input$fileCol2, "plateCol" = input$plateCol,
"wellCol" = input$wellCol, "fieldCol" = inputfieldCol, "treatCol" = input$treatCol)
"wellCol" = input$wellCol, "fieldCol" = input$fieldCol, "treatCol" = input$treatCol)
saveRDS(settings, file)
}
)
......@@ -379,10 +379,10 @@ input_data_server <- function(input, output, session) {
type = "warning",
duration = NULL)
}
rv$data[,"id"] <- c(1:nrow(rv$data)) # Used to uniquely identify data points
rv$data[,"idx"] <- sample(c(1:nrow(rv$data))) # Used to reorder data points
rv$data[,"ide.id"] <- c(1:nrow(rv$data)) # Used to uniquely identify data points
rv$data[,"ide.idx"] <- sample(c(1:nrow(rv$data))) # Used to reorder data points
# These don't need to be visible to the user
rv$colsToHide <- c(rv$colsToHide, match("id", colnames(rv$data)), match("idx", colnames(rv$data)))
rv$colsToHide <- c(rv$colsToHide, match("ide.id", colnames(rv$data)), match("ide.idx", colnames(rv$data)))
rv$currentRows <- c(1:nrow(rv$data))
rv$datapath<- input$datafile$name
},
......@@ -409,6 +409,9 @@ input_data_server <- function(input, output, session) {
Save_Variable_rv("fileCol1")
Save_Variable_rv("fileCol2")
Save_Variable_rv("colsOnHover")
Save_Variable_rv("plateCol")
Save_Variable_rv("wellCol")
Save_Variable_rv("fieldCol")
# Columns to hide / edit
Columns_event <- function(type){
......@@ -420,7 +423,7 @@ input_data_server <- function(input, output, session) {
rv[[type]] <- match(input[[type]], colnames(rv$data))
if(type == "colsToHide"){
# These columns don't need to be visible to the user
rv[[type]] <- c(rv[[type]], match("id", colnames(rv$data)), match("idx", colnames(rv$data)))
rv[[type]] <- c(rv[[type]], match("ide.id", colnames(rv$data)), match("ide.idx", colnames(rv$data)))
}
})
}
......
......@@ -75,7 +75,7 @@ explore_server <- function(input, output, session, rv, react) {
callModule(explore_image_server2, "image2", rv)
# Get info on hovering a data point in the plot
callModule(plot_server, "explore_data", rv)
callModule(info_server, "explore_data", rv)
}
# Authors: Coralie Muller & Jean-Karim Heriche
#################################
## Module Explore : info table ##
#################################
##################################
## Module Explore : info tables ##
##################################
############# UI ###########
......@@ -28,4 +28,24 @@ ui_explore_info <- function(id) {
)
} # End ui_explore_info()
# Server is shared with explore_plot.R
info_server <- function(input, output, session, rv) {
ns <- session$ns # Allow to use ns()
# Info on hover
output$hover <- renderTable({
# TODO: Figure out which plot we're in
if(length(rv$selectedVar) > 0 && length(rv$selectedVar) <= 2) {
hover <- event_data("plotly_hover", source = "scatterPlot")
if(is.null(hover)) {
hover <- event_data("plotly_hover", source = "plateView")
}
df <- head(rv$data[,c(rv$selectedVar, rv$colsOnHover), drop = FALSE], n = 1)
df[,] <- NA
if(!is.null(hover)) {
df <- rv$data[unlist(hover$key), c(rv$selectedVar, rv$colsOnHover), drop = FALSE]
}
return(df)
}
})
}
\ No newline at end of file
......@@ -31,19 +31,63 @@ plate_view_server <- function(input, output, session, rv) {
updateSearch(rv$proxy, keywords = list(global = defaultSearch, columns = defaultSearchColumns))
})
}
output$plot <- renderPlotly({
output$plate_view <- renderPlotly({
req(rv$data)
# Extract plate data
plateData <- rv$data[rv$plateCol == rv$platePos[,1], ]
# Draw plate
ggplot(plateData, aes(y = factor(rown, rev(levels(rown))), x = factor(col))) +
geom_point(aes(colour = colorvar), size =18) + theme_bw() +
labs(x=NULL, y = NULL)
selectedPlate <- unique(rv$data[rv$selectedRows, rv$plateCol])
if(length(selectedPlate) != 1) { # No plate or more than one => don't draw
} else { # only one plate
# Extract plate data
plateData <- rv$data[rv$data[,rv$plateCol] == selectedPlate,]
# Try to figure out plate format/size
# Conventions:
# - Rows are along the shortest dimension, e.g. an 8x12 plate has 8 rows.
# - Rows are labelled with letters starting from A.
# - Columns are numbered starting from 1.
# - Well A1 represents the top left corner of the plate.
plate.sizes <- c(4, 6, 8, 12, 24, 48, 96, 384, 1536)
plate.formats <- list(
"4" = c(nb.rows = 2, nb.cols = 2),
"6" = c(nb.rows = 2, nb.cols = 3),
"8" = c(nb.rows = 2, nb.cols = 4),
"12" = c(nb.rows = 3, nb.cols = 4),
"24" = c(nb.rows = 4, nb.cols = 6),
"48" = c(nb.rows = 6, nb.cols = 8),
"96" = c(nb.rows = 8, nb.cols = 12),
"384" = c(nb.rows = 16, nb.cols = 24),
"1536" = c(nb.rows = 32, nb.cols = 48)
)
nb.wells <- length(unique(plateData[,rv$wellCol]))
plateSize <- min(plate.sizes[nb.wells/plate.sizes<=1])
validate(need(plateSize>=4 && plateSize<=1536, "Unrecognized plate size/format."))
nb.rows <- plate.formats[[as.character(plateSize)]]["nb.rows"]
row.labels <- c(LETTERS, "AA", "AB", "AC", "AD", "AE", "AF")[1:nb.rows]
nb.cols <- plate.formats[[as.character(plateSize)]]["nb.cols"]
col.labels <- 1:nb.cols
plateData <- cbind(plateData[, c("ide.id", rv$wellCol,rv$selectedVar[1]), drop = FALSE], rows = NA, cols = NA)
# Match well index to row/col coordinates
for(i in 1:nrow(plateData)) {
idx <- plateData[i, rv$wellCol]
plateData[i, "rows"] <- row.labels[((idx-1) %/% nb.cols)+1]
plateData[i, "cols"] <- ((idx-1) %% nb.cols)+1
}
plateData$rows <- factor(plateData$rows)
plateData$rows <- factor(plateData$rows, rev(levels(plateData$rows)))
plateData$cols <- factor(plateData$cols)
# Draw plate
# Make sure that well size is small enough to fit in the available space
plateView <- ggplot(plateData, aes(y = rows, x = cols, key = ide.id)) +
geom_point(aes_string(colour = rv$selectedVar[1]), size = 1536/(2*plateSize)) +
theme(legend.title = element_blank()) +
labs(x = NULL, y = NULL, title = NULL)
ggplotly(plateView, tooltip = "none", source = "plateView") %>% event_register("plotly_hover") %>%
config(p = ., staticPlot = FALSE, doubleClick = "reset+autosize", autosizable = TRUE, displayModeBar = TRUE,
sendData = FALSE, displaylogo = FALSE,
modeBarButtonsToRemove = c("sendDataToCloud", "hoverCompareCartesian", "select2d", "lasso2d")) %>% # Control Plotly's tool bar
toWebGL()
}
}) # End renderPlotly
### Interactions with the plate viewer
......@@ -52,30 +96,21 @@ plate_view_server <- function(input, output, session, rv) {
## This selects the corresponding row in the data table
observe({
req(rv$data)
isolate({
if(!is.null(rv$platePos) && !is.na(platePos[1])) {
df <- rv$data
updateFilters() # Don't lose search terms in the data table
rv$currentRows
click <- event_data("plotly_click", priority = "event", source = "plateView")
if(!is.null(click)) {
selectRows(rv$proxy, as.numeric(unlist(click$key))) # Set selected point in table
if(!is.null(rv$roiX) && rv$roiX != "" && !is.null(rv$roiY) && rv$roiY != ""){
rv$pixelPosition <- rv$data[unlist(click$key), c(rv$roiX, rv$roiY)]
}
})
}) # End Observe
# Info on hover
output$hover <- renderTable({
if(!is.null(rv$platePos) && !is.na(platePos[1])) {
hover <- event_data("plotly_hover")
df <- head(rv$data[,c(rv$selectedVar, rv$colsOnHover), drop = FALSE], n = 1)
df[,] <- NA
if(!is.null(hover)) {
df <- rv$data[unlist(hover$key), rv$colsOnHover, drop = FALSE]
}
return(df)
# Reset event to avoid triggering updates when switching workspaces
runjs("Shiny.setInputValue('plotly_click-plateView', null);")
}
}) # End renderTable
updateFilters() # Don't lose search terms in the data table
rv$currentRows
}) # End Observe
# Info on selection
output$info <- renderTable({
......
......@@ -9,14 +9,14 @@
############### UI ###############
ui_explore_plot <- function(id) {
ns <- NS(id)
tabPanel(
h4('Scatter plot'),
box( width = 12, align = "left",
title = "Plot", solidHeader = TRUE, status = "primary",
withSpinner(
plotlyOutput(ns("plot"), height = '500px'))
) # End box
)
tabPanel(
h4('Scatter plot'),
box( width = 12, align = "left",
title = "Plot", solidHeader = TRUE, status = "primary",
withSpinner(
plotlyOutput(ns("plot"), height = '500px'))
) # End box
)
} # End ui_explore_plot()
############### Server ###############
......@@ -34,7 +34,6 @@ plot_server <- function(input, output, session, rv) {
})
}
output$plot <- renderPlotly({
req(rv$data)
D <- rv$data[rv$currentRows,]
......@@ -44,15 +43,15 @@ plot_server <- function(input, output, session, rv) {
## but allow plotting only one variable
if(length(rv$selectedVar) == 1) {
selectedCols[2] <- rv$selectedVar
selectedCols[1] <- "idx"
selectedCols[1] <- "ide.idx"
## Reordering based on data table row order
nr <- length(rv$dataTable_rows_all)
D[rv$dataTable_rows_all[1:nr],"idx"] <- c(1:nr)
D[rv$dataTable_rows_all[1:nr],"ide.idx"] <- c(1:nr)
} else if(length(rv$selectedVar) == 2) {
selectedCols <- rv$selectedVar
}
if(length(selectedCols) > 0 && length(selectedCols) <= 2) {
p <- ggplot(data = D, aes_string(x = selectedCols[1], y = selectedCols[2], key = "id")) +
p <- ggplot(data = D, aes_string(x = selectedCols[1], y = selectedCols[2], key = "ide.id")) +
labs(x = eval(selectedCols[1]), y = eval(selectedCols[2])) +
geom_point(colour = "grey") +
coord_cartesian(expand = TRUE)
......@@ -62,9 +61,9 @@ plot_server <- function(input, output, session, rv) {
theme(plot.title = element_blank(), legend.title = element_blank())
}
p <- p + geom_point(data = D[rv$selectedRows,],
aes_string(x = selectedCols[1], y = selectedCols[2], key = "id"),
aes_string(x = selectedCols[1], y = selectedCols[2], key = "ide.id"),
colour = "black")
ggplotly(p, tooltip = "none") %>% layout(legend = list(orientation = "v", x = 1, y = 0.8)) %>%
ggplotly(p, tooltip = "none", source = "scatterPlot") %>% layout(legend = list(orientation = "v", x = 1, y = 0.8)) %>%
config(p = ., staticPlot = FALSE, doubleClick = "reset+autosize", autosizable = TRUE, displayModeBar = TRUE,
sendData = FALSE, displaylogo = FALSE,
modeBarButtonsToRemove = c("sendDataToCloud", "hoverCompareCartesian")) %>% # Control Plotly's tool bar
......@@ -79,14 +78,14 @@ plot_server <- function(input, output, session, rv) {
observe({
req(rv$data)
if(length(rv$selectedVar) > 0 && length(rv$selectedVar) <= 2) { # Ensure we have a plot
click <- event_data("plotly_click", priority = "event", source = "A")
click <- event_data("plotly_click", priority = "event", source = "scatterPlot")
if(!is.null(click)) {
selectRows(rv$proxy, as.numeric(unlist(click$key))) # Set selected point in table
if(!is.null(rv$roiX) && rv$roiX != "" && !is.null(rv$roiY) && rv$roiY != ""){
rv$pixelPosition <- rv$data[unlist(click$key), c(rv$roiX, rv$roiY)]
}
# Reset event to avoid triggering updates when switching workspaces
runjs("Shiny.setInputValue('plotly_click-A', null);")
runjs("Shiny.setInputValue('plotly_click-scatterPlot', null);")
}
}
})
......@@ -94,26 +93,13 @@ plot_server <- function(input, output, session, rv) {
observe({
req(rv$data)
if(length(rv$selectedVar) > 0 && length(rv$selectedVar) <= 2) { # Ensure we have a plot
brush <- event_data("plotly_selected", priority = "event", source = "A")
brush <- event_data("plotly_selected", priority = "event", source = "scatterPlot")
if(!is.null(brush)) {
selectRows(rv$proxy, as.numeric(unique(unlist(brush$key))))
rv$selectedRows <- as.numeric(unique(unlist(brush$key)))
# Reset event to avoid triggering updates when switching workspaces
runjs("Shiny.setInputValue('plotly_selected-A', null);")
}
}
})
# Info on hover
output$hover <- renderTable({
if(length(rv$selectedVar) > 0 && length(rv$selectedVar) <= 2) { # Ensure we have a plot
hover <- event_data("plotly_hover")
df <- head(rv$data[,c(rv$selectedVar, rv$colsOnHover), drop = FALSE], n = 1)
df[,] <- NA
if(!is.null(hover)) {
df <- rv$data[unlist(hover$key), c(rv$selectedVar, rv$colsOnHover), drop = FALSE]
runjs("Shiny.setInputValue('plotly_selected-scatterPlot', null);")
}
return(df)
}
})
......
......@@ -185,12 +185,5 @@ explore_table_server <- function(input, output, session, rv, react) {
updateFilters()
})
## Detect switching areas
observeEvent(react$update_key==1,{
updateFilters()
react$update_key <- NULL
rv$select_variable_DR <- NULL
})
return(rv)
}
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