Как избежать наложения графически прямоугольных фигур при работе с вложенными блестящими модулями и реактивными элементами?

Question

У меня есть модульное приложение, в котором одной частью анализа является рисование прямоугольников по отношению к оси графика. Работая над этим, я столкнулся несколько конфликтов, которые объясняются использованием ниже usecases, например, и эталонного изображения. Я знаю, что пример кода довольно длинный, но это минимализм, который я мог бы сделать, чтобы пояснение было полным.

Допустим, есть 3 модуля:

«объединение», «критерии_А» и «критерии_В».

Модуль пула состоит из доступных критериев (в данном случае критерии_А и критериев_B) в качестве выбора selectInput, кнопки ADD и графического макета. Пользователь может выбрать нужные критерии и добавить его в качестве экземпляра пула. В течение такого курса могут быть добавлены несколько экземпляров одного и того же критерия. Это делается путем вызова соответствующего модуля критериев из модуля пула для каждого события кнопки ADD. Также можно удалить добавленные критерии из списка пула с помощью кнопки УДАЛИТЬ.

Обратите внимание, что фигуры вычисляются в модулях crit_A и критерии_B и возвращаются для использования в компоненте renderPlotly модуля пула .

Каждый модуль критериев имеет определенные параметры, такие как:

«Фазы», ​​«Начальное значение», «Конечное значение» и «Максимальное значение»

, из которых только «Phases» и «Max Val» наблюдаются для изменений («Start Val» и «End Val» представлены только для лучшего понимания).

Каждая фаза связана с диапазоном значений , которые используются как 'x0' и 'x1' (значения координат прямоугольника оси x). Например: фаза «block1» находится в диапазоне от 1 до 6 и т. Д.

Изначально End Val = Max Val (координата «x1» представляет «Max Val»), и для каждой такой фазы разрешается манипулировать «Max Val» (возможность уменьшить «x1» до «x0»), что приводит к в реактивном / регулируемом прямоугольнике над графиком. Тем не менее, «Start Val» / «x0» остается фиксированным.

---

Ниже приведены некоторые примеры использования, которые приводят к конфликтам при добавлении критериев объединения и рисовании соответствующих прямоугольников на графике.

Usecase1:

• step1: пользователь выбирает и добавляет «Критерии A»
• step2: выбор фаз 'block1' и 'block2'
• step3: уменьшает максимальное значение до 8,5
• step4: добавляет еще одно объединение типа Критерии B

Проблема: при добавлении 2-го критерия значение «Макс. Значение» (8.5) предыдущего пула 1 сбрасывается до его «Конечного значения» («блок1» + «блок2»: 11).

Я сомневаюсь, что это происходит, когда модуль пула вызывает модуль критериев для каждого события ADD. Но я уже обернул это призвание в изолят ({}). Требуется сохранить измененный «Max Val» любого предыдущего пула. Как избежать сброса этого значения?

Usecase2: в продолжение Usecase1, теперь есть два пула (Пул 1 типа Критерии A и Пул 2 типа Критерии B)

• step5: В пуле 2 типа Критерии B пользователь выбирает фазу block1.

Проблема: это вызывает перекрывающийся прямоугольник, в котором текущая форма 'block1' Критерия B перекрывается с предыдущей формой 'block1' Критерия A. Это неправильное поведение в качестве полного диапазона значений фазы 'block1' (от 1 до 6) уже используется в пуле 1.

Как этого перекрытия можно избежать? Требуется, чтобы пользователь все еще имел доступ к любым ранее использованным фазам также в будущих критериях, которые не будут влиять на график (только если используется полный диапазон значений фазы, если нет, то есть оставшийся диапазон значений фазы, который должен составлять оставшиеся часть прямоугольника. Это объясняется в следующем сценарии использования.)

Usecase3: в продолжение Usecase2 теперь есть два пула (Пул 1 типа Критерии A с фазами 'block1' и 'block2' и Пул 2 типа C Критерии B с фазой 'block1')

• step6: пользователь снова выбирает и добавляет «Критерии B».
• step7: выбирает фазу «block2» (для ясности, пожалуйста, измените ранее сброшенный «Max Val» при пуле 1 на 8.5)

Проблема 1: фаза «block2» начинается с начального начального диапазона («Start.val»), равного 7, что неверно. Он должен начинаться со значения 8.5, которое было «Max Val», установленным в пуле 1 для той же фазы «block2». Как можно нарисовать только оставшуюся часть прямоугольника без наложения?

---

library(tidyverse)
library(plotly)
library(crosstalk)
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)

---

Контрольное изображение

На изображении видны три типа прямоугольников:

«Красный», «Зеленый» и «Коричневый»

Красный и зеленый обозначают критерии А и В соответственно, а Браун обозначает перекрывающиеся прямоугольники. Как уже упоминалось в случаях использования:

• с пометкой «Макс. Значение» пула 1 должно сохранять заданное пользователем значение 8,5 и не сбрасываться до критерия А «Конечное значение» по умолчанию, равное 11.
• помеченное Объединение 2 не должно иметь никакого эффекта, или перекрывающий прямоугольник не должен быть нарисован (поскольку фаза 'block1' ранее использовалась в Объединении 1).
• помеченная фаза 'block2' и 'Start Val' в пуле 3 совпадает с ранее использовавшейся фазой 'block2' в Pooling 1 типа Критерии A. 'Стартовый Val' должен иметь значение 8,5 вместо 7. Это позволяет избежать перекрытие 2-го прямоугольника от 7 до 8,5

---

Я изучил этого и попытался реализовать пересекающуюся часть. Но только определение перекрывающихся координат недостаточно и не решает проблему. Кроме того, я думаю, что было бы целесообразно избежать дублирования в первую очередь и справиться с этим перед построением графика.

Как можно решить эту проблему? Любая помощь приветствуется! Спасибо.