diff --git a/R/mod_create_polygon.R b/R/mod_create_polygon.R new file mode 100644 index 0000000..3d168ad --- /dev/null +++ b/R/mod_create_polygon.R @@ -0,0 +1,108 @@ +createpolygonUI <- function(id) { + ns <- NS(id) + tagList( + shiny::plotOutput(ns('polygon_new')), + DT::DTOutput(ns('polyinfo')) + ) +} + +createpolygonServer <- function(id, + map_draw_new_feature) { + moduleServer( + id, + function(input, output, session) { + + + polygon_sf <- shiny::reactive({ + + # coordinates new polygon + coords <- map_draw_new_feature()$geometry$coordinates + coords_matrix <- sapply(coords[[1]], unlist) + + # convert the polygon to sf + polygon <- sf::st_polygon(list(t(coords_matrix))) + polygon_sf <- sf::st_sfc(polygon, crs = 4326) + polygon_sf |> + sf::st_transform(3857) # meters + }) + + + # Table with HYDROlakeDB lake clicked data + output$polyinfo <- DT::renderDT({ + if (!is.null(map_draw_new_feature())) { + poly_4326 <- polygon_sf() |> + sf::st_transform(4326) + + bbox <- sf::st_bbox(poly_4326) + + area <- sf::st_area(polygon_sf()) + area <- units::set_units(area, + km ^ 2) + + perimeter <- sf::st_length(st_boundary(polygon_sf())) + perimeter <- units::set_units(perimeter, + km) + + + datap <- t(data.frame( + c('Min Latitude', + round(bbox$xmin, + digit = 2)), + c('Max Latitude', + round(bbox$xmax, + digit = 2)), + c('Min Longitude', + round(bbox$ymin, + digit = 2)), + c('Max Longitude', + round(bbox$ymax, + digit = 2)), + c(paste0('Area (km^2)'), + round(area, + digits = 2)), + c( + paste0('Shore length (km)'), + round(perimeter, + digits = 2) + ) + )) + + colnames(datap) <- NULL + + DT::datatable( + datap, + rownames = FALSE, + options = list(ordering = FALSE, + dom = 't'), + # remove table interactive default options + colnames = rep("", ncol(datap)) + ) # remove column names + + } + + }) + + + output$polygon_new <- shiny::renderPlot({ + # Message + shiny::validate(shiny::need( + !is.null(map_draw_new_feature()), + "Please, create a polygon in the map" + )) + + + # plot recently created polygon + ggplot2::ggplot() + + ggplot2::geom_sf(data = polygon_sf(), + fill = 'aliceblue', + lwd = 0.5) + + ggplot2::theme_void() + + }) + return(list(polygon_sf = reactive({ + polygon_sf() + })) + ) + } + ) +} \ No newline at end of file diff --git a/R/mod_hydrolakes.R b/R/mod_hydrolakes.R new file mode 100644 index 0000000..9954a99 --- /dev/null +++ b/R/mod_hydrolakes.R @@ -0,0 +1,185 @@ +hydrolakesUI <- function(id) { + ns <- NS(id) + tagList( + shiny::plotOutput(ns('hydrolake'), + height = 190), + DT::DTOutput(ns('lakeinfo')), + shiny::textOutput('dist', + inline = TRUE), + shiny::textOutput(ns('countryinfo')), + shiny::plotOutput(ns('country'), + height = 190) + ) +} + +hydrolakesServer <- function(id, + countries_sf, + r_lake_data, + map_shape_click, + r_neosites_data) { + moduleServer( + id, + function(input, output, session) { + + # Select HYDROlakeDB polygon when clicking the map + lk_click <- eventReactive(map_shape_click(), { + lake_data_4326 <- r_lake_data() |> + sf::st_transform(4326) + + if (!is.null(map_shape_click()$id)) { + # convert hover coordinates in a sfc point + p <- + sf::st_sfc(sf::st_point( + x = c( + map_shape_click()$lng, + map_shape_click()$lat + ), + dim = "XY" + ), + crs = 4326) + + # detect detect polygon hovered by the user + lake_data_4326[sf::st_intersects(lake_data_4326, + p, + sparse = FALSE), ] + + }} + ) + mc_text <- eventReactive(lk_click(),{ + + mc_neosites_data <- neosites_data() |> + sf::st_transform(4326) + + if(!is.null(mapvalues$map_shape_click())){ + mc_lk_click <- lk_click$df |> + sf::st_transform(4326) + + paste0("Distance within the site: ", + round((sf::st_distance(mc_lk_click, + mc_neosites_data))/1000, + digits = 2), + ' km') } + + }) + + # Hydrolake clicked distance to NeotomaDB selected point + output$dist <- shiny::renderText({ + + # Message if there is no click on a lake + shiny::validate( + shiny::need(!is.null(map_shape_click()), + "Please, click one of the HYDROlakes in the map") + ) + mc_text() + + }) + + + + # Display plot clicked on the right sidebar + output$hydrolake <- shiny::renderPlot({ + shiny::req(r_neosites_data()) + + lake_data <- r_lake_data() |> + sf::st_transform(4326) + + countries_sf <- countries_sf |> + sf::st_transform(4326) + + if (!is.null(map_shape_click()$id)) { + # plot polygon of lake of interest + ggplot2::ggplot() + + ggplot2::geom_sf(data = lk_click(), + fill = 'aliceblue', + lwd = 0.5) + + ggplot2::theme_void() + + ggplot2::ggtitle(paste(as.character(lk_click()$Lake_name))) + + ggplot2::theme(text = ggplot2::element_text(size = 15)) + + } + }) + + # Table with HYDROlakeDB lake clicked data + output$lakeinfo <- DT::renderDT({ + if (!is.null(map_shape_click())) { + datalk <- t(data.frame( + c('Hylak_id', + lk_click()$Hylak_id), + c('Elevation (masl)', + lk_click()$Elevation), + c('Shore length (km)', + lk_click()$Shore_len), + c('Lake area (km^2)', + lk_click()$Lake_area), + c('Volume total (mcm)', + lk_click()$Vol_total), + c('Depth average (m)', + lk_click()$Depth_avg) + )) + + colnames(datalk) <- NULL + + DT::datatable( + datalk, + rownames = FALSE, + options = list(ordering = FALSE, + dom = 't'), + # remove table interactive default options + colnames = rep("", ncol(datalk)) + ) # remove column names + + } + + }) + + # Map of the country where the lake is placed + output$country <- shiny::renderPlot({ + shiny::req(map_shape_click()$id) + + if (!is.null(map_shape_click()$id)) { + + csf <- countries_sf |> + sf::st_transform(4326) |> + dplyr::filter(COUNTRY == lk_click()$COUNTRY) + + # plot polygon of lake of interest + world <- rnaturalearth::ne_countries(scale = 'small', + returnclass = "sf") + + ggplot2::ggplot() + + ggplot2::geom_sf(data = world, + fill = 'antiquewhite') + + ggplot2::geom_sf(data = csf, + fill = '#A5243D', + lwd = 0.5) + + ggplot2::theme_void() + + ggplot2::coord_sf(crs = "+proj=moll") + + ggplot2::theme( + panel.grid.major = ggplot2::element_line( + color = gray(.5), + linetype = 'dashed', + linewidth = 0.5 + ) + ) + + } + }) + + + # Add country name + output$countryinfo <- shiny::renderText({ + shiny::req(map_shape_click()$id) + + if (!is.null(map_shape_click()$id)) { + csf <- countries_sf |> + dplyr::filter(COUNTRY == lk_click()$COUNTRY) + + paste("Country:", as.character(lk_click()$COUNTRY)) + + } + }) + + return(list(lk_click = reactive({ lk_click() }))) + } + ) +} \ No newline at end of file diff --git a/R/mod_map.R b/R/mod_map.R new file mode 100644 index 0000000..1cd01c3 --- /dev/null +++ b/R/mod_map.R @@ -0,0 +1,157 @@ +leafletmapUI <- function(id) { + ns <- NS(id) + tagList( + shinycssloaders::withSpinner( + leaflet::leafletOutput(ns('map'), + height = 620), + type = 2, + color = '#1b3964', + color.background = 'white' + ) + ) +} + +leafletmapServer <- function(id, + r_neosites_data, + r_lake_data, + modify, + nooptions, + removelakes) { + moduleServer(id, + function(input, output, session) { + # Map + output$map <- leaflet::renderLeaflet({ + print('nsd') + print(r_neosites_data()) + # Creation of a basic map + lm <- leaflet::leaflet() |> + leaflet::addTiles(group = "OpenStreetMap") |> + leaflet::addProviderTiles( + "Esri.WorldImagery", + group = "Esri.WorldImagery", + options = leaflet::providerTileOptions( + attribution = paste( + 'Tiles', + '© Esri — Source: Esri, i-cubed, USDA, USGS,', + 'AEX, GeoEye, Getmapping, Aerogrid, IGN, IGP, UPR-EGP,', + 'and the GIS User Community - Powered by Esri' + ) + ) + ) |> + leaflet::addLayersControl( + baseGroups = c("EsriWorldImagery", + "OpenStreetMap"), + options = leaflet::layersControlOptions(collapsed = FALSE) + ) |> + leaflet::addMeasure(primaryLengthUnit = "kilometers", + secondaryLengthUnit = "kilometers") + + + neosites_data = r_neosites_data() |> + sf::st_transform(4326) + lake_data = r_lake_data() |> + sf::st_transform(4326) + + # To zoom in the map + bbx = sf::st_bbox(sf::st_union(neosites_data, + lake_data)) + + # The NeotomaDB site could be a point or a polygon + if (sf::st_is(neosites_data, "POINT")) { + lm <- lm |> + leaflet::addPolygons( + data = lake_data, + group = 'lakes', + layerId = ~ Hylak_id, + # https://rstudio.github.io/leaflet/showhide.html + weight = 5, + color = "blue", + fillColor = "lightblue" + ) |> # hydrolakes + leaflet::addMarkers(data = neosites_data) |> # neotoma sites + leaflet::fitBounds( + lng1 = bbx$xmin[[1]], + lat1 = bbx$ymin[[1]], + lng2 = bbx$xmax[[1]], + lat2 = bbx$ymax[[1]] + ) |> + leafem::addMouseCoordinates() + + } else{ + lm <- lm |> + leaflet::addPolygons( + data = r_lake_data(), + group = 'lakes', + layerId = ~ Hylak_id, + # https://rstudio.github.io/leaflet/showhide.html + weight = 5, + color = "blue", + fillColor = "lightblue" + ) |> # hydrolakes + leaflet::addPolygons( + data = neosites_data(), + weight = 5, + color = "#A5243D", + fillColor = "pink" + ) |> # neotoma sites + leaflet::fitBounds( + lng1 = bbx$xmin[[1]], + lat1 = bbx$ymin[[1]], + lng2 = bbx$xmax[[1]], + lat2 = bbx$ymax[[1]] + ) |> + leafem::addMouseCoordinates() + } + + # Add toolbar to draw polygons if this is requested by the user + if (!is.null(nooptions()) && + nooptions() == "Create lake polygon") { + lm |> + leaflet.extras::addDrawToolbar( + markerOptions = FALSE, + circleMarkerOptions = FALSE, + polylineOptions = FALSE, + circleOptions = FALSE, + rectangleOptions = FALSE, + singleFeature = TRUE + ) + } else{ + lm + } + }) + + # The user can request to hide the lakes layer + shiny::observe({ + shiny::req(nooptions()) + + proxy <- leaflet::leafletProxy('map') + + if (modify() == 'No' && + nooptions() == "Create lake polygon") { + proxy |> leaflet::hideGroup('lakes') + } else{ + proxy |> leaflet::showGroup('lakes') + } + }) + + # The user can request to hide the lakes layer + shiny::observeEvent(removelakes(), { + proxy <- leaflet::leafletProxy('map') + + if (removelakes() == TRUE) { + proxy |> leaflet::hideGroup('lakes') + } else{ + proxy |> leaflet::showGroup('lakes') + } + }) + + return(list( + map_shape_click = reactive({ + input$map_shape_click + }), + map_draw_new_feature = reactive({ + input$map_draw_new_feature + }) + )) + }) +} \ No newline at end of file diff --git a/R/mod_metadata.R b/R/mod_metadata.R new file mode 100644 index 0000000..910dd21 --- /dev/null +++ b/R/mod_metadata.R @@ -0,0 +1,34 @@ +metadataUI <- function(id) { + ns <- NS(id) + tagList( + DT::DTOutput(ns('metadata')) + ) +} + +metadataServer <- function(id, + r_neosites_data) { + moduleServer( + id, + function(input, output, session) { + + # Sidebar table withe the NeotomaDB siteId metadata + output$metadata <- DT::renderDT({ + + name <- as.character(r_neosites_data()$sitename) + description <- as.character(r_neosites_data()$sitedescription) + notes <- as.character(r_neosites_data()$notes) + + data <- data.frame(c(description, + 'notes', notes)) + + colnames(data) <- as.character(name) + + DT::datatable(data, + rownames= FALSE, + options = list(dom = 't', + ordering = FALSE)) + + }) + } + ) +} \ No newline at end of file diff --git a/R/mod_options.R b/R/mod_options.R new file mode 100644 index 0000000..97ad2e9 --- /dev/null +++ b/R/mod_options.R @@ -0,0 +1,54 @@ +optionsUI <- function(id) { + ns <- NS(id) + tagList( + shinyWidgets::prettyRadioButtons( + inputId = ns("modify"), + label = "Is this site the correct lake polygon in NeotomaDB?", + choices = c("Yes", "No"), + selected = "Yes", + outline = TRUE, + plain = TRUE, + status = "primary", + icon = shiny::icon("check") + ), + shiny::uiOutput(ns('dynamicUI')) + ) + + +} + +optionsServer <- function(id) { + moduleServer(id, + function(input, output, session) { + ns <- session$ns + # Add radiobuttons if the user selects 'no' as option + output$dynamicUI <- shiny::renderUI({ + if (input$modify == "No") { + shinyWidgets::prettyRadioButtons( # or prettyRadioButtons + inputId = ns("nooptions"), + label = "How would you update NeotomaDB?", + choices = c("Replace with HYDROLakeDB" , + "Create lake polygon"), + outline = TRUE, + plain = TRUE, + status = "primary", + icon = shiny::icon("check")) + } else { + # If the option is not "Option 1", render an empty div + shiny::div() + } + }) + return(list(modify = reactive({ + input$modify + }), + nooptions = reactive({ + if (!is.null(input$nooptions)) + { + input$nooptions + } else{ + NULL + } + }) + )) + }) +} \ No newline at end of file diff --git a/R/mod_submit.R b/R/mod_submit.R new file mode 100644 index 0000000..50729ae --- /dev/null +++ b/R/mod_submit.R @@ -0,0 +1,86 @@ +# submitUI <- function(id) { +# ns <- NS(id) +# tagList(shiny::downloadButton(ns('submit'), 'Submit')) +# } +# +# submitServer <- function(id, +# r_neositeid, +# modify, +# nooptions, +# lk_click, +# notes, +# map_draw_new_feature, +# polygon_sf) { +# moduleServer(id, +# function(input, output, session) { +# # Subset of data to send in relation with user input +# data_submit <- shiny::reactive({ +# +# print('data') +# print(r_neositeid()) +# print(modify()) +# print(nooptions()) +# print(lk_click()) +# print(notes()) +# print(map_draw_new_feature()) +# print(polygon_sf()) +# +# if (modify() == 'Yes') { +# df <- data.frame('siteId' = r_neositeid(), +# 'comments' = notes()) +# print('df1') +# print(df) +# df +# +# } else if (modify() == "No" && +# nooptions() == "Replace with HYDROLakeDB") { +# df <- data.frame( +# 'siteId' = r_neositeid(), +# 'HYDROlake_id' = lk_click()$Hylak_id, +# 'comments' = notes() +# ) +# print('df2') +# print(df) +# df +# +# } else if (modify() == "No" && +# nooptions() == "Create lake polygon") { +# if (!is.null(map_draw_new_feature())) { +# polygon_sf() +# } +# +# df <- data.frame('siteId' = r_neositeid(), +# 'comments' = notes()) +# print('df3') +# print(df) +# sf::st_sf(df, geometry = polygon_sf()) +# +# } +# }) +# +# # Save user selections as csv +# output$submit <- shiny::downloadHandler( +# filename = function() { +# paste0("lake_", +# r_neositeid(), +# ".csv") +# }, +# content = function(fname) { +# print('data_submit()') +# req(data_submit()) +# print(data_submit()) +# if (modify() == 'Yes') { +# write.csv(data_submit(), fname) +# } else if (modify() == 'No' && +# nooptions() == 'Create lake polygon'){ +# sf::st_write(data_submit(), +# fname, +# layer_options = "GEOMETRY=AS_WKT") +# } else{ +# write.csv(data_submit(), fname) +# } +# } +# ) +# return(submit = reactive({input$submit})) +# }) +# } \ No newline at end of file diff --git a/R/mod_user_decisions.R b/R/mod_user_decisions.R new file mode 100644 index 0000000..19945b3 --- /dev/null +++ b/R/mod_user_decisions.R @@ -0,0 +1,122 @@ +userdecisionsUI <- function(id) { + ns <- NS(id) + tagList(shiny::textOutput(ns('action')), + shiny::tags$div(shiny::textAreaInput(ns('notes'), + label = 'Comments:')), + shiny::downloadButton(ns('submit'), 'Submit')) +} + +userdecisionsServer <- function(id, + modify, + nooptions, + neositeid, + map_draw_new_feature, + map_shape_click, + lk_click, + polygon_sf) { + moduleServer(id, + function(input, output, session) { + + # Display user comments in the screen + output$notes <- shiny::renderText({ + input$notes + }) + + # Text + output$action <- shiny::renderText({ + if (modify() == 'Yes') { + paste("The NeotomaDB site", + neositeid(), + "is correct and don't need to be replaced") + } else if (nooptions() == "Replace with HYDROLakeDB") { + # Message + shiny::validate(shiny::need( + !is.null(map_shape_click()), + "Please, click one of the HYDROlakes in the map" + )) + + paste( + "The NeotomaDB site", + neositeid(), + "should be replaced with the HYDROLakeDB", + lk_click()$Hylak_id + ) + + } else{ + # Message + shiny::validate(shiny::need( + !is.null(map_draw_new_feature()), + "Please, create a polygon in the map" + )) + + + paste( + "The NeotomaDB site", + neositeid(), + "can be replaced with the polygon that I am submitting" + ) + } + + }) + + # SUBMIT + data_submit <- shiny::reactive({ + if (modify() == 'Yes') { + df <- data.frame('siteId' = neositeid(), + 'comments' = input$notes) + + df + + } else if (modify() == "No" && + nooptions() == "Replace with HYDROLakeDB") { + df <- data.frame( + 'siteId' = neositeid(), + 'HYDROlake_id' = lk_click()$Hylak_id, + 'comments' = input$notes + ) + + df + + } else if (modify() == "No" && + nooptions() == "Create lake polygon") { + if (!is.null(map_draw_new_feature())) { + + st_as_sf(polygon_sf()) + + + df <- data.frame('siteId' = neositeid(), + 'comments' = input$notes) + polydata <- sf::st_sf(df, + geometry = polygon_sf()) + + polydata } + + } + }) + + # Save user selections as csv + output$submit <- shiny::downloadHandler( + filename = function() { + paste0("lake_", + neositeid(), + ".csv") + }, + content = function(fname) { + + if (modify() == 'Yes') { + write.csv(data_submit(), fname) + + } else if (modify() == 'No' && + nooptions() == 'Create lake polygon') { + + sf::st_write(data_submit(), fname, + layer_options = "GEOMETRY=AS_WKT") + + } else{ + + write.csv(data_submit(), fname) + + } + } + ) +} )} \ No newline at end of file diff --git a/app.R b/app.R index 1e1f103..3a05830 100644 --- a/app.R +++ b/app.R @@ -23,8 +23,10 @@ sf::sf_use_s2(FALSE) # Read data # Countries -countries_sf <- st_read('data/countries.gpkg') |> st_transform(3857) |> - st_simplify(preserveTopology = TRUE, dTolerance=100) +countries_sf <- st_read('data/countries.gpkg') |> + st_transform(3857) |> + st_simplify(preserveTopology = TRUE, + dTolerance=100) # Lakes lakes_country <- st_read("data/lakes_country.gpkg") |> @@ -34,7 +36,7 @@ lakes_country <- st_read("data/lakes_country.gpkg") |> sites_country <- st_read("data/sites_country.gpkg") -# Links +# Links for navbar link_neotoma <- tags$a(shiny::icon("github"), "GitHub", href = "https://github.com/NeotomaDB", @@ -44,105 +46,6 @@ link_slack <- tags$a(shiny::icon("slack"), href = "https://neotomadb.slack.com/ssb/redirect", target = "_blank") - - -# UI -# accordion_left -accordion_left <- bslib::accordion( - open = 'User options', - multiple = TRUE, - height="100%", - id = 'sidebar_accordion', - bslib::accordion_panel( - id = 'Site metadata', - title = 'Site metadata', - DT::DTOutput('metadata')), - bslib::accordion_panel( - id = 'Map options', - title = 'Map options', - shinyWidgets::materialSwitch( - inputId = "removelakes", - label = "remove HYDROlakes layer", - status = "primary" - )), - bslib::accordion_panel( - id = 'User options', - title = 'User options', - shinyWidgets::prettyRadioButtons( - inputId = "modify", - label = "Is this site the correct lake polygon in NeotomaDB?", - choices = c("Yes", "No"), - outline = TRUE, - plain = TRUE, - status = "primary", - icon = shiny::icon("check") - ), - shiny::uiOutput('dynamicUI') - )) - -# accordion_center -accordion_center <- bslib::accordion( - id = 'map_accordion', - open = 'How to use this app?', - height="100%", - bslib::accordion_panel( - id = "Map", - title = "Map of the site area", - class = 'p-0', - shinycssloaders::withSpinner( - leaflet::leafletOutput('map', - height = 620), - type = 2, - color = '#1b3964', - color.background = 'white')), - bslib::accordion_panel( - id = "Comments", - title = "User decision", - bslib::layout_columns( - shiny::textOutput('action'), - shiny::tags$div( - shiny::textAreaInput('notes', - label = 'Comments:'), - shiny::downloadButton('submit', 'Submit')))), - bslib::accordion_panel( - id = "help", - title = "How to use this app?", - shiny::tags$img(src = "img-app.png", - height = 'auto', - width = '100%'), - shiny::includeMarkdown("help.md"), - shiny::tags$img(src = "img-app-end.png", - height = 'auto', - width = '100%'))) - -# accordion_right -accordion_right <- bslib::accordion( - id = "lakes_or_polygons", - height="100%", - open = FALSE, - bslib::accordion_panel( - id = "lakes", - title = "Hydrolakes DB", - - shiny::plotOutput('hydrolake', - height = 190), - DT::DTOutput('lakeinfo'), - shiny::textOutput('dist', - inline = TRUE), - shiny::textOutput('countryinfo'), - shiny::plotOutput('country', - height = 190) - - ), - bslib::accordion_panel( - id = "polygon", - title = "Polygon" , - shiny::plotOutput('polygon_new'), - DT::DTOutput('polyinfo'), - - )) - - # UI ui = bslib::page_navbar( title = "NeotomaDB", @@ -173,9 +76,80 @@ ui = bslib::page_navbar( paste("Check sitesid in the webpage.", "For this demo you can use site 9606", "as an example")), - accordion_left), - accordion_center), - accordion_right)), + bslib::accordion( + id = 'sidebar_accordion', + open = 'User options', + multiple = TRUE, + height = "100%", + bslib::accordion_panel(id = 'Site metadata', + title = 'Site metadata', + metadataUI('mod_metadata')), + bslib::accordion_panel( + id = 'Map options', + title = 'Map options', + shinyWidgets::materialSwitch( + inputId = "removelakes", + label = "remove HYDROlakes layer", + status = "primary" + ) + ), + bslib::accordion_panel( + id = 'User options', + title = 'User options', + optionsUI('mod_options') + )) + ), # accordion right / sidebar + bslib::accordion( + id = 'map_accordion', + open = 'How to use this app?', + height = "100%", + bslib::accordion_panel( + id = "Map", + title = "Map of the site area", + class = 'p-0', + leafletmapUI('mod_map') + ), + bslib::accordion_panel( + id = "Comments", + title = "User decision", + bslib::layout_columns( + userdecisionsUI('mod_user_decisions')#, + # submitUI('mod_submit') + )), + bslib::accordion_panel( + id = "help", + title = "How to use this app?", + shiny::tags$img( + src = "img-app.png", + height = 'auto', + width = '100%' + ), + shiny::includeMarkdown("help.md"), + shiny::tags$img( + src = "img-app-end.png", + height = 'auto', + width = '100%' + ) + ) + ) # closes accordion center + ), # closes layout sidebar + bslib::accordion( + id = "lakes_or_polygons", + height = "100%", + open = FALSE, + bslib::accordion_panel( + id = "lakes", + title = "Hydrolakes DB", + hydrolakesUI('mod_hydrolakes') + ), + bslib::accordion_panel( + id = "polygon", + title = "Polygon", + createpolygonUI('mod_create_polygon') + ) + ) # closes accordion right + ) #layout columns + ), #navbar bslib::nav_spacer(), bslib::nav_menu( title = "Links", @@ -186,28 +160,16 @@ ui = bslib::page_navbar( server = function(input, output, session) { - - shiny::observeEvent(input$search, { - shinyFeedback::hideFeedback("neositeid") - - if (!(input$neositeid %in% unique(sites_country$siteid))){ - - shinyFeedback::feedbackDanger( - inputId = "neositeid", - show = TRUE, - text = "Please select a valid siteId" - )} - }) # Select site from the database neosites_data <- shiny::eventReactive(input$search,{ - - sites_country |> + neosites_data <- sites_country |> dplyr::mutate(siteid = as.character(siteid)) |> dplyr::filter(siteid %in% as.character(input$neositeid)) |> sf::st_transform(3857) - + return(neosites_data) }) + # Keep the closest lakes (50 km) to NeotomaDb selected point/polygon lake_data <- shiny::eventReactive(input$search,{ @@ -219,119 +181,62 @@ server = function(input, output, session) { }) - # Map - output$map <- leaflet::renderLeaflet({ - - # Creation of a basic map - lm <- leaflet::leaflet() |> - leaflet::addTiles(group = "OpenStreetMap") |> - leaflet::addProviderTiles("Esri.WorldImagery", - group = "Esri.WorldImagery", - options = leaflet::providerTileOptions(attribution = paste( - 'Tiles', - '© Esri — Source: Esri, i-cubed, USDA, USGS,', - 'AEX, GeoEye, Getmapping, Aerogrid, IGN, IGP, UPR-EGP,', - 'and the GIS User Community - Powered by Esri'))) |> - leaflet::addLayersControl( - baseGroups = c("EsriWorldImagery", - "OpenStreetMap"), - options = leaflet::layersControlOptions(collapsed = FALSE) - ) |> - leaflet::addMeasure(primaryLengthUnit="kilometers", - secondaryLengthUnit="kilometers") - - - neosites_data = neosites_data() |> - sf::st_transform(4326) - lake_data = lake_data() |> - sf::st_transform(4326) - - # To zoom in the map - bbx = sf::st_bbox(sf::st_union(neosites_data, - lake_data)) - - # The NeotomaDB site could be a point or a polygon - if(sf::st_is(neosites_data(), "POINT")){ - - lm <- lm |> - leaflet::addPolygons(data = lake_data, - group = 'lakes', - layerId = ~Hylak_id, # https://rstudio.github.io/leaflet/showhide.html - weight = 5, - color = "blue", - fillColor = "lightblue") |> # hydrolakes - leaflet::addMarkers(data = neosites_data) |> # neotoma sites - leaflet::fitBounds(lng1 = bbx$xmin[[1]], - lat1= bbx$ymin[[1]], - lng2 = bbx$xmax[[1]], - lat2 = bbx$ymax[[1]]) |> - leafem::addMouseCoordinates() - - }else{ - - lm <- lm |> - leaflet::addPolygons(data = lake_data, - group = 'lakes', - layerId = ~Hylak_id, # https://rstudio.github.io/leaflet/showhide.html - weight = 5, - color = "blue", - fillColor = "lightblue") |> # hydrolakes - leaflet::addPolygons(data = neosites_data, - weight = 5, - color = "#A5243D", - fillColor = "pink") |> # neotoma sites - leaflet::fitBounds(lng1 = bbx$xmin[[1]], - lat1= bbx$ymin[[1]], - lng2 = bbx$xmax[[1]], - lat2 = bbx$ymax[[1]]) |> - leafem::addMouseCoordinates() - - } - - - # Add toolbar to draw polygons if this is requested by the user - if(!is.null(input$nooptions) && input$nooptions == "Create lake polygon"){ - - lm |> - leaflet.extras::addDrawToolbar(markerOptions = FALSE, - circleMarkerOptions = FALSE, - polylineOptions = FALSE, - circleOptions = FALSE, - rectangleOptions = FALSE, - singleFeature = TRUE) - - }else{ lm } - - }) + # left accordion + metadataServer('mod_metadata', + r_neosites_data = reactive({ neosites_data() }) ) + values <- optionsServer('mod_options') - # The user can request to hide the lakes layer - shiny::observeEvent(input$removelakes, { - proxy <- leaflet::leafletProxy('map') + # central accordion + mapvalues <- leafletmapServer('mod_map', + r_neosites_data = reactive({ neosites_data() }), + r_lake_data = reactive({ lake_data() }), + nooptions = values$nooptions, + modify = values$modify, + removelakes = reactive({ input$removelakes }) ) - if(input$removelakes == TRUE){ - proxy |> leaflet::hideGroup('lakes') - }else{ - proxy |> leaflet::showGroup('lakes')} - } - ) + userdecisionsServer('mod_user_decisions', + neositeid = reactive({ input$neositeid }), + modify = values$modify, + nooptions = values$nooptions, + map_draw_new_feature = mapvalues$map_draw_new_feature, + map_shape_click = mapvalues$map_shape_click, + lk_click = hydrolakes$lk_click, + polygon_sf = newpolygon$polygon_sf) + # button <- submitServer('mod_submit', + # r_neositeid = reactive({ input$neositeid }), + # modify = values$modify, + # nooptions = values$nooptions, + # lk_click = hydrolakes$lk_click, + # notes = decision$notes, + # map_draw_new_feature = mapvalues$map_draw_new_feature, + # polygon_sf = newpolygon$polygon_sf) - # The user can request to hide the lakes layer - shiny::observe({ - shiny::req(input$nooptions) + # right accordion + hydrolakes <- hydrolakesServer('mod_hydrolakes', + countries_sf = countries_sf, + r_neosites_data = reactive({ neosites_data() }), + r_lake_data = reactive({ lake_data() }), + map_shape_click = mapvalues$map_shape_click + ) - proxy <- leaflet::leafletProxy('map') + newpolygon <- createpolygonServer('mod_create_polygon', + map_draw_new_feature = mapvalues$map_draw_new_feature) - if(input$modify == 'No' && - input$nooptions == "Create lake polygon"){ - proxy |> leaflet::hideGroup('lakes') + shiny::observeEvent(input$search, { + shinyFeedback::hideFeedback("neositeid") - }else{ - proxy |> leaflet::showGroup('lakes')}}) + if (!(input$neositeid %in% unique(sites_country$siteid))){ + shinyFeedback::feedbackDanger( + inputId = "neositeid", + show = TRUE, + text = "Please select a valid siteId" + )} + }) # Open the accordion metadata only once the user selects a siteid @@ -349,11 +254,9 @@ server = function(input, output, session) { bslib::accordion_panel_open(id = 'lakes_or_polygons', value = 'Hydrolakes DB') + } - } - - - if(input$modify == "No"){ + if(values$modify() == "No"){ # Open the accordion to complete and submit comments once they have selected # what they want to do with the siteid lake data bslib::accordion_panel_open(id = 'map_accordion', @@ -361,10 +264,10 @@ server = function(input, output, session) { shiny::observe({ - shiny::req(input$nooptions) + shiny::req(values$nooptions()) - if(input$modify == "No" && - input$nooptions == "Create lake polygon"){ + if(values$modify() == "No" && + values$nooptions() == "Create lake polygon"){ # Open the accordion when the user wants to create a polygon bslib::accordion_panel_close(id = 'lakes_or_polygons', @@ -372,400 +275,13 @@ server = function(input, output, session) { bslib::accordion_panel_open(id = 'lakes_or_polygons', value = 'Polygon') - }else if(input$modify == "No" && - input$nooptions == "Replace with HYDROLakeDB"){ + }else if(values$modify() == "No" && + values$nooptions() == "Replace with HYDROLakeDB"){ bslib::accordion_panel_close(id = 'lakes_or_polygons', value = 'Polygon') bslib::accordion_panel_open(id = 'lakes_or_polygons', value = 'Hydrolakes DB')} }) - - - - # Sidebar table withe the NeotomaDB siteId metadata - output$metadata <- DT::renderDT({ - - name <- as.character(neosites_data()$sitename) - description <- as.character(neosites_data()$sitedescription) - notes <- as.character(neosites_data()$notes) - - data <- data.frame(c(description, - 'notes', notes)) - - colnames(data) <- as.character(name) - - DT::datatable(data, - rownames= FALSE, - options = list(dom = 't', - ordering = FALSE)) - - }) - - # Add radiobuttons if the user selects 'no' as option - output$dynamicUI <- shiny::renderUI({ - if (input$modify == "No") { - shinyWidgets::prettyRadioButtons( # or prettyRadioButtons - inputId = "nooptions", - label = "How would you update NeotomaDB?", - choices = c("Replace with HYDROLakeDB" , - "Create lake polygon"), - outline = TRUE, - plain = TRUE, - status = "primary", - icon = shiny::icon("check")) - } else { - # If the option is not "Option 1", render an empty div - shiny::div() - } - }) - - # Select HYDROlakeDB polygon when clicking the map - lk_click <- shiny::reactive({ - - shiny::req(input$map_shape_click) - - lake_data = lake_data() |> - sf::st_transform(4326) - - if(!is.null(input$map_shape_click$id)){ - - # convert hover coordinates in a sfc point - p = sf::st_sfc(sf::st_point(x=c(input$map_shape_click$lng, - input$map_shape_click$lat), - dim="XY"), - crs = 4326) - - # detect detect polygon hovered by the user - lk_click <- lake_data[sf::st_intersects(lake_data, p, - sparse = FALSE),] - lk_click - - } - }) - - - # Display plot clicked on the right sidebar - output$hydrolake <- shiny::renderPlot({ - - shiny::req(input$search) - - lake_data <- lake_data() |> sf::st_transform(4326) - countries_sf |> sf::st_transform(4326) - - if(!is.null(input$map_shape_click$id)){ - - - # plot polygon of lake of interest - ggplot2::ggplot()+ - ggplot2::geom_sf(data = lk_click(), - fill = 'aliceblue', - lwd = 0.5)+ - ggplot2::theme_void() + - ggplot2::ggtitle(paste(as.character(lk_click()$Lake_name))) + - ggplot2::theme(text = ggplot2::element_text(size = 15)) - - } - }) - - - # Hydrolake clicked distance to NeotomaDB selected point - output$dist <- shiny::renderText({ - - shiny::req(input$search) - - # Message if there is no click on a lake - shiny::validate( - shiny::need(!is.null(input$map_shape_click), - "Please, click one of the HYDROlakes in the map") - ) - - neosites_data <- neosites_data() |> - sf::st_transform(4326) - lk_click = lk_click() |> - sf::st_transform(4326) - - paste0("Distance within the site: ", - round((sf::st_distance(lk_click, - neosites_data))/1000, - digits = 2), - ' km') - - }) - - # Table with HYDROlakeDB lake clicked data - output$lakeinfo <- DT::renderDT({ - - if(!is.null(input$map_shape_click)){ - - - datalk <- t(data.frame(c('Hylak_id', - lk_click()$Hylak_id), - c('Elevation (masl)', - lk_click()$Elevation), - c('Shore length (km)', - lk_click()$Shore_len), - c('Lake area (km^2)', - lk_click()$Lake_area), - c('Volume total (mcm)', - lk_click()$Vol_total), - c('Depth average (m)', - lk_click()$Depth_avg))) - - colnames(datalk) <- NULL - - DT::datatable(datalk, - rownames= FALSE, - options = list(ordering = FALSE, - dom = 't'), # remove table interactive default options - colnames = rep("", ncol(datalk))) # remove column names - - } - - }) - - - # Map of the country where the lake is placed - output$country <- shiny::renderPlot({ - - shiny::req(input$map_shape_click$id) - - countries_sf |> - sf::st_transform(4326) - - if(!is.null(input$map_shape_click$id)){ - - csf <- countries_sf |> - dplyr::filter(COUNTRY == lk_click()$COUNTRY) - - # plot polygon of lake of interest - world <- rnaturalearth::ne_countries(scale = 'small', - returnclass = "sf") - - ggplot2::ggplot() + - ggplot2::geom_sf(data = world, - fill= 'antiquewhite') + - ggplot2::geom_sf(data = csf, - fill = '#A5243D', - lwd = 0.5) + - ggplot2::theme_void() + - ggplot2::coord_sf(crs = "+proj=moll") + - ggplot2::theme(panel.grid.major = ggplot2::element_line(color = gray(.5), - linetype = 'dashed', - linewidth = 0.5)) - - } - }) - - - # Add country name - output$countryinfo <- shiny::renderText({ - - shiny::req(input$map_shape_click$id) - - if(!is.null(input$map_shape_click$id)){ - csf = countries_sf |> - dplyr::filter(COUNTRY == lk_click()$COUNTRY) - - paste("Country:", as.character(lk_click()$COUNTRY)) - - } - }) - - - # Display user comments in the screen - output$notes <- shiny::renderText({ input$notes }) - - # Text - output$action <- shiny::renderText({ - - - - if(input$modify == 'Yes'){ - - paste("The NeotomaDB site", - input$neositeid, "is correct and don't need to be replaced") - - }else if(input$nooptions == "Replace with HYDROLakeDB"){ - - - # Message - shiny::validate( - shiny::need(!is.null(input$map_shape_click), - "Please, click one of the HYDROlakes in the map") - ) - - paste("The NeotomaDB site", input$neositeid, - "should be replaced with the HYDROLakeDB", - lk_click()$Hylak_id) - - }else{ - - # Message - shiny::validate( - shiny::need(!is.null(input$map_draw_new_feature), - "Please, create a polygon in the map") - ) - - - paste("The NeotomaDB site", input$neositeid, - "can be replaced with the polygon that I am submitting") - } - - }) - - - polygon_sf <- shiny::reactive({ - - # coordinates new polygon - coords <- input$map_draw_new_feature$geometry$coordinates - coords_matrix <- sapply(coords[[1]], unlist) - - # convert the polygon to sf - polygon <- sf::st_polygon(list(t(coords_matrix))) - polygon_sf <- sf::st_sfc(polygon, crs = 4326) - polygon_sf |> - sf::st_transform(3857) # meters - }) - - - # Subset of data to send in relation with user input - data_submit <- shiny::reactive({ - - if(input$modify == 'Yes'){ - - data_submit <- data.frame('siteId' = input$neositeid, - 'comments' = input$notes) - - }else if(input$modify == "No" && - input$nooptions == "Replace with HYDROLakeDB"){ - - data_submit <- data.frame('siteId' = input$neositeid, - 'HYDROlake_id' = lk_click()$Hylak_id, - 'comments' = input$notes) - - }else if(input$modify == "No" && - input$nooptions == "Create lake polygon"){ - - - - if(!is.null(input$map_draw_new_feature)){ - - polygon_sf() - } - - - data_submit <- data.frame('siteId' = input$neositeid, - 'comments' = input$notes) - - poly_submit <- sf::st_sf(data_submit, geometry = polygon_sf()) - poly_submit - } - - - - }) - - - # Save user selections as csv - output$submit <- shiny::downloadHandler( - filename = function(){ - paste0("lake_", - input$neositeid, - ".csv")}, - content = function(fname){ - - - if(input$modify == 'Yes'){ - - write.csv(data_submit(), fname) - - }else if(input$modify == 'No' && - input$nooptions == 'Create lake polygon'){ - - - sf::st_write(data_submit(), fname, - layer_options = "GEOMETRY=AS_WKT") - - }else{ - - write.csv(data_submit(), fname) - - } - - } - ) - - - # Table with HYDROlakeDB lake clicked data - output$polyinfo <- DT::renderDT({ - - if(!is.null(input$map_draw_new_feature)){ - - poly_4326 <- polygon_sf() |> - sf::st_transform(4326) - - bbox <- sf::st_bbox(poly_4326) - - area <- sf::st_area(polygon_sf()) - area <- units::set_units(area, - km^2) - - perimeter <- sf::st_length(st_boundary(polygon_sf())) - perimeter <- units::set_units(perimeter, - km) - - - datap <- t(data.frame(c('Min Latitude', - round(bbox$xmin, - digit = 2)), - c('Max Latitude', - round(bbox$xmax, - digit = 2)), - c('Min Longitude', - round(bbox$ymin, - digit = 2)), - c('Max Longitude', - round(bbox$ymax, - digit = 2)), - c(paste0('Area (km^2)'), - round(area, - digits = 2)), - c(paste0('Shore length (km)'), - round(perimeter, - digits = 2)))) - - colnames(datap) <- NULL - - DT::datatable(datap, - rownames= FALSE, - options = list(ordering = FALSE, - dom = 't'), # remove table interactive default options - colnames = rep("", ncol(datap))) # remove column names - - } - - }) - - - output$polygon_new <- shiny::renderPlot({ - - # Message - shiny::validate( - shiny::need(!is.null(input$map_draw_new_feature), - "Please, create a polygon in the map") - ) - - - # plot recently created polygon - ggplot2::ggplot()+ - ggplot2::geom_sf(data = polygon_sf(), - fill = 'aliceblue', - lwd = 0.5)+ - ggplot2::theme_void() - - }) - - } shinyApp(ui, server) diff --git a/data-wrangling.qmd b/data-wrangling.qmd index ad59966..6a811df 100644 --- a/data-wrangling.qmd +++ b/data-wrangling.qmd @@ -7,7 +7,7 @@ format: html # NeotomaLakes app data wrangling ```{r echo = FALSE} -library(tidyverse) +library(tidyverse) #not a good idea for renv library(sf) ``` diff --git a/renv.lock b/renv.lock index 0ac3eac..4c292d0 100644 --- a/renv.lock +++ b/renv.lock @@ -1006,12 +1006,7 @@ "renv": { "Package": "renv", "Version": "1.0.3", - "Source": "Repository", - "Repository": "CRAN", - "Requirements": [ - "utils" - ], - "Hash": "41b847654f567341725473431dd0d5ab" + "Source": "Repository" }, "rlang": { "Package": "rlang", @@ -1253,6 +1248,11 @@ ], "Hash": "f39bb3c44a9b496723ec7e86f9a771d8" }, + "shinyjs": { + "Package": "shinyjs", + "Version": "2.1.0", + "Source": "Repository" + }, "sourcetools": { "Package": "sourcetools", "Version": "0.1.7-1", diff --git a/renv/activate.R b/renv/activate.R index cb5401f..a59fce4 100644 --- a/renv/activate.R +++ b/renv/activate.R @@ -31,6 +31,14 @@ local({ if (!is.null(override)) return(override) + # if we're being run in a context where R_LIBS is already set, + # don't load -- presumably we're being run as a sub-process and + # the parent process has already set up library paths for us + rcmd <- Sys.getenv("R_CMD", unset = NA) + rlibs <- Sys.getenv("R_LIBS", unset = NA) + if (!is.na(rlibs) && !is.na(rcmd)) + return(FALSE) + # next, check environment variables # TODO: prefer using the configuration one in the future envvars <- c( @@ -50,9 +58,22 @@ local({ }) - if (!enabled) + # bail if we're not enabled + if (!enabled) { + + # if we're not enabled, we might still need to manually load + # the user profile here + profile <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") + if (file.exists(profile)) { + cfg <- Sys.getenv("RENV_CONFIG_USER_PROFILE", unset = "TRUE") + if (tolower(cfg) %in% c("true", "t", "1")) + sys.source(profile, envir = globalenv()) + } + return(FALSE) + } + # avoid recursion if (identical(getOption("renv.autoloader.running"), TRUE)) { warning("ignoring recursive attempt to run renv autoloader") @@ -1041,7 +1062,7 @@ local({ # if jsonlite is loaded, use that instead if ("jsonlite" %in% loadedNamespaces()) { - json <- catch(renv_json_read_jsonlite(file, text)) + json <- tryCatch(renv_json_read_jsonlite(file, text), error = identity) if (!inherits(json, "error")) return(json) @@ -1050,7 +1071,7 @@ local({ } # otherwise, fall back to the default JSON reader - json <- catch(renv_json_read_default(file, text)) + json <- tryCatch(renv_json_read_default(file, text), error = identity) if (!inherits(json, "error")) return(json) @@ -1063,14 +1084,14 @@ local({ } renv_json_read_jsonlite <- function(file = NULL, text = NULL) { - text <- paste(text %||% read(file), collapse = "\n") + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") jsonlite::fromJSON(txt = text, simplifyVector = FALSE) } renv_json_read_default <- function(file = NULL, text = NULL) { # find strings in the JSON - text <- paste(text %||% read(file), collapse = "\n") + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' locs <- gregexpr(pattern, text, perl = TRUE)[[1]] @@ -1118,14 +1139,14 @@ local({ map <- as.list(map) # remap strings in object - remapped <- renv_json_remap(json, map) + remapped <- renv_json_read_remap(json, map) # evaluate eval(remapped, envir = baseenv()) } - renv_json_remap <- function(json, map) { + renv_json_read_remap <- function(json, map) { # fix names if (!is.null(names(json))) { @@ -1152,7 +1173,7 @@ local({ # recurse if (is.recursive(json)) { for (i in seq_along(json)) { - json[i] <- list(renv_json_remap(json[[i]], map)) + json[i] <- list(renv_json_read_remap(json[[i]], map)) } }