EditAttributes в блестящем приложении заставляет пользователя редактировать атрибуты
Спасибо за помощь в ответе на мой первый вопрос по этой теме. Я обновляю и уточняю свой вопрос здесь: я пытаюсь создать блестящее приложение, которое загружает карту и пустой фрейм данных с тремя ранее определенными атрибутами в качестве заголовков таблицы. Затем пользователь должен нарисовать на карте первый прямоугольник. Прямоугольник (leafletID) должен появиться в таблице , и пользователь должен соответствующим образом отредактировать атрибуты, и ему не будет разрешено рисовать следующий прямоугольник, пока он не подтвердит отредактированные атрибуты. После подтверждения пользователь может нарисовать второй прямоугольник и так далее. Приложению не обязательно иметь столбец добавления или специальные функции масштабирования. Наконец, пользователь может захотеть настроить некоторые атрибуты того или иного прямоугольника или даже удалить прямоугольник (линию).
На основе очень полезного пакета Mapedit и функции editAttributes версии для разработчиков. Я создал небольшое работающее приложение. Однако описанные функции не реализованы, поскольку я изо всех сил пытался это сделать. Благодарен за любые подсказки или предложения по запуску этого проекта.
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)