r – Hi! I am trying to change the columns as the shiny session runs and update the plot with a new column. But when I index my plot is blank. Any ideas?

There is a lot of code. I apologize. I block quoted out the specific code I am having issues with so please ignore everything else as I only put it so you have everything if you want to run a file yourself. Please use this site: https://community.cytobank.org/cytobank/experiments/27889/download_files and download any file to test the code below.

rm(list = ls())

library(shiny)
library(shinyjs)
library(ggplot2)
library(plotly)
library(viridis)
library(shinydashboard)

## 30 MB file limit
options(shiny.maxRequestSize=30*1024^2)

# Only tested with histogram2d
# The trick for all of this is that every pixel in histogram is now clickable and locatable!
# Perhaps we could use this approach with for other plot types by overlaying a transparent histogram2d?
PLOT_TYPE <- "histogram2d" # "histogram2d", "histogram2dcontour"

NBINS <- 200 # "Pixels for the image"
ZMIN <- 0 # Leave at zero
ZMAX <- 20 # ZMIN and ZMAX are used for adjusting "saturation" of the color scale

PAL <- "inferno" # "jet", "magma", "inferno", "plasma", "viridis", "cividis", "rocket", "mako", "turbo"
PAL_SIZE=100 # number of levels for color scale
BACKGROUND_COLOR <- "white"

# Polygon coloring properties
POLY_OPA <- 0.55 # Set opacity > 0.5 so entire polygon is selectable instead of just the border!
POLY_STATIC_FILL <- "magenta"
POLY_STATIC_OUTLINE <- "blue"
POLY_EDIT_COLOR <- "orange"
POLY_LIN_WDTH <- 4

# How close you need to click for point selection and polygon closing
# Should probably change this to be some percentage of x/y range
NEARNESS_TOLERANCE <- 0.2

# Make the buttons a little smaller
BUTTON_STYLE <- "padding:2px; font-size:80%"

# Set up color palette.  Jet is not included, so enter this on manually
if (PAL == "jet") {
    pal <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan",
                          "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))(PAL_SIZE)
} else {
    pal <- viridis_pal(option=PAL)(PAL_SIZE)
}

# This is important!  Make the background white by changing the lowest level of color palette
# Could this be broken by a small number for PAL_SIZE?
pal <- c(BACKGROUND_COLOR, pal)

## import flowcore
library(flowCore)

# Convert path (from SVG, with M, L, Z, etc.) to data frame with XY coordinates
# M = start point, L = connection to next point, Z = connect back to start point)
path_to_xy <- function(input_path) {
    # Reworked to avoid tidyverse.  This is just to avoid using "unnecessary" libraries,
    # but we can go back to using tidyverse if it helps in other places.
    a <- input_path
    a <- gsub("[MZ ]", "", a)
    a <- strsplit(a,"L")[[1]]
    a <- matrix(as.numeric(unlist(strsplit(as.matrix(a), ","))), ncol=2, byrow=TRUE)
    a <- as.data.frame(a)
    colnames(a) <- c("x", "y")
    return(a)
}

# Convert XY coordinates to SVG path (with M, L, Z, etc.)
xy_to_path <- function(input_xy) {
    a <- input_xy
    a <- as.character(t(a))
    output_path <- " M "
    for (i in 1:length(a)){
        if (i %% 2 == 0) {
            output_path <- paste0(output_path, a[i], " L")
        } else {
            output_path <- paste0(output_path, a[i], ",")
        }
    }
    output_path <- sub(" L$", "", output_path)
    return(output_path)
}

ui <- dashboardPage(
title="ScopeDashboard",dashboardHeader(title = span("Scope Dashboard")
),
dashboardSidebar(

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()
              ),
              
    ## add file opener
        fileInput("file1", "Choose FCS File", accept = ".fcs"),
        checkboxInput("header", "Header", TRUE),
    
>     selectInput(
>       inputId = 'test_dfx', 
>       label = "Choose X variable:",
>       choices="",
>       multiple = F,
>       selected = "FSC-A"
>     ),
>     
>     selectInput(
>       inputId = 'test_dfy', 
>       label = "Choose Y variable:",
>       choices="",
>       multiple = F,
>       selected = "SSC-A"
>     ),
     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
      ## Create new input
      file.name <- input$file1
      
      ## ----ReadFiles3, echo=TRUE, results="markup"----------------------------------
      DF <- read.FCS(file.name$datapath, column.pattern="-A") 
      test_df <- data.frame(DF@exprs)
      colnames <- c(as.character(DF@parameters@data[,"name"]))
      colnames <- str_replace_all(colnames, '-A', '.A')
      
      updateSelectInput(session, inputId = 'xvar', label="Choose X Variable",
                        choices = colnames, selected = 'FSC.A')
      updateSelectInput(session, inputId = 'yvar', label="Choose Y Variable",
                        choices = colnames, selected = 'SSC.A')
      
      
>       indx <- as.character(input$xvar)
>       indy <- as.character(input$yvar)
>       
>         fig <- plot_ly(x= test_df[indx], y= test_df[indy], nbinsx=NBINS, nbinsy=NBINS,
>                        colorscale=list(seq(0,1, length.out=length(pal)), pal),
>                        type=PLOT_TYPE, zmin=ZMIN, zmax=ZMAX, hoverinfo="none",
>         )%>%
        layout(xaxis = list(
                   title = input$xvar
                   ),
                 yaxis = list(
                   title =input$yvar
                 ),
               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)

This is what I see when I upload a .fcs file which is a flow cytometry file

Leave a Comment