picker
lets you zoom, pan, and pick points from a
scatter plot.
# install.packages("remotes")
::install_github("hms-dbmi/picker") remotes
library(shiny)
library(picker)
# load example data
load(system.file('extdata/pbmcs.rda', package = 'picker'))
# setup gradient scale legend
<- list(colorHigh = 'blue', colorLow = '#f5f5f5', high = round(max(exp)), low = min(exp))
scale_legend_props
<- list()
text_props
if (require(repel)) {
# repel labels
$label <- levels(labels)[as.numeric(label_coords$label)]
label_coords<- repel_text(label_coords, mar = rep(0, 4), fontsize = 16)
label_coords
# adjust text props to be the same
$getSize <- 16
text_props$getTextAnchor <- 'middle'
text_props$getAlignmentBaseline <- 'center'
text_props
else {
} message("See https://github.com/hms-dbmi/repel to install repel")
}
# get colors for gene expression
<- scales::rescale(exp, c(0, 1))
exp <- scales::seq_gradient_pal('#f5f5f5', 'blue')(exp)
expression_colors
# legend to show when grid is visible
= list(
grid_legend_items list(color = '#FF0000', label = '↑'),
list(color = '#0000FF', label = '↓'),
list(color = '#989898', label = 'p < .05'),
list(color = '#EAEAEA', label = 'p ≥ .05')
)
= shinyUI(fluidPage(
ui $head(tags$style(".picker {border: 1px solid #ddd; margin: 20px 0;}")),
tags::column(
shinywidth = 6,
pickerOutput('clusters', width = '100%', height = '400px'),
pickerOutput('expression', width = '100%', height = '400px'),
verbatimTextOutput('selected')
)
))
= function(input, output) {
server
# show selected output
$selected <- renderPrint({
output$clusters_selected_points
input
})
# coordinate views (zoom/pan)
<- picker_proxy('clusters')
clusters_proxy observeEvent(input$expression_view_state, {
update_picker(clusters_proxy, input$expression_view_state)
})
<- picker_proxy('expression')
expression_proxy observeEvent(input$clusters_view_state, {
update_picker(expression_proxy, input$clusters_view_state)
})
# change title between grid/scatterplot
observeEvent(input$clusters_show_grid, {
<- ifelse(input$clusters_show_grid, 'Δ CELLS', '')
title update_picker(clusters_proxy, title = title)
})
# render pickers
$clusters <- renderPicker(
outputpicker(
coords,
cluster_colors,
labels, label_coords = label_coords,
polygons = polygons,
text_props = text_props,
point_color_polygons = 'white',
grid_legend_items = grid_legend_items)
)
$expression <- renderPicker(
outputpicker(coords,
expression_colors,
labels,show_controls = FALSE,
scale_legend_props = scale_legend_props)
)
}
shinyApp(ui = ui, server = server, options = list(launch.browser = TRUE))