Commit 7b02650b authored by biohentze's avatar biohentze

Colour points by group

parent ff56bd21
......@@ -61,7 +61,7 @@ ui <- dashboardPage(
## Custom CSS to:
## - Reduce white space around boxes
## - Chenge font size
## - Change postion of notification box
## - Change postion and size of notification box
tags$head(tags$style(HTML(
'[class*="col-lg-"],[class*="col-md-"],
[class*="col-sm-"],[class*="col-xs-"]{
......@@ -71,8 +71,9 @@ ui <- dashboardPage(
.main-sidebar { font-size: 20px; }
.shiny-notification {
position:fixed;
top: calc(25%);;
left: calc(25%);;
top: calc(50%);
left: calc(50%);
width: 22em;
}'
))),
......@@ -120,6 +121,11 @@ ui <- dashboardPage(
title = "Columns to edit", solidHeader = TRUE, status = "primary",
## Select columns to edit
uiOutput("columnsToEdit")
),
box( width = NULL,
title = "Groups", solidHeader = TRUE, status = "primary",
## Select variables to display
uiOutput("groupsColumn")
)
),
box( width = 3,
......@@ -146,7 +152,10 @@ ui <- dashboardPage(
uiOutput("roiY"),
uiOutput("roiFrame")
)
)
), # End first row
fluidRow(
) # End second row
),
tabItem(tabName = "explore",
fluidRow(
......@@ -245,7 +254,7 @@ server <- function(input, output, session) {
## Select variables for plotting
output$variables <- renderUI({
selectizeInput(inputId = "selectedVar",
label = "Select variables to plot",
label = "Select 2 variables to plot",
multiple = TRUE,
choices = names(rv$data),
options = list(maxItems = 2))
......@@ -254,7 +263,7 @@ server <- function(input, output, session) {
## Select columns to hide
output$columnsToHide <- renderUI({
selectizeInput(inputId = "colsToHide",
label = "Select columns to hide",
label = "These columns will not be displayed",
multiple = TRUE,
choices = names(rv$data))
})
......@@ -262,11 +271,20 @@ server <- function(input, output, session) {
## Select columns to edit
output$columnsToEdit <- renderUI({
selectizeInput(inputId = "colsToEdit",
label = "Select columns to edit",
label = "Cells in these columns can be modified",
multiple = TRUE,
choices = names(rv$data))
})
## Select column containing group labels
output$groupsColumn <- renderUI({
selectizeInput(inputId = "groupLabels",
label = "Select column containing group labels",
multiple = FALSE,
choices = c("",names(rv$data)),
options = list(maxItems = 1))
})
## Select columns containing ROI coordinates
output$roiX <- renderUI({
colNames <- names(rv$data)
......@@ -355,7 +373,7 @@ server <- function(input, output, session) {
})
rv <- reactiveValues(data = NULL, currentRows = NULL, selectedRows = NULL, imgPath1 = NULL, imgPath2 = NULL, pixelPosition = NULL,
rv <- reactiveValues(data = NULL, currentRows = NULL, selectedRows = NULL, clusters = NULL, imgPath1 = NULL, imgPath2 = NULL, pixelPosition = NULL,
selectedFrame = NULL, metadataImg1 = NULL, metadataImg2 = NULL, colsToHide = NULL, colsToEdit = NULL)
## Read uploaded data file
......@@ -405,6 +423,24 @@ server <- function(input, output, session) {
rv$colsToEdit <- match(input$colsToEdit, colnames(rv$data))
})
# Group labels
observeEvent(input$groupLabels, {
req(rv$data) ## Proceed only if file read
# Get index of column
# Note: indexing starts at 0 but if row names are present they are in column 0
# so we don't use -1 to get the actual column indices.
idx <- match(input$groupLabels, colnames(rv$data))
if(!is.null(idx) && !is.na(idx) && length(idx)>0) {
rv$clusters <- rv$data[,idx]
if(length(levels(factor(rv$clusters)))>9) {
showNotification("Not enough colours for more than 9 groups", type = "warning")
rv$clusters <- NULL
}
} else {
rv$clusters <- NULL
}
})
## Show the data table in the explorer (this one is not editable)
output$dataTable <- renderDT({
req(rv$data)
......@@ -455,6 +491,7 @@ server <- function(input, output, session) {
req(rv$data)
selectedCols <- input$selectedVar
D <- rv$data[rv$currentRows,]
clusters <- rv$clusters[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
......@@ -462,11 +499,15 @@ server <- function(input, output, session) {
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 = "grey") +
geom_point(data = D[rv$selectedRows,],
aes_string(x = selectedCols[1], y = selectedCols[2], key = "IDs"),
colour = "black") +
coord_cartesian(expand = TRUE)
ggplotly(p, tooltip = "none") %>%
if(!is.null(rv$clusters)) {
p <- p + geom_point(aes(colour = factor(clusters)), alpha = 0.3) +
scale_colour_brewer(palette = 'Set1') + theme(title=element_blank())
}
p <- p + geom_point(data = D[rv$selectedRows,],
aes_string(x = selectedCols[1], y = selectedCols[2], key = "IDs"),
colour = "black")
ggplotly(p, tooltip = "none") %>% 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", "lasso2d", "select2d", "hoverCompareCartesian")) # Control Plotly's tool bar
......@@ -564,6 +605,7 @@ server <- function(input, output, session) {
})
observeEvent(input$clearSelected, {
selectRows(proxy, list())
selectRows(proxy2, list())
rv$imgPath1 <- NULL
rv$ImgPath2 <- NULL
rv$pixelPosition <- NULL
......@@ -576,6 +618,11 @@ server <- function(input, output, session) {
updateFilters()
})
## Detect switching areas
observeEvent(input$menu,{
updateFilters()
})
## Read image(s) corresponding to selected data point
img1 <- reactive({
## Deal with eventual Windows-style paths
......@@ -746,6 +793,8 @@ server <- function(input, output, session) {
}, callback = DT::JS("$('div.dwnld').append($('#download1'));"), # works but generates warnings
server = TRUE) # Server side processing required for large data tables
proxy2 <- dataTableProxy('dataTableEdit')
observeEvent(input$dataTableEdit_cell_edit, {
rv$data <<- editData(rv$data, input$dataTableEdit_cell_edit, 'dataTableEdit')
})
......
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