Merge pull request #109 from BioDT/95-prepare-wild-boar-disease

Prepare wild boar disease's main pDT page

app/logic/disease_outbreaks/disease_leaflet_map.R

@@ -0,0 +1,68 @@
+box::use(
+  terra[rast, project],
+  leaflet[tileOptions, leaflet, addTiles, addRasterImage, setView, addLayersControl, layersControlOptions, addControl, getMapData, addProviderTiles],
+)
+
+#' @export
+read_and_project_raster <- function(map_full_path) {
+  map_raster <- rast(map_full_path) |> project("epsg:3857")
+}
+
+#' @export
+disease_leaflet_map_basic <- function(map_raster,
+                                add_control = TRUE,
+                                main_map_features = TRUE) {
+  leaflet_map <- leaflet() |>
+    addTiles(group = "Default layer (OpenStreetMap)") |>
+    setView(
+      lng = 12.3601,
+      lat = 51.3402,
+      zoom = 5
+    ) |>
+    addRasterImage(
+      map_raster,
+      opacity = 0.5,
+      project = FALSE,
+      options = tileOptions(zIndex = 100),
+      group = "Input layer"
+    ) |>
+    addLayersControl(
+      baseGroups = c(
+        "Default layer (OpenStreetMap)"
+      ),
+      overlayGroups = c("Input layer"),
+      options = layersControlOptions(collapsed = FALSE)
+    )
+
+  return(leaflet_map)
+}
+
+# #' @export
+# disease_leaflet_with_output_layer <- function(map_output_id, input_raster, output_raster) {
+
+
+#     leafletProxy(map_output_id) |> # hint: leafletProxy, removeImage, addRasterLegend, addLegend,
+#       clearImages() |>
+#       clearControls() |>
+#       addRasterImage(
+#         input_raster,
+#         opacity = 0.5,
+#         project = FALSE,
+#         options = tileOptions(zIndex = 100),
+#         group = "Input layer",
+#         layerId = "inputLayer"
+#       ) |>
+#       addRasterImage(
+#         output_raster,
+#         opacity = 0.5,
+#         project = FALSE,
+#         options = tileOptions(zIndex = 101),
+#         group = "Output layer",
+#         layerId = "outputLayer"
+#       ) |>
+#       addLayersControl(
+#         overlayGroups = c("Input layer", "Output layer"),
+#         options = layersControlOptions(collapsed = FALSE)
+#       )
+# }
+

app/main.R

@@ -175,7 +175,7 @@ ui <- function(id) {
           nav_panel(
             title = i18n$translate("Disease Outbreaks"),
             class = "p-0",
-            disease_outbreaks_main_ui(ns("disease_outbreaks_main_ui"), i18n)
+            disease_outbreaks_main_ui(ns("disease_outbreaks_main"), i18n)
           )
         },
       ),
@@ -256,6 +256,8 @@ server <- function(id) {
       "ces_main"
     )
 
+    disease_outbreaks_main_server("disease_outbreaks_main")
+
     shiny$observeEvent(input$biodt_logo, {
       nav_select(
         id = "navbar",

app/view/disease_outbreaks/disease_app/disease_app.R

@@ -1,23 +1,17 @@
 box::use(
-  shiny[NS, tagList, moduleServer, tags],
+  shiny[NS, tagList, moduleServer, tags, reactiveVal, observeEvent],
   bslib[layout_column_wrap],
   htmltools[css],
+  waiter[Waiter],
+)
+
+box::use(
+  app / view / disease_outbreaks / disease_app / disease_map[disease_map_ui, disease_map_server],
+  app / view / disease_outbreaks / disease_app / disease_choose_file[disease_choose_file_ui, disease_choose_file_server],
+  app / logic / disease_outbreaks / disease_leaflet_map[read_and_project_raster, disease_leaflet_map_basic],
+  app / logic / waiter[waiter_text],
 )
 
-# box::use(
-#   app/view/grassland/grassland_dynamics/grassland_dynamics_inputmap[
-#     grassland_dynamics_inputmap_ui,
-#     grassland_dynamics_inputmap_server
-#   ],
-#   app/view/grassland/grassland_dynamics/grassland_dynamics_location[
-#     grassland_dynamics_location_ui,
-#     grassland_dynamics_location_server
-#   ],
-#   app/view/grassland/grassland_dynamics/grassland_dynamics_outputplot[
-#     grassland_dynamics_outputplot_ui,
-#     grassland_dynamics_outputplot_server
-#   ],
-# )
 
 #' @export
 disease_app_ui <- function(id, i18n) {
@@ -27,25 +21,61 @@ disease_app_ui <- function(id, i18n) {
       width = NULL,
       fill = FALSE,
       style = css(grid_template_columns = "3fr 1fr"),
-      tags$h3(i18n$translate("Input map")),
-      tags$h3(i18n$translate("Location")),
+      disease_map_ui(
+        ns("disease_map"), i18n
+      ),
+      disease_choose_file_ui(
+        ns("disease_select"), i18n
+      ),
     ),
     tags$h3(i18n$translate("Output Plot"))
   )
 }
 
 #' @export
-disease_app_server <- function(id, r) {
+disease_app_server <- function(id, tab_disease_selected) {
   moduleServer(id, function(input, output, session) {
+    # Define waiter ----
+    msg <- waiter_text(message = tags$h3("Loading data...",
+      style = "color: #414f2f;"
+    ))
+    w <- Waiter$new(
+      html = msg,
+      color = "rgba(256,256,256,0.9)"
+    )
+
     ns <- session$ns
+    # Variables ----
+    map <- reactiveVal()
+    leaflet_map <- reactiveVal()
+
+    new_tif_upload <- disease_choose_file_server("disease_select", tab_disease_selected())
+
+    observeEvent(tab_disease_selected(),
+      ignoreInit = TRUE,
+      {
+        w$show()
+        "app/data/disease_outbreak/Mosaic_final.tif" |>
+          read_and_project_raster() |>
+          map()
+
+        map() |>
+          disease_leaflet_map_basic(
+            add_control = TRUE,
+            main_map_features = TRUE
+          ) |>
+          leaflet_map()
 
-    # # LOCATION settings ----
-    # coordinates <- grassland_dynamics_location_server("location")
+        w$hide()
 
-    # # MAP itself ----
-    # grassland_dynamics_inputmap_server("inputmap", coordinates)
+      }
+    )
 
-    # # Output PLOT ----
-    # grassland_dynamics_outputplot_server("outputplot")
+    disease_map_server(
+      "disease_map",
+      map_original = map,
+      leaflet_map = leaflet_map,
+      new_tif_upload = new_tif_upload
+    )
   })
 }

app/view/disease_outbreaks/disease_app/disease_choose_file.R

@@ -0,0 +1,45 @@
+box::use(
+  shiny[moduleServer, NS, bootstrapPage, tags, observeEvent, reactiveVal, reactive, fileInput],
+  bslib[card, card_header, card_body],
+)
+
+#' @export
+disease_choose_file_ui <- function(id, theme, i18n) {
+  ns <- NS(id)
+  bootstrapPage(
+    theme = theme,
+    card(
+      class = "me-md-3 card-shadow overflow-hidden mt-2",
+      title = "select_map",
+      full_screen = FALSE,
+      card_header(
+        tags$h2(
+          class = "card_title",
+          "Upload a file with raster"
+        )
+      ),
+      card_body(
+        fileInput(ns("tif_file"), "Choose .tif file", accept = ".tif"),
+      ),
+    )
+  )
+}
+
+#' @export
+disease_choose_file_server <- function(id, tab_disease_selected) {
+  moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+    out <- reactiveVal(NULL)
+
+    observeEvent(
+      input$tif_file,
+      ignoreInit = TRUE,
+      ignoreNULL = TRUE,
+      {
+        out(input$tif_file$datapath)
+      }
+    )
+
+    reactive(out())
+  })
+}

app/view/disease_outbreaks/disease_app/disease_map.R

@@ -0,0 +1,73 @@
+box::use(
+  shiny[NS, moduleServer, tags, observeEvent, req],
+  bslib[card, card_header, card_body],
+  leaflet[leafletOutput, renderLeaflet, leafletProxy, addRasterImage, addLayersControl, layersControlOptions, tileOptions, clearControls, clearImages],
+)
+
+box::use(
+  app / logic / disease_outbreaks / disease_leaflet_map[read_and_project_raster]
+)
+
+#' @export
+disease_map_ui <- function(id, i18n) {
+  ns <- NS(id)
+  card(
+    id = ns("map_wrapper"),
+    class = "ms-md-3 card-shadow mt-2",
+    full_screen = TRUE,
+    card_header(
+      tags$h2(
+        class = "card_title",
+        i18n$translate("Map")
+      )
+    ),
+    card_body(
+      leafletOutput(
+        ns("map_output")
+      ),
+    ),
+  )
+}
+
+#' @export
+disease_map_server <- function(id, map_original, leaflet_map, new_tif_upload) {
+  moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+
+    observeEvent(leaflet_map(), {
+      req(leaflet_map())
+      output_map <- leaflet_map()
+      output$map_output <- renderLeaflet(output_map)
+    })
+
+    observeEvent(new_tif_upload(), {
+      new_tif_raster <- new_tif_upload() |>
+        read_and_project_raster()
+
+      req(new_tif_raster)
+      leafletProxy("map_output") |>
+        clearImages() |>
+        clearControls() |>
+        addRasterImage(
+          map_original(),
+          opacity = 0.5,
+          project = FALSE,
+          options = tileOptions(zIndex = 100),
+          group = "Input layer",
+          layerId = "inputLayer"
+        ) |>
+        addRasterImage(
+          new_tif_raster,
+          opacity = 0.5,
+          project = FALSE,
+          options = tileOptions(zIndex = 101),
+          group = "Output layer",
+          layerId = "outputLayer"
+        ) |>
+        addLayersControl(
+          overlayGroups = c("Input layer", "Output layer"),
+          options = layersControlOptions(collapsed = FALSE)
+        )
+    })
+  })
+}

app/view/disease_outbreaks/disease_contributors.R

@@ -0,0 +1,43 @@
+box::use(
+  shiny[moduleServer, NS, tagList, div, column, tags, fluidRow, icon],
+)
+
+#' @export
+disease_contributors_ui <- function(id, i18n) { # nolint
+  ns <- NS(id)
+  fluidRow(
+    class = "align-items-center justify-content-center m-0 p-0",
+    style = "overflow-x: hidden",
+    column(
+      width = 6,
+      class = "col-sm-12 col-lg-6",
+      style = "height: 100vh;",
+      tags$div(
+        class = "col-sm-10 offset-sm-1 text-center mt-5",
+        tags$h2(i18n$translate("CONTRIBUTORS"),
+          style = "greeting display-4 font-weight-bold"
+        ),
+        tags$p("TO BE ADDED"),
+      )
+    ),
+    column(
+      width = 6,
+      style = "height: 100vh;",
+      class = "d-none d-lg-block m-0 p-0",
+      tags$div(
+        tags$img(
+          class = "info-picture",
+          src = "static/img/Alexis-Lours-Sus-scrofa-Linnaeus.gif",
+          alt = "Video of wild boar pack",
+        )
+      )
+    )
+  )
+}
+
+#' @export
+disease_contributors_server <- function(id, r) { # nolint
+  moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+  })
+}