R/mod_network_plot.R

In tbilab/meToolkit: Build and Customize Phewas Multimorbidity Explorer Apps.

#' Subject-level network diagram: UI
#'
#' @seealso \code{\link{network_plot}}
#' @param id Unique id of module
#' @param snp_colors A three element array of colors corresponding to the color
#'   of patient nodes and their snp status in order of 0,1,2 copies of minor
#'   allele.
#'
#' @return HTML tag containing interactive network
#' @export
#'
#' @examples
#'
#' network_plot_UI('mycomorbiditynetwork_plot', snp_colors = c('#bdbdbd','#fecc5c', '#a50f15'))
network_plot_UI <- function(id, snp_colors) {
  ns <- NS(id)

  height_of_controls <- 30

  module_css <- glue::glue(
    "
    #network_module-control-panel {
      height: {height_of_controls}px;
      display: flex;
      justify-content: space-between;
    }

    .network_module-network-controls {
      padding: 3px;
      align-self: center;
    }

    #network_plot_holder {
      height: calc(100% - var(--section-title-height) - [[height_of_controls]]px);
      position: relative;
    }
    ",
    .open = "[[",
    .close = "]]"
  )

  # CSS Styles
  rounded_span <- function(color) {
    glue::glue(
      "
      border-radius: 50%;
      font-family: Monaco;
      font-size: 0.9rem;
      padding: 1px 6px;
      color: white;
      background: {color};
      "
    )
  }

  shiny::tagList(
    shiny::tags$style(module_css),
    shiny::div(
      class = "title-bar",
      shiny::h3("Subject-Phecode Bipartite Network", class = "template-section-title"),
      help_modal_UI(
        id = ns("network"),
        title = "Help for the subject-phecode bipartite netework",
        help_img_url = "https://raw.githubusercontent.com/tbilab/meToolkit/reviewer_updates/vignettes/network_help_page.png",
        more_link = "https://prod.tbilab.org/phewas_me_manual/articles/meToolkit.html#subject-phecode-bipartite-network"
      )
    ),
    shiny::div(
      id = "network_module-control-panel",
      div(
        class = 'network_module-network-controls minor-allele-checkbox',
        uiOutput(ns("snp_filter_holder")),
      ),
      div(
        class = 'network_module-network-controls minor-allele-legend',
        span('Copies of minor allele:'),
        span(style = rounded_span(snp_colors[1]), "0"),
        span(style = rounded_span(snp_colors[2]), "1"),
        span(style = rounded_span(snp_colors[3]), "2")
      )
    ),
    shiny::div(id = "network_plot_holder",
               r2d3::d3Output(ns("plot"), height = '100%'))
  )
}

#' Subject-level network diagram: Server
#'
#' @seealso \code{\link{network_plot_UI}}
#' @param input,output,session Auto-filled by callModule | ignore
#' @param network_data Reactive object containing individual network data as
#'   generated by \code{meToolkit::setup_network_data}.
#' @param highlighted_codes Reactive object containing list with `type`:
#'   (`{'pattern', 'code'}`) and `codes`: array of code names that comprise
#'   connection pattern to highlight in patients.
#' @param snp_filter Reactive object containing boolean containing info on if
#'   we've filtered by snp or not.
#' @param viz_type Character string containing info on which type of network we
#'   want to draw. "bipartite" for a plot that puts one node type on either
#'   size, or free for a traditional force directed layout. Defaults to
#'   \code{'free'}.
#' @param update_freq How many iterations of the layout simulation are run
#'   between redrawing the viz. Set to lower value for a smoother animation,
#'   higher for better performance. Default is \code{15} frames.
#' @param action_object A \code{reactiveVal} that will be updated by the module
#'   upon isolation, deletion, or snp_filtering.
#' @return Server component of interactive network plot. Returns type-payload
#'   list with the type \code{"isolation, deletion, snp_filtering"} to the
#'   passed \code{action_object} for updating app state.
#' @export
#'
#' @examples
#' callModule(info_panel, 'info_panel', snp_name, individual_data, subset_maf)
network_plot <- function(input,
                         output,
                         session,
                         network_data,
                         highlighted_codes,
                         snp_filter,
                         viz_type = 'free',
                         update_freq = 15,
                         action_object) {
  message_path <- 'message_network_plot'

  # send data and options to the 2d plot
  output$plot <- r2d3::renderD3({
    validate(need(network_data(), message = FALSE))

    r2d3::r2d3(
      data = jsonlite::toJSON(network_data()),
      script = system.file("d3/network_plot/index.js", package = "meToolkit"),
      container = 'div',
      dependencies = c(
        "d3-jetpack",
        system.file("d3/helpers.js", package = "meToolkit"),
        system.file("d3/network_plot/helpers.js", package = "meToolkit")
      ),
      css = c(
        system.file("d3/helpers.css", package = "meToolkit"),
        system.file("d3/network_plot/network.css", package = "meToolkit"),
        system.file("css/common.css", package = "meToolkit")
      ),
      options = list(
        just_snp = snp_filter(),
        msg_loc = session$ns(message_path),
        highlighted_pattern = highlighted_codes(),
        viz_type = viz_type,
        update_freq = update_freq
      )
    )
  })

  starting_filter_value <- isolate(snp_filter())

  output$snp_filter_holder <- renderUI({
    checkboxInput(session$ns("snp_filter"),
                  label = "Just minor-allele carriers",
                  value = starting_filter_value,
                  width = "auto")
  })

  # If we've received a message from the network viz package
  # it into the returned reactive value
  observeEvent(input[[message_path]], {
    validate(need(input[[message_path]], message = FALSE))
    action_object(input[[message_path]])
  })

  # If the snp filter toggle has been changed, send the message
  # to the reactive value
  observeEvent(input$snp_filter, {
    # Check to see if the snp filter is different than current state
    validate(need(input$snp_filter != snp_filter(), message = FALSE))

    action_object(list(type = 'snp_filter_change',
                       payload = input$snp_filter,
                       source = "network_plot"))
  })

  # Enable opening and closing of help modal
  shiny::callModule(help_modal, "network")
}