library(shiny)
library(shinyjs)
library(ggplot2)
library(plotly)
library(viridis)
library(shinydashboard)
ui <- dashboardPage(title="ScopeDashboard",
dashboardHeader(title = span("Scope Dashboard")),
dashboardSidebar(
# Buttons for modifying polygon gates. This will get more complicated
# with additional gate types. Change to conditional appearance of buttons?
# Or just grey out add/remove for other gate types?
actionButton(inputId = "edit", label = "Edit Points", style=BUTTON_STYLE),
actionButton(inputId = "add", label = "Add Points", style=BUTTON_STYLE),
actionButton(inputId = "remove", label = "Remove Points", style=BUTTON_STYLE),
actionButton(inputId = "done", label = "Done", style=BUTTON_STYLE),
# Name for saving/renaming gates. Should probably be replace with popup window?
textInput(inputId = "name_input", label = "Gate Name"),
# Buttons for loading/saving gates. In the future, change behavior to
# look in directory and load saved gates from file (if previously saved).
actionButton(inputId = "load", label = "Load", style=BUTTON_STYLE),
actionButton(inputId = "create", label = "Create", style=BUTTON_STYLE),
actionButton(inputId = "save", label = "Save", style=BUTTON_STYLE),
actionButton(inputId = "rename", label = "Rename", style=BUTTON_STYLE),
actionButton(inputId = "cancel", label = "Cancel", style=BUTTON_STYLE),
# Select which saved gate to load.
# Change this in the future to show entire table. Desired properties:
# 1) All gates shown, scrollable, 2) Click on/off to select/deselect,
# 3) Only allow one item to be selected at a time.
selectInput(inputId = "name_table", label = NULL, choices = c()
),
selectInput(
inputId = 'test_dfx',
label = "Choose X variable:",
choices = ~ mget(c(as.character(DF@parameters@data[,"name"])),
multiple = F,
selected = "FSC-A"
),
selectInput(
inputId = 'test_dfy',
label = "Choose Y variable:",
choices = ~ mget(c(as.character(DF@parameters@data[,"name"])),
multiple = F,
selected = "SSC-A"
),
## add file opener
fileInput("file1", "Choose FCS File", accept = ".fcs"),
checkboxInput("header", "Header", TRUE)
),
dashboardBody(
plotlyOutput("plot")
)
)
)
)
server <- function(input, output, session) {
# Reactive Polygon Control
react_poly <- reactiveValues()
react_poly$points <- data.frame(x=c(), y=c()) # Stores current XY coordinates for polygon
react_poly$edit_points <- data.frame(x=c(), y=c()) # Use this so we can cancel and go back to version before editing
react_poly$path <- "" # Stores path used to draw polygon (M/L/Z format)
react_poly$edit_path <- "" # Stores path used to draw polygon (M/L/Z format)
react_poly$gates <- list() # For storage and recall
react_poly$drawing <- FALSE # Are we currently drawing a new gate?
react_poly$editable <- FALSE # Is the current gate editable? (Draggable points when clicked to activate)
react_poly$static <- FALSE # Is the current gate static (FALSE means we're still clicking to add more points)
react_poly$adding <- FALSE # Are we currently adding points to the polygon?
react_poly$removing <- FALSE # Are we currently removing points to the polygon?
# Initialize Buttons
disable("edit")
disable("add")
disable("remove")
disable("done")
enable("load")
enable("create")
disable("save")
disable("rename")
disable("cancel")
# When edit button is clicked, the key change here is react_poly$editable <- TRUE
# Note that you need to click the polygon before it becomes editable/draggable.
# In the future, would be great if it could go straight to editable/draggable mode!
observeEvent(input$edit,{
disable("edit")
disable("add")
disable("remove")
enable("done")
disable("load")
disable("create")
disable("save")
disable("rename")
enable("cancel")
react_poly$editable <- TRUE
react_poly$edit_path <- react_poly$path # temp version allows cancel/undo
react_poly$edit_points <- react_poly$points # temp version allows cancel/undo
})
# Activate mode to add points to polygon
observeEvent(input$add, {
disable("edit")
disable("add")
disable("remove")
enable("done")
disable("load")
disable("create")
disable("save")
disable("rename")
enable("cancel")
react_poly$adding <- TRUE
react_poly$static <- FALSE # This is important to change drawing mode, allow border/nodes
react_poly$edit_path <- react_poly$path # temp version allows cancel/undo
react_poly$edit_points <- react_poly$points # temp version allows cancel/undo
})
# Activate mode to remove points from polygon
observeEvent(input$remove, {
disable("edit")
disable("add")
disable("remove")
enable("done")
disable("load")
disable("create")
disable("save")
disable("rename")
enable("cancel")
react_poly$removing <- TRUE
react_poly$static <- FALSE # This is important to change drawing mode, allow border/nodes
react_poly$edit_path <- react_poly$path # temp version allows cancel/undo
react_poly$edit_points <- react_poly$points # temp version allows cancel/undo
})
# Finalize changes made to polygon (instead of canceling and reverting to previous version).
# Would be nice if this could close the polygon while originally drawing it, but it
# doesn't currently do this.
observeEvent(input$done, {
enable("edit")
enable("add")
enable("remove")
disable("done")
enable("load")
enable("create")
enable("save")
enable("rename")
disable("cancel")
react_poly$static <- TRUE
react_poly$drawing <- FALSE
react_poly$editable <- FALSE
react_poly$adding <- FALSE
react_poly$removing <- FALSE
react_poly$points <- react_poly$edit_points # Accept changes made while editing
react_poly$path <- xy_to_path(react_poly$points) # Update the polygon path too
react_poly$path <- paste0(react_poly$path, " Z") # Fix polygon path to make it closed
})
# Switch to a previously saved gate
observeEvent(input$load, {
enable("edit")
enable("add")
enable("remove")
disable("done")
enable("load")
enable("create")
disable("save")
enable("rename")
disable("cancel")
react_poly$points <- react_poly$gates[[input$name_table]]$xy # Recall stored gate XY info
react_poly$path <- xy_to_path(react_poly$points) # Convert recalled XY to path
react_poly$path <- paste0(react_poly$path, " Z") # Fix path to make it closed
react_poly$static <- TRUE
react_poly$drawing <- FALSE
})
# Start drawing polygon gate
observeEvent(input$create, {
disable("edit")
disable("add")
disable("remove")
disable("done")
enable("load")
disable("create")
disable("save")
disable("rename")
enable("cancel")
react_poly$points <- data.frame(x=c(), y=c()) # Clear to start from scratch
react_poly$static <- FALSE
react_poly$drawing <- TRUE
})
# Save the currently displayed gate. Uses text input from text_input field "Gate Name"
observeEvent(input$save, {
# Should add an if/else with error message to prevent overwriting previous gates
# Should change this to a popup window in the future?
if (!is.null(input$name_input)) { # Don't do anything if no text is entered for gate name.
enable("edit")
enable("add")
enable("remove")
disable("done")
enable("load")
enable("create")
disable("save")
enable("rename")
disable("cancel")
# Store current XY coordinates in reactive list object
react_poly$gates[[input$name_input]] <- list(
xy=react_poly$points
)
# Update gate chooser list/table
updateSelectInput(session, "name_table", NULL, choices=names(react_poly$gates))
# Reset text input field
updateTextInput(session,"name_input", "Gate Name", value="")
}
})
# This currently behaves the same as "save." Change in the future?
observeEvent(input$rename, {
enable("edit")
enable("add")
enable("remove")
disable("done")
enable("load")
enable("create")
disable("save")
enable("rename")
disable("cancel")
# Code for renaming current gate - save with a new name
react_poly$gates[[input$name_input]] <- list(
xy=react_poly$points
)
updateSelectInput(session, "name_table", NULL, choices=names(react_poly$gates))
updateTextInput(session,"name_input", "Gate Name", value="")
})
# Use this to roll back gate updates if they haven't been saved yet.
# Different behaviors for drawing mode vs. add/remove points mode.
observeEvent(input$cancel, {
if (react_poly$drawing) {
disable("edit")
disable("add")
disable("remove")
disable("done")
enable("load")
enable("create")
disable("save")
disable("rename")
disable("cancel")
react_poly$points <- data.frame(x=c(), y=c())
} else {
enable("edit")
enable("add")
enable("remove")
disable("done")
enable("load")
enable("create")
enable("save")
enable("rename")
disable("cancel")
react_poly$static <- TRUE
react_poly$drawing <- FALSE
react_poly$editable <- FALSE
react_poly$adding <- FALSE
react_poly$removing <- FALSE
}
})
output$plot <- renderPlotly({
# Dataset for testing
##Change x and/ or y to cell pop of interest
# First plot the data that will be gated.
file.name <- input$file1
## ----ReadFiles3, echo=TRUE, results='markup'----------------------------------
DF <- read.FCS(file.name$datapath, column.pattern="-A")
test_dfx <- reactive({data.frame(DF@exprs)})
test_dfy <- reactive({data.frame(DF@exprs)})
## Create new input
fig <- plot_ly(x= ~ get(input$test_dfx), y= ~ get(input$test_dfy), nbinsx=NBINS, nbinsy=NBINS,
colorscale=list(seq(0,1, length.out=length(pal)), pal),
type=PLOT_TYPE, zmin=ZMIN, zmax=ZMAX, hoverinfo="none",
text = ~ paste(
"<br> Count :",
get(input$test_dfx),
"<br> Count :",
get(input$test_dfy)
),
hoverinfo = "text",
height = 470
)%>%
layout(showlegend = TRUE,
title = paste("Something per year"),
xaxis = list(
title = input$test_dfx,
yaxis = list(
title =input$test_dfy
),
legend = c()
)
)
# Only plot the polygon if it has points. Could get errors otherwise?
if (nrow(react_poly$points) > 0) {
# If the gate is static (not currently editable), draw shape with layout method.
# This allows it to be editable, which is important for dragging polygon points!
# This mode also allows different colors for outline and fill color.
# Could draw two objects for filled polygon and outlet to get better control,
# but I haven't figured out how to do this without messing up transition to
# editable mode
if (react_poly$static) {
# Add polygon to the figure
fig <- layout(fig, shapes=list(
# Can't figure out how to add points/dots! They're present in editable
# mode, but not when unclicked. This might be inchangeable plotly behavior. . .
# Use fill/outline color to indicate swapping between editable/static modes.
list(type='path', editable=react_poly$editable, path=react_poly$path,
fillcolor=POLY_STATIC_FILL, opacity = POLY_OPA, active=1,
line=list(color=POLY_STATIC_OUTLINE, width=POLY_LIN_WDTH))),
activeshape=list(fillcolor=POLY_EDIT_COLOR, opacity=0.55)) # opacity < 0.5 means that you have to click out outline to select/toggle, which is a pain!
} else {
# If the gate is not static (currently editable), then draw gate with
# add_trace method. This allows circles at points, outline, and fill,
# but I haven't figured out how to separate color or opacity for line/fill.
# Red circle points = add/remove, black circle points = drawing
if(react_poly$adding || react_poly$removing) {
point_color <- "red"
points_xy <- rbind(react_poly$edit_points, react_poly$edit_points[1,])
} else {
point_color <- "black"
points_xy <- react_poly$points
}
# Add polygon to the figure
fig <- fig %>%
# Note, points_xy needs to have first point added to the end, to
# close the polygon --where is this done again?
add_trace(data=points_xy, x=~x, y=~y, type="scatter",
mode="lines+markers",
marker=list(line=list(width=2, color=POLY_EDIT_COLOR),
size=10, color=point_color),
line=list(color=POLY_EDIT_COLOR, width=POLY_LIN_WDTH),
hoverinfo='skip', fill="toself", inherit=FALSE)
}
}
# Actually run the plotly object for display, now that all components are added.
fig
})
# Do this every time after polygon is edited by dragging a point
# Use edit_path instead of path, so changes can be discarded.
# This event coes from the "editable" polygon, set with editable=TRUE
observeEvent(event_data("plotly_relayout"), {
if (react_poly$path != "") { # Only do this if there's a current polygon! Resizing the page also triggers plotly_relayout, so this will crash if no polygon is drawn yet.
ed <- event_data("plotly_relayout") # Get event info
ed_path <- ed[[grep("path",names(ed))]] # Get path from event info
react_poly$edit_path <- ed_path # Store (as editing/temp version)
ed_xy <- path_to_xy(ed_path) # Convert to XY coordinates
react_poly$edit_points <- ed_xy # Store (as editing/temp version)
}
})
# What to do when the plot is clicked
# Note that this allows clicking anywhere on the plot and recording XY,
# which only works because we're using histogram2d.
# Might work with other plots if we overlay a transparent histogram 2d?
observeEvent(event_data("plotly_click"), {
# Shorten name for convenience
d <- event_data("plotly_click") # get coordinates
if(react_poly$drawing) {
# Shorten name for convenience
# Pull out first point drawn, use this to check if current point
# is close enough to count as closing/finishing the polygon
# (using NEARNESS_TOLERANCE).
s <- react_poly$points[1,]
# Don't allow polygon closure if there are 2 or fewer points!
if (nrow(react_poly$points) < 3) {
dist_to_start <- Inf
} else {
dist_to_start <- ((d$x-s$x)^2+(d$y-s$y)^2)^0.5 # distance of clicked point to starting point, will be compared with NEARNESS_TOLERANCE
}
# If clicked point is close enough to start point, close the polygon and exit drawing mode.
if (dist_to_start < NEARNESS_TOLERANCE) {
react_poly$path <- paste0(react_poly$path, " Z") # Close path
react_poly$static <- TRUE
react_poly$drawing <- FALSE
# Switch out buttons
enable("edit")
enable("add")
enable("remove")
disable("done")
enable("load")
enable("create")
enable("save")
enable("rename")
disable("cancel")
} else {
# If clicked point isn't close enough to start point, add point to polygon
# and keep on drawing.
react_poly$points <- rbind(react_poly$points,
data.frame(x=d$x, y=d$y))
react_poly$path <- xy_to_path(react_poly$points)
}
}
# Known bug! If you make changes with adding/removing, but then cancel instead
# clicking done, and then go back to adding/removing, you won't be able to click
# on the last point that you edited (and canceled). Clicks nearby also don't
# register with event_data("plotly_click") -- very strange!
# ---------The workaround for this is to just click somewhere else (away from the
# gate is fine, or on other points within the gate), and then it will register again,
# even the point that was originally unclickable!
# If in add/remove point mode (not polygon drawing mode):
if (react_poly$adding || react_poly$removing) {
# a$x and a$y messed this up, so using a["x"] and a["y"] instead. This is because apply converts away from dataframe and loses names.
all_dists <- apply(react_poly$edit_points, 1,
function(a) ((d$x-a["x"])^2+(d$y-a["y"])^2)^0.5 ) # Get dist from click to all points in the polygon
# Find the closest point in polygon to mouse click
selected_idx <- which.min(all_dists)
# Check if click was close enough to polygon point
if (all_dists[selected_idx] < NEARNESS_TOLERANCE) {
# If click is close enough to polygon point, choose different actions
# for adding points vs. removing points
if (react_poly$adding) {
# This code will check the two segments before and after the selected
# point, see which is longer, and add a new point at the halfway point
# on that segment.
# shorten names so the lines of code don't get too long
rx <- react_poly$edit_points[,"x"] # X coordinates only
ry <- react_poly$edit_points[,"y"] # Y coordinates only
si <- selected_idx # Index of the selected point (closest to click)
# Point indices before and after selected point index.
# Note that these will be overwritten later if they are the first
# or last point in the polygon, and we need to go "around the circle."
si_before <- si - 1
si_after <- si + 1
# Need special cases for first and last indices, because R doesn't allow reverse/negative indexing!
nr <- nrow(react_poly$edit_points) # Shorten for convenience
if (si == 1) {
si_before <- nr # Only correct for "before" case, but this won't be used in the "after" case, so that's ok.
}
if (si == nr) {
si_after <- 1 # Only correct for "after" case, but this won't be used in the "before" case, so that's ok.
}
# Calculate the segment lengths before and after the selected point (to find longest).
dist_before <- ((rx[si]-rx[si_before])^2+(ry[si]-ry[si_before])^2)^0.5
dist_after <- ((rx[si]-rx[si_after])^2+(ry[si]-ry[si_after])^2)^0.5
if (dist_before > dist_after) {
cut_point <- si_before # Used to inserting row in the middle of dataframe
new_point <- colMeans(react_poly$edit_points[c(si_before, si),]) # new point to insert
} else {
cut_point <- si # Used to inserting row in the middle of dataframe
new_point <- colMeans(react_poly$edit_points[c(si, si_after),]) # new point to insert
}
# Start with special case where we need to go backward from the first point
if (si == 1 && dist_before > dist_after) {
# If we need to go backward from the first point, add new point at the end
react_poly$edit_points <- rbind(react_poly$edit_points, new_point)
} else {
# Second special case, where we need to go forward from the last point
if (si == nr && dist_after > dist_before) {
# If we need to go forward from the last point, add new point at the beginning
react_poly$edit_points <- rbind(new_point, react_poly$edit_points)
} else {
# For regular, non-special cases, just add new point in the middle of the data frame.
react_poly$edit_points <- rbind(
react_poly$edit_points[1:cut_point,],
new_point,
react_poly$edit_points[(cut_point+1):nr,]
)
}
}
}
if (react_poly$removing){
# For removing points from polygon - don't let it get smaller than 3. . .
if (nrow(react_poly$edit_points) > 2) {
# -idx does removal, rather than reverse indexing in other languages!
react_poly$edit_points <- react_poly$edit_points[-selected_idx,]
}
}
# Reset dataframe indices to make sure there's not and indexing problem later!
row.names(react_poly$edit_points) <- NULL
react_poly$edit_path <- xy_to_path(react_poly$edit_points)
}
}
})
}
shinyApp(ui, server)
您的selectInput()的multiple选项行正上方的行似乎令人不快:
choices = ~ mget(c(as.character(DF@parameters@data[,"name"])),
有3个开始花括号，只有2个结束花括号;根据selectInput()的结构，这是不正确的。
(我没有mget()功能的经验，也不知道波浪在那里做什么。您可能只需要在最后的,)