How to avoid overlapping plotly rectangle shapes when working with nested shiny modules and reactive elements?

shinydashboard
shiny-modules
r
plotly
datatable

#1

(originally asked at SO: https://stackoverflow.com/questions/53211142/how-to-avoid-overlapping-plotly-rectangle-shapes-when-working-with-nested-shiny)

I have a modularized app in which one part of analysis is to draw rectangle shapes relative to plot axis. While working on this, I am facing few conflicts which are explained using below usecases, example and a reference image. I know that the example code is quite lengthy but this is the minimalistic I could get to make the explanation complete.

Let's say there are 3 modules:

'pooling', 'criteria_A' and 'criteria_B'.

The pooling module consists of available criteria's (in this case criteria_A and criteria_B) as selectInput choices, an ADD button and a plotly layout. User can select the desired criteria and add it as a pooling instance. During such course, multiple instances of same and different criteria's can be added. This is done by calling the respective criteria module from pooling module for each ADD button event. Also, it is possible to remove the added criteria from pooling list through REMOVE button.

Note that shapes are computed within 'criteria_A' and 'criteria_B' modules and returned to be used in renderPlotly component of pooling module .

Each criteria module has certain parameters like:

'Phases', 'Start Val', 'End Val' and 'Max Val'

out of which only 'Phases' and 'Max Val' are observed for changes ('Start Val' and 'End Val' are provided only for better understanding).

Each phase is associated with a range of values which are used as plot's 'x0' and 'x1' (x-axis rectangle coordinate values). For example: 'block1' phase ranges from 1 to 6 and so on.

Initially, End Val = Max Val ('x1' coordinate represents 'Max Val') and for each such phases it is allowed to manipulate the 'Max Val' (possibility to reduce 'x1' upto 'x0') which results in a reactive/adjustable rectangle over the plot. However, the 'Start Val' / 'x0' remains fixed.

Below are some usecases which leads to conflicts while adding pooling criteria's and drawing respective rectangles on the plot.

Usecase 1
  • step1: User selects and adds 'Criteria A'
  • step2: Selects 'block1' and 'block2' phases
  • step3: Reduces the Max Val to 8.5
  • step4: adds another pooling of type Criteria B

Problem: with addition of 2nd criteria, the 'Max Val' value (8.5) of previous Pooling 1 is reset back to its 'End Val' ('block1' + 'block2': 11).

I doubt this behavior is caused when pooling module call to criteria module is made on each ADD event. But I have already wrapped this calling in an isolate({}). It is required to hold the changed 'Max Val' of any previous pooling. How can this value reset be avoided ?

Usecase 2

in continuation to Usecase1, now there are two pooling's (Pooling 1 of type Criteria A and Pooling 2 of type Criteria B)

  • step5: In Pooling 2 of type Criteria B, user selects 'block1' phase.

Problem: this causes an overlapping rectangle where the current 'block1' shape of Criteria B overlaps with previous 'block1' shape of Criteria A. This is not the correct behavior as the complete value range of 'block1' phase (from 1 to 6) is already utilized in Pooling 1.

How can this overlap be avoided ? It is required that the user still can access any previously used phases also in future criteria's which will have no effect on the plot (only if the complete phase value range is utilized, if not there is a remaining phase value range which should constitute the remaining portion of the rectangle. This is explained in next usecase.)

Usecase 3

in continuation to Usecase2, now there are two pooling's` (Pooling 1 of type Criteria A with 'block1' and 'block2' phases and Pooling 2 of type Criteria B with 'block1' phase)

  • step6: User selects and adds 'Criteria B' again.
  • step7: Selects 'block2' phase (for clarity, please change the previously reset 'Max Val' at Pooling 1 to 8.5)

Problem1: The 'block2' phase starts from its initial start range ('Start.val') of 7 which is incorrect. It should start from value 8.5 which was the 'Max Val' set at Pooling 1 for the same 'block2' phase. How is it possible to draw only the remaining portion of rectangle without overlap ?

Below is the reprex:

library(tidyverse)
library(plotly)
library(shiny)
library(shinyBS)
library(shinydashboard)
library(shinydashboardPlus)

# dataset
dataset <- reactiveValues(rectDF = NULL)

x1 <- data.frame(Block = 'block1', Value = seq(from = 1, to = 6))
x2 <- data.frame(Block = 'block2', Value = seq(from = 7, to = 11))
x3 <- data.frame(Block = 'block3', Value = seq(from = 12, to = 15))

dataset$rectDF <- rbind(x1,x2,x3)
#

block.names = reactive({
  unique(dataset$rectDF$Block)
})

############################################
# pooling module

poolingUI <- function(id) {
  ns <- NS(id)
  
  tagList(
    fluidRow(
      column(
        width = 12,
        column(
          width = 12,
          plotlyOutput(ns('plot'))
        ),
        column(
          br(), br(),
          width = 2,
          selectInput(
            ns('poolingCriteria'), 'Pooling Criteria',
            choices = c(
              'Criteria A' = 'criteria_A',
              'Criteria B' = 'criteria_B'
            )
          )
        ),
        column(
          br(), br(),
          width = 2,
          br(),
          fluidRow(
            bsButton(ns('addPoolingBtn'), 'Add', size = 'large', style = 'success')
          )
        )
      )
    ),br(),
    uiOutput(ns('criteriaUIs'))
  )
}

pooling <- function(input, output, session) {
  
  module.settings = reactiveValues(modules = list(), uis = list(), shapes = list(), nwidgets = 0)
  
  observeEvent(input$addPoolingBtn, {
    isolate({
      ns = session$ns
      module.settings$nwidgets = module.settings$nwidgets + 1
      id = paste0('crit', module.settings$nwidgets,"_", format(Sys.time(), '%H%M%OS3'))
      module.settings$uis[[ns(id)]] = poolingWidgetUI(ns(id))
      
      module.settings$modules[[module.settings$nwidgets]] = callModule(
        get(as.character(input$poolingCriteria), mode = 'function'),
        id
      )
    })
    
  })
  
  output$plot <- renderPlotly({
    
    shapes = list()
    if(module.settings$nwidgets > 0) {
      ncriteria <- module.settings$nwidgets
      
      shapes = lapply(1:ncriteria, function(i){
        module.settings$modules[[i]]()$shape
      })
    }
    
    plot_ly() %>%
      layout(
        xaxis = list(range = c(1.667, 16))
      ) %>%
      layout(
        title = 'Shape Overlap',
        yaxis = list(zeroline = FALSE),
        xaxis = list(zeroline = FALSE)
      ) %>%
      layout(shapes = c(unlist(shapes, recursive = F)))
  })
  
  
  
  rmv.obsList <- list()
  
  output$criteriaUIs = renderUI({
    
    req(module.settings$uis)
    ns = session$ns
    
    buttons = lapply(seq_along(module.settings$uis),function(i)
    {
      btName = paste0('rmvPoolingBtn',i)
      
      if (is.null(rmv.obsList[[btName]])) {
        rmv.obsList[[btName]] <<- observeEvent(input[[btName]], {
          module.settings$modules = module.settings$modules[-i]
          module.settings$uis = module.settings$uis[-i]
          module.settings$nwidgets = module.settings$nwidgets - 1
        })
      }
      fluidRow(
        bsButton(ns(btName), 'Remove', size = 'large', style = 'danger'),
        style = "margin-top: 60px;"
      )
      
    })
    
    
    module.uis = lapply(seq_along(module.settings$uis),function(i)
    {
      boxPad(
        fluidRow(
          column(paste('Pooling', i), width = 1, style = "margin-top: 60px;"),
          column(module.settings$uis[[i]],width = 10),
          column(buttons[[i]],width = 1)
        )
      )
    })
    
    lapply(module.uis, tagList)
  })
  
}


############################################
# criteria_A module

poolingWidgetUI <- function(id) {
  ns = NS(id)
  uiOutput(ns('widget'))
}

criteria_A <- function(input, output, session, criteria_A.settings = NULL) {
  ns = session$ns
  
  if(is.null(criteria_A.settings))
    criteria_A.settings = reactiveValues()
  else
    criteria_A.settings = reactiveValues(
      block.phase = criteria_A.settings$block.phase,
      start.val = criteria_A.settings$start.val,
      end.val = criteria_A.settings$end.val,
      max.val = criteria_A.settings$max.val
    )
  
  rect.data <- reactive({
    dataset$rectDF[dataset$rectDF$Block %in% criteria_A.settings$block.phase, ]
  })
  
  observe({
    req(rect.data())
    
    end.val = max(rect.data()$Value)
    start.val = min(rect.data()$Value)
    
    if (start.val > end.val) start.val = end.val
    
    criteria_A.settings$start.val = start.val
    criteria_A.settings$end.val = end.val
    
  })
  
  output$widget = renderUI({
    selected = criteria_A.settings$block.phase
    
    fluidRow(
      boxPlus(
        width = 12,
        title = helpText(HTML('<h4><b>Criteria A</b></h4>')),
        closable = F,
        collapsible = F,
        status = 'danger',
        enable_label = F,
        
        column(
          style = 'border-right: 3px solid purple',
          width = 3,
          selectInput(
            ns('blockPhase'),
            'Phases',
            choices = block.names(),
            selected = selected,
            multiple = T
          )
        ),
        
        column(
          style = 'border-right: 3px solid purple',
          width = 2,
          textInput(ns('msStart'), 'Start Val', value = min(rect.data()$Value))
        ),
        
        column(
          style = 'border-right: 3px solid purple',
          width = 2,
          textInput(ns('msEnd'), 'End Val', value = max(rect.data()$Value))
        ),
        
        column(
          style = 'border-right: 3px solid purple',
          width = 2,
          numericInput(
            ns('maxVal'),
            'Max Val',
            value = criteria_A.settings$end.val,
            min = min(rect.data()$Value),
            max = max(rect.data()$Value),
            step = .5
          )
        )
      )
    )
  })
  
  observe({
    if (length(input$blockPhase) > 0){
      criteria_A.settings$block.phase = input$blockPhase
    }
  })
  
  observe({
    req(input$maxVal)
    criteria_A.settings$max.val = input$maxVal
    
  })
  
  return(reactive({
    req(criteria_A.settings$block.phase)
    
    # browser()
    if (is.null(criteria_A.settings$start.val) | is.null(criteria_A.settings$end.val) | is.null(criteria_A.settings$max.val))
    {
      shape = NULL
    }
    else
    {
      if (nrow(dataset$rectDF) > 0)
        rect = list(
          type = "criteria_A.rect",
          x0 = criteria_A.settings$start.val,
          x1 = criteria_A.settings$max.val,
          xref = "x",
          y0 = 0,
          y1 = 2.5,
          yref = "y",
          fillcolor = 'rgb(221, 62, 62)',
          line = list(color = "darkgrey"),
          opacity = 0.8
        )
      else
        rect = NULL
      
      shape = list(rect)
      
    }
    
    list(
      type = "criteria_A",
      criteria_A.settings = criteria_A.settings,
      shape = shape
    )
  }))
}



############################################
# criteria_B module

poolingWidgetUI <- function(id) {
  ns = NS(id)
  uiOutput(ns('widget'))
}

criteria_B <- function(input, output, session, criteria_B.settings = NULL) {
  ns = session$ns
  
  if(is.null(criteria_B.settings))
    criteria_B.settings = reactiveValues()
  else
    criteria_B.settings = reactiveValues(
      block.phase = criteria_B.settings$block.phase,
      start.val = criteria_B.settings$start.val,
      end.val = criteria_B.settings$end.val,
      max.val = criteria_B.settings$max.val
    )
  
  rect.data <- reactive({
    dataset$rectDF[dataset$rectDF$Block %in% criteria_B.settings$block.phase, ]
  })
  
  observe({
    req(rect.data())
    
    end.val = max(rect.data()$Value)
    start.val = min(rect.data()$Value)
    
    if (start.val > end.val) start.val = end.val
    
    criteria_B.settings$start.val = start.val
    criteria_B.settings$end.val = end.val
    
  })
  
  output$widget = renderUI({
    
    selected = criteria_B.settings$block.phase
    
    fluidRow(
      boxPlus(
        width = 12,
        title = helpText(HTML('<h4><b>Criteria B</b></h4>')),
        closable = F,
        collapsible = F,
        status = 'danger',
        enable_label = F,
        
        column(
          style = 'border-right: 3px solid purple',
          width = 3,
          selectInput(
            ns('blockPhase'),
            'Phases',
            choices = block.names(),
            selected = selected,
            multiple = T
          )
        ),
        
        column(
          style = 'border-right: 3px solid purple',
          width = 2,
          textInput(ns('msStart'), 'Start Val', value = criteria_B.settings$start.val)
        ),
        
        column(
          style = 'border-right: 3px solid purple',
          width = 2,
          textInput(ns('msStart'), 'End Val', value = criteria_B.settings$end.val)
        ),
        
        column(
          style = 'border-right: 3px solid purple',
          width = 2,
          numericInput(
            ns('maxVal'),
            'Max Val',
            value = criteria_B.settings$end.val,
            min = min(rect.data()$Value),
            max = max(rect.data()$Value),
            step = .5
          )
        )
      )
    )
  })
  
  observe({
    if (length(input$blockPhase) > 0){
      criteria_B.settings$block.phase = input$blockPhase
    }
  })
  
  observe({
    req(input$maxVal)
    criteria_B.settings$max.val = input$maxVal
  })
  
  return(reactive({
    req(criteria_B.settings$block.phase)
    
    # browser()
    if (is.null(criteria_B.settings$start.val) | is.null(criteria_B.settings$end.val) | is.null(criteria_B.settings$max.val))
    {
      shape = NULL
    }
    else
    {
      if (nrow(dataset$rectDF) > 0)
        rect = list(
          type = "criteria_B.rect",
          x0 = criteria_B.settings$start.val,
          x1 = criteria_B.settings$max.val,
          xref = "x",
          y0 = 0,
          y1 = 2.5,
          yref = "y",
          fillcolor = 'rgb(62, 221, 128)',
          line = list(color = "darkgrey"),
          opacity = 0.3
        )
      else
        rect = NULL
      
      shape = list(rect)
      
    }
    
    list(
      type = "criteria_A",
      criteria_B.settings = criteria_B.settings,
      shape = shape
    )
  }))
}



############################################
# UI

ui <- bootstrapPage(
  poolingUI(id = 'pooling')
)

############################################
# Server

server <- function(input, output, session) {
  
  # callmodule pooling and poolingPlot
  callModule(pooling, 'pooling')
  
}


shinyApp(ui = ui, server = server)

Three types of rectangles can be seen in image:

'Red', 'Green' and 'Brown'

Red and Green represents criteria A and criteria B respectively and Brown represents the overlapping rectangles. As mentioned in usecases:

  • marked 'Max Val' of Pooling 1 should retain the user set value of 8.5 and not reset to Criteria A default 'End Val' of 11.
  • marked Pooling 2 should have no effect or no overlapping rectangle should be drawn (as the 'block1' phase is previously used in Pooling 1).
  • marked 'block2' phase and 'Start Val' in Pooling 3 coincides with the previously used 'block2' phase in Pooling 1 of type Criteria A. The 'Start Val' should have a value of 8.5 instead of 7. This avoids the overlap of 2nd rectangle from 7 to 8.5

I have looked into this and have tried to implement the intersecting portion. But, only determining the overlapping coordinates is not sufficient and does not solve the problem. Also, I think it would be efficient to avoid the overlap at the first place and to handle this before plotting.

How could such problem be tackled ? Any help is appreciated! Thanks.


#2

There seems to be a lot of irrelevant detail surrounding the core issue, so let's try to work from a minimal example. If I understand correctly, the main issue is that you want to draw two overlapping shapes, but avoid blending their color? Here is an example:

rect1 <- list(
  type = "rect",
  fillcolor = "rgb(62, 221, 128)",
  opacity = 0.5,
  x0 = 0.25, 
  x1 = 1,
  y0 = 0.25, 
  y1 = 1
)

rect2 <- list(
  type = "rect",
  fillcolor = "rgb(221, 62, 62)",
  opacity = 0.5,
  x0 = 0, 
  x1 = 0.75,
  y0 = 0, 
  y1 = 0.75
)


plot_ly() %>%
  layout(
    shapes = list(rect1, rect2)
  )

I don't think it will be possible to use opacity (or alpha blending) and prevent their colors from blending without using the intersection trick. One simple alternative though would be to remove opacity altogether or remove it from the "top" shape

rect1 <- list(
  type = "rect",
  fillcolor = "rgb(62, 221, 128, 0.5)",
  opacity = 0.5,
  x0 = 0.25, 
  x1 = 1,
  y0 = 0.25, 
  y1 = 1
)

rect2 <- list(
  type = "rect",
  fillcolor = "rgb(221, 62, 62)",
  x0 = 0, 
  x1 = 0.75,
  y0 = 0, 
  y1 = 0.75
)


plot_ly() %>%
  layout(
    shapes = list(rect1, rect2)
  )