Merge pull request #3 from CRI-iAtlas/develop

Develop

DESCRIPTION

@@ -25,6 +25,7 @@ Imports:
     stringr,
     viridis,
     shinydashboard,
+    tibble,
     tidyselect,
     htmltools,
     markdown

NAMESPACE

@@ -3,11 +3,16 @@
 export(barplot_server)
 export(barplot_ui)
 export(create_group_text_from_eventdata)
+export(create_nested_named_list)
 export(create_plotly_text)
+export(distributions_plot_ui)
+export(drilldown_histogram_server)
 export(drilldown_scatterplot_server)
 export(plotly_bar)
 export(plotly_scatter)
 export(plotly_server)
 export(plotly_ui)
+importFrom(dplyr,filter)
+importFrom(dplyr,mutate)
 importFrom(magrittr,"%>%")
 importFrom(rlang,.data)

R/app_server.R

@@ -1,8 +1,6 @@
 
 server <- function(input, output, session) {
 
-  # examples ----
-
   barplot_server(
     "barplot1",
     shiny::reactive(example_starwars_data_func),
@@ -33,4 +31,41 @@ server <- function(input, output, session) {
     x_feature_input = shiny::reactive("Petal.Length"),
     y_feature_input = shiny::reactive("Petal.Width")
   )
+
+  distributions_plot_server(
+    "distplot1",
+    plot_data_function = shiny::reactive(example_iris_data_func),
+    drilldown = shiny::reactive(T)
+  )
+
+  distributions_plot_server(
+    "distplot2",
+    plot_data_function = shiny::reactive(example_iris_data_func),
+    features = shiny::reactive(
+      example_iris_data() %>%
+        dplyr::select(
+          "feature_class",
+          "feature_name" = "feature",
+          "feature_display"
+        ) %>%
+        dplyr::distinct()
+    ),
+    drilldown = shiny::reactive(T)
+  )
+
+  distributions_plot_server(
+    "distplot3",
+    plot_data_function = shiny::reactive(example_iris_data_func),
+    features = shiny::reactive(
+      example_iris_data() %>%
+        dplyr::select(
+          "feature_class",
+          "feature_class2",
+          "feature_name" = "feature",
+          "feature_display"
+        ) %>%
+        dplyr::distinct()
+    ),
+    drilldown = shiny::reactive(T)
+  )
 }

R/app_ui.R

@@ -11,6 +11,12 @@ ui <- function() {
           barplot_ui("barplot2", title = "Example 2"),
           barplot_ui("barplot3", title = "Example 3"),
           barplot_ui("barplot4", title = "Example 4")
+        ),
+        shiny::tabPanel(
+          "Distribution Plots",
+          distributions_plot_ui("distplot1", title = "Example 1"),
+          distributions_plot_ui("distplot2", title = "Example 2"),
+          distributions_plot_ui("distplot3", title = "Example 3")
         )
       )
     )

R/barplot_server.R

@@ -30,7 +30,6 @@ barplot_server <- function(
   shiny::moduleServer(
     id,
     function(input, output, session) {
-
       ns <- session$ns
 
       display_feature_class_selection_ui <- shiny::reactive({
@@ -96,7 +95,7 @@ barplot_server <- function(
 
       group_data <- shiny::reactive({
         shiny::req("group_description" %in% colnames(barplot_data()))
-        get_group_data(barplot_data())
+        get_barplot_group_data(barplot_data())
       })
 
       plotly_server(

R/barplot_server_functions.R

@@ -19,7 +19,7 @@ summarise_barplot_se <- function(data, title){
     create_plotly_text(.data$feature, .data$group, c("MEAN", "SE"), title)
 }
 
-get_group_data <- function(barplot_data){
+get_barplot_group_data <- function(barplot_data){
   barplot_data %>%
     dplyr::select("group", "description" = "group_description") %>%
     dplyr::distinct()

R/distributions_plot_server.R

@@ -0,0 +1,153 @@
+distributions_plot_server <- function(
+  id,
+  plot_data_function,
+  features = shiny::reactive(NULL),
+  drilldown = shiny::reactive(F)
+  ) {
+  shiny::moduleServer(
+    id,
+    function(input, output, session) {
+      ns <- session$ns
+
+      feature_classes <- shiny::reactive({
+        get_distributions_feature_classes(features())
+      })
+
+      display_feature_class_selection_ui <- shiny::reactive({
+        shiny::req(!is.null(feature_classes()))
+        length(feature_classes()) > 1
+      })
+
+      output$display_feature_class_selection_ui <- shiny::reactive({
+        display_feature_class_selection_ui()
+      })
+
+      shiny::outputOptions(
+        output,
+        "display_feature_class_selection_ui",
+        suspendWhenHidden = FALSE
+      )
+
+      output$feature_class_selection_ui <- shiny::renderUI({
+        shiny::req(feature_classes())
+        shiny::selectInput(
+          inputId  = ns("feature_class_choice"),
+          label    = "Select Feature",
+          choices  = feature_classes()
+        )
+      })
+
+      display_feature_selection_ui <- shiny::reactive({
+        !is.null(features())
+      })
+
+      output$display_feature_selection_ui <- shiny::reactive({
+        display_feature_selection_ui()
+      })
+
+      shiny::outputOptions(
+        output,
+        "display_feature_selection_ui",
+        suspendWhenHidden = FALSE
+      )
+
+      feature_list <- shiny::reactive({
+        shiny::req(
+          features(),
+          display_feature_selection_ui(),
+          !is.null(display_feature_class_selection_ui())
+        )
+        if(display_feature_class_selection_ui()){
+          shiny::req(input$feature_class_choice)
+        }
+        get_distributions_feature_list(
+          features(),
+          input$feature_class_choice,
+          display_feature_class_selection_ui()
+        )
+      })
+
+      output$feature_selection_ui <- shiny::renderUI({
+        shiny::req(feature_list())
+        shiny::selectInput(
+          inputId  = ns("feature_choice"),
+          label    = "Select Feature",
+          choices  = feature_list()
+        )
+      })
+
+      distplot_data <- shiny::reactive({
+        shiny::req(
+          plot_data_function(),
+          input$scale_method_choice,
+          input$reorder_method_choice
+        )
+
+        if(display_feature_selection_ui()){
+          shiny::req(input$feature_choice)
+        }
+        create_distplot_data(
+          plot_data_function(),
+          input$feature_choice,
+          input$scale_method_choice,
+          input$reorder_method_choice
+        )
+      })
+
+      distplot_source_name <- shiny::reactive(ns("distplot"))
+
+      plotly_function <- shiny::reactive({
+        if(input$plot_type_choice == "Violin") return(plotly_violin)
+        else return(plotly_box)
+      })
+
+      output$distplot <- plotly::renderPlotly({
+        shiny::req(distplot_data(), distplot_source_name(), plotly_function())
+        plotly_function()(
+          data = distplot_data(),
+          source_name = distplot_source_name(),
+          x_col = "group",
+          y_col = "feature_value"
+        )
+      })
+
+      distplot_eventdata <- shiny::reactive({
+        shiny::req(distplot_source_name(), distplot_data(), plotly_function())
+        eventdata <- plotly::event_data("plotly_click", distplot_source_name())
+        shiny::validate(shiny::need(eventdata, "Click on above barplot."))
+        return(eventdata)
+      })
+
+      group_data <- shiny::reactive({
+        shiny::req("group_description" %in% colnames(distplot_data()))
+        distplot_data() %>%
+          dplyr::select("group", "description" = "group_description") %>%
+          dplyr::distinct()
+      })
+
+      plotly_server(
+        "distplot",
+        plot_data = distplot_data,
+        group_data = group_data,
+        eventdata = distplot_eventdata
+      )
+
+      drilldown_histogram_server(
+        "histogram",
+        plot_data = distplot_data,
+        eventdata = distplot_eventdata,
+        x_lab = "test_feature"
+      )
+
+      output$display_drilldown_ui <- shiny::reactive({
+        drilldown()
+      })
+
+      shiny::outputOptions(
+        output,
+        "display_drilldown_ui",
+        suspendWhenHidden = FALSE
+      )
+    }
+  )
+}

R/distributions_plot_server_functions.R

@@ -0,0 +1,50 @@
+get_distributions_feature_classes <- function(features){
+  if(is.null(features)){
+    return(character(0))
+  } else {
+    features %>%
+      colnames() %>%
+      setdiff(c("feature_name", "feature_display")) %>%
+      return()
+  }
+}
+
+
+get_distributions_feature_list <- function(
+  features,
+  feature_class_choice,
+  display_feature_class_selection_ui
+  ){
+
+  if(display_feature_class_selection_ui){
+    tbl <- features %>%
+      dplyr::select(
+        "feature_class" = feature_class_choice,
+        "feature_display",
+        "feature_name"
+      )
+  } else {
+    tbl <- features %>%
+      dplyr::select(
+        "feature_class",
+        "feature_display",
+        "feature_name"
+      )
+  }
+  create_nested_named_list(tbl)
+}
+
+create_distplot_data <- function(
+  plot_data_function,
+  feature_choice,
+  scale_method_choice,
+  reorder_method_choice
+  ){
+  data <-
+    plot_data_function(.feature = feature_choice) %>%
+    scale_tbl_value_column(scale_method_choice) %>%
+    reafctor_by_tbl_value_column(reorder_method_choice) %>%
+    dplyr::select(dplyr::any_of(
+      c("sample", "feature", "feature_value", "group", "group_description")
+    ))
+}