Thanks for helping about my first question regarding this topic. I update and specify my question here: I try to build a shiny app that loads a map and an empty data frame with three previously defined attributes as table headers. The user should then draw a first rectangle on the map. The rectangle (leafletID) should appear in the table and the user must edit the attributes accordingly and not be allowed to draw a further rectangle until he confirmed the edited attributes. As soon as confirmed, the user might draw a second rectangle and so on. The app does not need to have a add column or specific zoom funtions. Finally, the user might want to adjust some attributes of one or the other rectangle or even delete a rectangle (line).
Based on the very useful mapedit package and the function editAttributes of the dev version. I created a small running app. However the functionalities as described are not implemented since I struggled to do so. Thankful for any hints or suggestion to make this running.
library(shiny)
library(leaflet)
library(mapedit)
library(sf)
library(dplyr)
library(rgee)
library(DT)
library(shinycssloaders)
library(leafem)
library(leafpop)
dat <- data.frame(ES_value = 'CHANGE ME',confidence="how confident are you?", comments = 'ADD COMMENTS...')
original_sf <- NULL
APP_CRS <- 4326
dat <- dat %>% mutate(leaf_id = 1:nrow(dat))
data_copy <- sf::st_as_sf(
dat,
geometry = sf::st_sfc(lapply(seq_len(nrow(dat)),function(i){sf::st_point()}))
) %>% sf::st_set_crs(APP_CRS)
ui<-mainPanel(actionButton("donebtn", "Done"),
actionButton('row_add', 'new poly'),
editModUI("map_training"),
DTOutput(
"tbl"
))
server <- function(input, output, session) {
df <- shiny::reactiveValues(types = sapply(dat, class),
data = data_copy)
shiny::observe({
training_pol <- callModule(
module = editMod,
leafmap = mapview::mapview(map.types = "CartoDB.Positron")@map %>%
leafem::addFeatures(data = df$data,
layerId = df$data$leaf_id,
group = 'editLayer',
popup = leafpop::popupTable(df$data)),
id = "map_training",
sf = T,
editorOptions = list(editOptions = leaflet.extras::editToolbarOptions(edit = TRUE)),
)
})
#make a proxy map
proxy_map <- leaflet::leafletProxy('map-map', session)
# render new row form based on the existing data structure
shiny::observe({
output$dyn_form <- shiny::renderUI({
shiny::tagList(
lapply(1:length(df$types), function(n){
name <- names(df$types[n])
label <- paste0(names(df$types[n]), ' (', df$types[n], ')')
if (df$types[n] == 'character') {
shiny::textInput(name, label, width = '100%')
} else if (df$types[n] == 'factor') {
shiny::selectInput(name, label, width = '100%',
choices = levels(dat[[names(df$types[n])]]),
selected = NULL,
selectize = TRUE)
} else if (df$types[n] %in% c('numeric','integer')) {
shiny::numericInput(name, label, width = '100%', value = NA)
} else if (df$types[n] == 'Date') {
shiny::dateInput(name, label, width = '100%', value = NA)
}
}),
# we don't want to see this element but it is needed to form data structure
htmltools::tags$script("document.getElementById('leaf_id-label').hidden = true; document.getElementById('leaf_id').style.visibility = 'hidden';")
)
})
})
output$tbl <- DT::renderDataTable({
n <- grep('leaf_id|geom', colnames(df$data)) # used to hide geometry/leaf_id column
DT::datatable(
df$data,
options = list(scrollY="200px",
pageLength = 50,
scrollX = TRUE,
columnDefs = list(list(visible=FALSE, targets=n))),
# could support multi but do single for now
selection = "single",
height = 200,
editable = TRUE,
)
})
proxy = DT::dataTableProxy('tbl')
# modify namespace to get map ID
nsm <- function(event="", id="map") {
paste0(session$ns(id), "-", event)
}
EVT_DRAW <- "map_draw_new_feature"
EVT_EDIT <- "map_draw_edited_features"
EVT_DELETE <- "map_draw_deleted_features"
#create a vector input for 'row_add'
EVT_ADD_ROW <- "row_add"
# determines whether to use 'row_add' or 'map_draw_feature'
# also, if rows are selected then it won't trigger the 'map_draw_feature'
addRowOrDrawObserve <- function(event, id) {
shiny::observeEvent(
if(is.na(id)){
input[[event]]
} else {
input[[nsm(event, id = id)]]},{
if(!is.null(input$tbl_rows_selected)){
} else {
# creates first column and row (must be more elegant way)
new_row <- data.frame(X = input[[names(df$types[1])]])
colnames(new_row) <- names(df$types[1])
# remaining columns will be correct size
for (i in 2:length(df$types)) {
new_row[names(df$types[i])] <- input[[names(df$types[i])]]
}
new_row <- sf::st_as_sf(new_row, geometry = sf::st_sfc(sf::st_point()), crs = APP_CRS)
suppressWarnings({
# add to data_copy data.frame and update visible table
df$data <- df$data %>%
rbind(new_row)
})
# reset input table
if(isTRUE(reset)){
for (i in 1:length(df$types)) {
typ <- df$types[i]
nm <- names(typ)
if (typ == 'character') {
shiny::updateTextInput(session, nm, value = NA)
} else if (typ %in% c('numeric','integer')) {
shiny::updateNumericInput(session, nm, value = NA)
} else if (typ == 'Date') {
shiny::updateDateInput(session, nm, value = NA)
}
}
}
}
})
}
addRowOrDrawObserve(EVT_ADD_ROW, id = NA)
addRowOrDrawObserve(EVT_DRAW, id = 'map')
addDrawObserve <- function(event) {
shiny::observeEvent(
input[[nsm(event)]],
{
evt <- input[[nsm(event)]]
# this allows the user to edit geometries or delete and then save without selecting row.
# you can also select row and edit/delete as well but this gives the ability to not do so.
if(event == EVT_DELETE) {
ids <- vector()
for(i in 1:length(evt$features)){
iter <- evt$features[[i]]$properties[['layerId']]
ids <- append(ids, iter)
}
df$data <- dplyr::filter(df$data, !df$data$leaf_id %in% ids)
df$ids <- ids
} else if (event == EVT_EDIT) {
for(i in 1:length(evt$features)){
evt_type <- evt$features[[i]]$geometry$type
leaf_id <- evt$features[[i]]$properties[['layerId']]
geom <- unlist(evt$features[[i]]$geometry$coordinates)
if (evt_type == 'Point') {
sf::st_geometry(df$data[df$data$leaf_id %in% leaf_id,]) <- sf::st_sfc(sf::st_point(geom))
} else if (evt_type == 'Polygon'){
geom <- matrix(geom, ncol = 2, byrow = T)
sf::st_geometry(df$data[df$data$leaf_id %in% leaf_id,]) <- sf::st_sfc(sf::st_polygon(list(geom)))
} else if (evt_type == 'LineString'){
geom <- matrix(geom, ncol = 2, byrow = T)
sf::st_geometry(df$data[df$data$leaf_id %in% leaf_id,]) <- sf::st_sfc(sf::st_linestring(geom))
}
}
} else {
# below determines whether to use 'row_add' or 'map_draw_feature' for adding geometries
if(!is.null(input$tbl_rows_selected)) {
selected <- shiny::isolate(input$tbl_rows_selected)
} else if (event == EVT_DRAW){
selected <- length(input$tbl_rows_all) + 1
}
skip = FALSE
# ignore if selected is null
if(is.null(selected)) {skip = TRUE}
# replace if draw or edit
if(skip==FALSE) {
sf::st_geometry(df$data[selected,]) <- sf::st_geometry(
st_as_sfc.geo_list(evt))
#adding the leaf_id when we draw or row_add
df$data[selected, 'leaf_id'] <- as.integer(evt$properties[['_leaflet_id']])
}
}
})
}
# update table cells with double click on cell
shiny::observeEvent(input$tbl_cell_edit, {
df$data <- DT::editData(df$data, input$tbl_cell_edit, 'tbl', resetPaging = F)
DT::replaceData(proxy, df$data, rownames = FALSE, resetPaging = FALSE)
})
# provide mechanism to return after all done
shiny::observeEvent(input$donebtn, {
if (testing) shiny::stopApp()
if(grepl(class(df$data$geometry)[[1]], "sfc_GEOMETRY")){
if (any(sf::st_is_empty(df$data$geometry))) {
shinyWidgets::show_alert('Missing Geometry',
'some features are missing geometry, these must be entered before saving',
type = 'warning')
} else {
shiny::stopApp({
out <- df$data %>% dplyr::select(-leaf_id) %>%
dplyr::mutate(geo_type = as.character(sf::st_geometry_type(.)))
out <- sf::st_sf(out, crs = user_crs)
out <- split(out , f = out$geo_type)
# clean bounding box just in case
for(i in 1:length(out)){
attr(sf::st_geometry(out[[i]]), "bbox") <- sf::st_bbox(sf::st_union(out[[i]]$geometry))
}
out
})
}
} else {
if (any(sf::st_is_empty(df$data$geometry))) {
shinyWidgets::show_alert('Missing Geometry',
'some features are missing geometry, these must be entered before saving',
type = 'warning')
} else {
shiny::stopApp({
# ensure export is sf and same as input crs
out <- sf::st_sf(df$data,crs=user_crs)
# clean bounding box just in case
attr(sf::st_geometry(out), "bbox") <- sf::st_bbox(sf::st_union(out$geometry))
out %>% dplyr::select(-leaf_id)
})
}
}
})
}
shinyApp(ui, server)
