I am working on a shiny app that lets users interactively draw polygons on a leaflet map using the "leafpm" package, calculate forest biometrics, report them, and make those polygons available to download. I think I have may app almost complete, but I am struggling to handle edits to the polygon.
I adapted my code from this Stack Overflow post, which uses the now deprecated "sp" package to handle the polygons. I instead use the "sf" package. In my observeEvent() function, I attempt to handle polygon edits, by dropping the feature with the same unique identifier supplied by the reactive shiny object input$MAP_draw_edited_features$properties$layerId from polys$out (which is the reactiveValues() object that I define to store all of the drawn polygons), and then using rbind() to add the edited feature back in. I store the unique identifier from the reactive shiny object as the row names in polys$out. I store the edited feature as an "sf" object called sfp, which also has its unique identifier stored as its row name. The idea is that I can query based on non-matching row names to remove the old version of the edited feature from polys$out, and then use rbind() to add sfp back into polys$out with the same unique identifier, so that users see only the changes in geometry. Strangely, when I test this, my edits seem to result in an the edited feature sequentially overwriting the geometries of unedited features.
At first, I ran a number of isolate(print(row.names(polys$out))) statements to see if somehow my method of querying on row name was flawed. It turned out that using rbind() overwrote the row names, so I explicitly redefined the row names following my schema described above. After doing that, I was able to ensure that the correct row name for the edited feature was being dropped, and then added back in. However, the geometries are still getting overwritten. Do I need to somehow break the observeEvent() after each edits to prevent this from happening? Am I somehow overwriting the wrong row names to the wrong feature?
Below is my full reproducible example. Please draw at least 3 - 4 polygons, check the table for the values, then make at least two edits to the polygons, and then check the table again to reproduce the behavior I describe.
library(leaflet)
library(shiny)
library(leafpm)
library(terra)
library(shinydashboard)
library(sf)
library(dplyr)
set.seed(56)
BAA<-rast(xmin= -124.0, xmax=-121.0, ymin=44.0, ymax=46.0, nrows=500, ncols=500, crs="epsg:4326")
values(BAA)<-rnorm(250000, 150, 40)
rastpath<-tempdir()
if(!dir.exists(rastpath)){
dir.create(tempdir)
}
writeRaster(BAA, paste(normalizePath(rastpath,"/"), "Basal Area per Acre.tif", sep="/"), overwrite=TRUE)
SPP<-BAA
species<-c("THPL", "ALRU2", "ACMA3",
"PSME", "TSHE", "PISI", "ABPR")
values(SPP)<-sample(species, 250000, replace=TRUE)
writeRaster(SPP, paste(normalizePath(rastpath,"/"), "Species Composition.tif", sep="/"), overwrite=TRUE)
ui<-dashboardPage(
title = "EFI Interactive Mapper",# Start Dashboard Page
header = dashboardHeader(
tags$li(class = "dropdown",
tags$style(".main-header {max-height: 100px}"),
tags$style(".main-header .logo {height: 100px} .primary-title height {100px}"),
tags$style(".sidebar-toggle {height: 20px; padding-top: 150px !important;}"),
tags$style(".navbar {min-height:20px !important}")
),
titleWidth='100%',
title = span(
tags$img(src="Rlogo.png", width = '5%', align='right'),
column(12, class="title-box",
tags$h1(class="primary-title", style='margin-top:5px;', 'EFI Interactive Mapper')
))),#End Header
dashboardSidebar(tags$style(".left-side, .main-sidebar {padding-top: 150px} "),selectInput(inputId = "BIO", "Select a Biometric",
choices = c("Basal Area per Acre", "Species Composition", "All Biometrics"),
selected = "Basal Area Per Acre"), tags$style(".skin-blue .sidebar a { color: #444; }"),
downloadButton('downloadData', 'Download Polygon')
),
dashboardBody(
fluidRow(
tabBox(
tabPanel('Map', div(style='height:63.0vh', leafletOutput(outputId = "MAP", height="100%"))),
tabPanel('Table', div(style='overflow-x: auto; overflow-y: auto; max-height:63.0vh', uiOutput("TABLE"))),
width=12, selected='Table'
)
)
)
)
server<-function(input, output, session){
Bios<-c( "Species Composition", "Basal Area per Acre")
tifnames<-c('Species Composition.tif', "Basal Area Per Acre.tif")
rastdf<-data.frame(Bio=Bios[order(Bios)], paths=paste(normalizePath(rastpath, "/"), tifnames, sep="/"))
tmp<-lapply(rastdf$paths, rast)
bio_ras<-c(tmp)
names(bio_ras)<-rastdf$Bio
output$MAP<-renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng=-123.5, lat=45.5, zoom = 10) %>%
addWMSTiles(
"https://gis.odf.oregon.gov/ags3/rest/services/Basemaps/ProtectionMap/MapServer/tile/{z}/{y}/{x}",
layers = "0",
options = WMSTileOptions(format = "image/png", transparent = TRUE),
attribution = "") %>%
addPmToolbar(
toolbarOptions = pmToolbarOptions(drawPolygon = T,
drawCircle = F,
drawPolyline = F,
drawRectangle = F,
editMode = T,
cutPolygon = T,
removalMode = F,
position="topleft"))
})
proxy <- leafletProxy("MAP", session)
poly<-reactiveValues()
coords<-reactiveValues()
bio_extract<-reactive({
if(!is.null(poly$out)){
if(input$BIO=="All Biometrics"){
bio_use<-bio_ras
} else{
bio_use<-bio_ras[names(bio_ras)==input$BIO][[1]]
}
fnx<-function(x){
themean<-mean(x, na.rm=TRUE)
thesd<-sqrt(var(x, na.rm=TRUE))
out<-list(mean=round(themean,2), sd=round(thesd,2))
return(out)
}
shapevect<-poly$out
if(input$BIO=="Species Composition"){
fqt<-freq(bio_use, zones=vect(shapevect)) %>% mutate(pct_comp = 100*count/sum(count))
all_spp<-as.data.frame(expand.grid(levels(bio_use)[[1]][,2], unique(fqt$zone)))
colnames(all_spp)[1:2]<-c("Species", "ID")
use_cols<-c("value", "zone", "pct_comp")
all_spp<-merge(all_spp, fqt[,use_cols], by.x=c("Species", "ID"), by.y=c("value", "zone"), all.x=TRUE, all.y=FALSE)
all_spp$pct_comp[is.na(all_spp$pct_comp)]<-0
spp_out<-tidyr::pivot_wider(all_spp, id_cols=ID, names_from = Species, values_from = pct_comp) %>% as.data.frame()
e<-cbind(shapevect, as.data.frame(spp_out))
#cbind(shapevect, spp_out)
}else{
if(input$BIO=="All Biometrics"){
ext_ras<-bio_use[names(bio_use)!= "Species Composition"]
e <- lapply(ext_ras, extract, shapevect, fnx, bind = FALSE, raw=FALSE)
spp_ras<-bio_use[names(bio_use)== "Species Composition"][[1]]
fqt<-freq(spp_ras, zones=vect(shapevect)) %>% mutate(pct_comp = 100*count/sum(count))
all_spp<-as.data.frame(expand.grid(levels(spp_ras)[[1]][,2], unique(fqt$zone)))
colnames(all_spp)[1:2]<-c("Species", "ID")
use_cols<-c("value", "zone", "pct_comp")
all_spp<-merge(all_spp, fqt[,use_cols], by.x=c("Species", "ID"), by.y=c("value", "zone"), all.x=TRUE, all.y=FALSE)
all_spp$pct_comp[is.na(all_spp$pct_comp)]<-0
spp_out<-tidyr::pivot_wider(all_spp, id_cols=ID, names_from = Species, values_from = pct_comp) %>% as.data.frame()
e[[length(e)+1]]<-spp_out
names(e)[length(e)]<-"Species Composition"
e<-lapply(e, function(X, Y){cbind(Y, as.data.frame(X))}, shapevect)
}else{
e <- terra::extract(bio_use, shapevect, fnx, bind = FALSE)
e<-cbind(shapevect, as.data.frame(e))
# st_as_sf(cbind(shapevect, e[, -1, drop = FALSE]))
}
}
return(e)
}
})
observeEvent(input$MAP_draw_new_feature, {
req(input$BIO)
coords$dtf<-data.frame(do.call( rbind, do.call(cbind,input$MAP_draw_new_feature$geometry$coordinates)))
colnames(coords$dtf)<-c("long", "lat")
sfp <- coords$dtf %>%
st_as_sf(coords = c("long", "lat"), crs = 4326) %>%
summarise(geometry = st_combine(geometry)) %>%
st_cast("POLYGON") %>% st_transform(crs=6557) %>% st_as_sf()
row.names(sfp)<-input$MAP_draw_new_feature$properties$layerId
if(is.null(poly$out)){
poly$out<-sfp
isolate(print(row.names(poly$out)))
}else{
rn<-row.names(poly$out)
poly$out<-rbind(poly$out, sfp)
row.names(poly$out)[-nrow(poly$out)]<-rn
row.names(poly$out)[nrow(poly$out)]<-row.names(sfp)
isolate(print(row.names(poly$out)))
}
})
observeEvent(input$MAP_draw_edited_features, {
dtf<-data.frame(do.call(rbind, do.call(cbind, input$MAP_draw_edited_features$geometry$coordinates)))
colnames(dtf)<-c("long", "lat")
sfp <- coords$dtf %>%
st_as_sf(coords = c("long", "lat"), crs = 4326) %>%
summarise(geometry = st_combine(geometry)) %>%
st_cast("POLYGON") %>% st_transform(crs=6557) %>% st_as_sf()
row.names(sfp)<-input$MAP_draw_edited_features$properties$layerId
rn<-row.names(poly$out)
isolate(poly$out)
poly$out<-poly$out[!row.names(poly$out) %in% row.names(sfp),]
row.names(poly$out)<-rn[!rn %in% rownames(sfp)]
isolate(poly$out)
poly$out<-rbind(poly$out, sfp)
row.names(poly$out)[1:(nrow(poly$out)-1)]<-rn[!rn %in% rownames(sfp)]
row.names(poly$out)[nrow(poly$out)]<-row.names(sfp)
isolate(poly$out)
})
observeEvent(input$drawnPoly_deleted_features, {
f <- input$drawnPoly_deleted_features
ids<-lapply(f$features, function(x){unlist(x$properties$layerId)})
polys$out<-polys$out[!row.names(polys$out) %in% ids ,]
})
output$TABLE<-renderUI({
req(input$BIO)
if(!is.null(poly$out)){
data.out<-bio_extract()
if(input$BIO=="All Biometrics"){
for(i in 1:length(data.out)){
if(i < length(data.out)){
data.out[[i]]<-as.data.frame(data.out[[i]] %>% st_drop_geometry())
colnames(data.out[[i]])<-c("Area of Interest","Estimate Mean", "Estimate Standard Deviation",
"Lower Bound <br> 95% Prediction Interval <br> Mean", "Lower Bound <br> 95% Prediction Interval <br> Standard Deviation",
"Upper Bound <br> 95% Prediction Interval <br> Mean", "Upper Bound <br> 95% Prediction Interval <br> Standard Deviation")
}else{
data.out[[i]]<-data.out[[i]] %>% st_drop_geometry() %>% mutate(across(.cols=everything(), ~paste(round(.x, 1), "%"))) %>% as.data.frame()
colnames(data.out[[i]])[1]<-"Area of Interest"
}
}
kbl_out<-lapply(data.out, function(X){
kbl(X, format="html", align="c", escape=FALSE, col.names=colnames(X)) %>%
column_spec(column=c(1:ncol(X)), width_min="3.5cm") %>%
kable_styling()
})
table_formatter<-function(tname, tkbl){
paste0("<center><b><u><font size = '+2'>", tname, "</font></u></b></center>",
"<br><center>", tkbl, "</center><br>")}
HTML(table_formatter(names(data.out), kbl_out))
}else{
data.out<-data.out %>% st_drop_geometry()
table_formatter<-function(tname, tkbl){
paste0("<center><b><u><font size = '+2'>", tname, "</font></u></b></center>",
"<br><center>", tkbl, "</center><br>")}
if(input$BIO!="Species Composition"){
use_names<-c("Area of Interest","Estimate Mean", "Estimate Standard Deviation",
"Lower Bound <br> 95% Prediction Interval <br> Mean", "Lower Bound <br> 95% Prediction Interval <br> Standard Deviation",
"Upper Bound <br> 95% Prediction Interval <br> Mean", "Upper Bound <br> 95% Prediction Interval <br> Standard Deviation")
}else{
use_names<-colnames(data.out)
data.out<-data.out %>% mutate(across(.cols=everything(), ~paste(round(.x, 1), "%")))
}
kbl_out<-kbl(data.out, format="html", escape = FALSE, col.names=use_names, align="c") %>%
column_spec(column=c(1:ncol(data.out)), width_min = "3.5cm") %>%
kable_styling()
HTML(table_formatter(input$BIO, kbl_out))
}
}
})
output$downloadData<-downloadHandler(
filename <- function(){
fname<-input$BIO
paste(fname, "Polygon.gpkg", sep="_")},
content = function(file) {
# req(polys$out)
if (length(Sys.glob(paste(input$BIO, "*", sep=".")))>0){
file.remove(Sys.glob(paste(input$BIO, "*", sep=".")))
}
owd<-setwd(tempdir())
on.exit(setwd(owd))
polys_out<-bio.extract()
if(input$BIO=="All Biometrics"){
polys_out2<-rapply(polys_out, function(X){merge(X, X, by=names(X)[1])}, how="replace")
}else{
polys_out2<-polys_out
}
st_write(polys_out2, "polyExport.gpkg", "GPKG", append=FALSE)
file.rename("polyExport.gpkg", file)
if (length(Sys.glob("polyExport.*"))>0){
file.remove(Sys.glob("polyExport.*"))
}
})
}
shinyApp(ui=ui, server=server)
It turned out this was just a typo on my part. In the call to observeEvent(), I had this chunk of code that creates the simple feature version of the edit polygons
sfp <- coords$dtf %>%
st_as_sf(coords = c("long", "lat"), crs = 4326) %>%
summarise(geometry = st_combine(geometry)) %>%
st_cast("POLYGON") %>% st_transform(crs=6557) %>% st_as_sf()
coords$dtf is actually from the previous observer for newly drawn polygons. Changing that object to dtf, which is the object for edited polygons solved the issue. If it is helpful to anyone else, here is the full reproducible solution:
library(leaflet)
library(shiny)
library(leafpm)
library(terra)
library(shinydashboard)
library(sf)
library(dplyr)
set.seed(56)
BAA<-rast(xmin= -124.0, xmax=-121.0, ymin=44.0, ymax=46.0, nrows=500, ncols=500, crs="epsg:4326")
values(BAA)<-rnorm(250000, 150, 40)
rastpath<-tempdir()
if(!dir.exists(rastpath)){
dir.create(tempdir)
}
writeRaster(BAA, paste(normalizePath(rastpath,"/"), "Basal Area per Acre.tif", sep="/"), overwrite=TRUE)
SPP<-BAA
species<-c("THPL", "ALRU2", "ACMA3",
"PSME", "TSHE", "PISI", "ABPR")
values(SPP)<-sample(species, 250000, replace=TRUE)
writeRaster(SPP, paste(normalizePath(rastpath,"/"), "Species Composition.tif", sep="/"), overwrite=TRUE)
ui<-dashboardPage(
title = "EFI Interactive Mapper",# Start Dashboard Page
header = dashboardHeader(
tags$li(class = "dropdown",
tags$style(".main-header {max-height: 100px}"),
tags$style(".main-header .logo {height: 100px} .primary-title height {100px}"),
tags$style(".sidebar-toggle {height: 20px; padding-top: 150px !important;}"),
tags$style(".navbar {min-height:20px !important}")
),
titleWidth='100%',
title = span(
tags$img(src="Rlogo.png", width = '5%', align='right'),
column(12, class="title-box",
tags$h1(class="primary-title", style='margin-top:5px;', 'EFI Interactive Mapper')
))),#End Header
dashboardSidebar(tags$style(".left-side, .main-sidebar {padding-top: 150px} "),selectInput(inputId = "BIO", "Select a Biometric",
choices = c("Basal Area per Acre", "Species Composition", "All Biometrics"),
selected = "Basal Area Per Acre"), tags$style(".skin-blue .sidebar a { color: #444; }"),
downloadButton('downloadData', 'Download Polygon')
),
dashboardBody(
fluidRow(
tabBox(
tabPanel('Map', div(style='height:63.0vh', leafletOutput(outputId = "MAP", height="100%"))),
tabPanel('Table', div(style='overflow-x: auto; overflow-y: auto; max-height:63.0vh', uiOutput("TABLE"))),
width=12, selected='Table'
)
)
)
)
server<-function(input, output, session){
Bios<-c( "Species Composition", "Basal Area per Acre")
tifnames<-c('Species Composition.tif', "Basal Area Per Acre.tif")
rastdf<-data.frame(Bio=Bios[order(Bios)], paths=paste(normalizePath(rastpath, "/"), tifnames, sep="/"))
tmp<-lapply(rastdf$paths, rast)
bio_ras<-c(tmp)
names(bio_ras)<-rastdf$Bio
output$MAP<-renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng=-123.5, lat=45.5, zoom = 10) %>%
addWMSTiles(
"https://gis.odf.oregon.gov/ags3/rest/services/Basemaps/ProtectionMap/MapServer/tile/{z}/{y}/{x}",
layers = "0",
options = WMSTileOptions(format = "image/png", transparent = TRUE),
attribution = "") %>%
addPmToolbar(
toolbarOptions = pmToolbarOptions(drawPolygon = T,
drawCircle = F,
drawPolyline = F,
drawRectangle = F,
editMode = T,
cutPolygon = T,
removalMode = F,
position="topleft"))
})
proxy <- leafletProxy("MAP", session)
poly<-reactiveValues()
coords<-reactiveValues()
bio_extract<-reactive({
if(!is.null(poly$out)){
if(input$BIO=="All Biometrics"){
bio_use<-bio_ras
} else{
bio_use<-bio_ras[names(bio_ras)==input$BIO][[1]]
}
fnx<-function(x){
themean<-mean(x, na.rm=TRUE)
thesd<-sqrt(var(x, na.rm=TRUE))
out<-list(mean=round(themean,2), sd=round(thesd,2))
return(out)
}
shapevect<-poly$out
if(input$BIO=="Species Composition"){
fqt<-freq(bio_use, zones=vect(shapevect)) %>% mutate(pct_comp = 100*count/sum(count))
all_spp<-as.data.frame(expand.grid(levels(bio_use)[[1]][,2], unique(fqt$zone)))
colnames(all_spp)[1:2]<-c("Species", "ID")
use_cols<-c("value", "zone", "pct_comp")
all_spp<-merge(all_spp, fqt[,use_cols], by.x=c("Species", "ID"), by.y=c("value", "zone"), all.x=TRUE, all.y=FALSE)
all_spp$pct_comp[is.na(all_spp$pct_comp)]<-0
spp_out<-tidyr::pivot_wider(all_spp, id_cols=ID, names_from = Species, values_from = pct_comp) %>% as.data.frame()
e<-cbind(shapevect, as.data.frame(spp_out))
#cbind(shapevect, spp_out)
}else{
if(input$BIO=="All Biometrics"){
ext_ras<-bio_use[names(bio_use)!= "Species Composition"]
e <- lapply(ext_ras, extract, shapevect, fnx, bind = FALSE, raw=FALSE)
spp_ras<-bio_use[names(bio_use)== "Species Composition"][[1]]
fqt<-freq(spp_ras, zones=vect(shapevect)) %>% mutate(pct_comp = 100*count/sum(count))
all_spp<-as.data.frame(expand.grid(levels(spp_ras)[[1]][,2], unique(fqt$zone)))
colnames(all_spp)[1:2]<-c("Species", "ID")
use_cols<-c("value", "zone", "pct_comp")
all_spp<-merge(all_spp, fqt[,use_cols], by.x=c("Species", "ID"), by.y=c("value", "zone"), all.x=TRUE, all.y=FALSE)
all_spp$pct_comp[is.na(all_spp$pct_comp)]<-0
spp_out<-tidyr::pivot_wider(all_spp, id_cols=ID, names_from = Species, values_from = pct_comp) %>% as.data.frame()
e[[length(e)+1]]<-spp_out
names(e)[length(e)]<-"Species Composition"
e<-lapply(e, function(X, Y){cbind(Y, as.data.frame(X))}, shapevect)
}else{
e <- terra::extract(bio_use, shapevect, fnx, bind = FALSE)
e<-cbind(shapevect, as.data.frame(e))
# st_as_sf(cbind(shapevect, e[, -1, drop = FALSE]))
}
}
return(e)
}
})
observeEvent(input$MAP_draw_new_feature, {
req(input$BIO)
coords$dtf<-data.frame(do.call( rbind, do.call(cbind,input$MAP_draw_new_feature$geometry$coordinates)))
colnames(coords$dtf)<-c("long", "lat")
sfp <- coords$dtf %>%
st_as_sf(coords = c("long", "lat"), crs = 4326) %>%
summarise(geometry = st_combine(geometry)) %>%
st_cast("POLYGON") %>% st_transform(crs=6557) %>% st_as_sf()
row.names(sfp)<-input$MAP_draw_new_feature$properties$layerId
if(is.null(poly$out)){
poly$out<-sfp
isolate(print(row.names(poly$out)))
}else{
rn<-row.names(poly$out)
poly$out<-rbind(poly$out, sfp)
row.names(poly$out)[-nrow(poly$out)]<-rn
row.names(poly$out)[nrow(poly$out)]<-row.names(sfp)
isolate(print(row.names(poly$out)))
}
})
observeEvent(input$MAP_draw_edited_features, {
dtf<-data.frame(do.call(rbind, do.call(cbind, input$MAP_draw_edited_features$geometry$coordinates)))
colnames(dtf)<-c("long", "lat")
sfp <- dtf %>%
st_as_sf(coords = c("long", "lat"), crs = 4326) %>%
summarise(geometry = st_combine(geometry)) %>%
st_cast("POLYGON") %>% st_transform(crs=6557) %>% st_as_sf()
row.names(sfp)<-input$MAP_draw_edited_features$properties$layerId
rn<-row.names(poly$out)
isolate(poly$out)
poly$out<-poly$out[!row.names(poly$out) %in% row.names(sfp),]
row.names(poly$out)<-rn[!rn %in% rownames(sfp)]
isolate(poly$out)
poly$out<-rbind(poly$out, sfp)
row.names(poly$out)[1:(nrow(poly$out)-1)]<-rn[!rn %in% rownames(sfp)]
row.names(poly$out)[nrow(poly$out)]<-row.names(sfp)
isolate(poly$out)
})
observeEvent(input$drawnPoly_deleted_features, {
f <- input$drawnPoly_deleted_features
ids<-lapply(f$features, function(x){unlist(x$properties$layerId)})
polys$out<-polys$out[!row.names(polys$out) %in% ids ,]
})
output$TABLE<-renderUI({
req(input$BIO)
if(!is.null(poly$out)){
data.out<-bio_extract()
if(input$BIO=="All Biometrics"){
for(i in 1:length(data.out)){
if(i < length(data.out)){
data.out[[i]]<-as.data.frame(data.out[[i]] %>% st_drop_geometry())
colnames(data.out[[i]])<-c("Area of Interest","Estimate Mean", "Estimate Standard Deviation",
"Lower Bound <br> 95% Prediction Interval <br> Mean", "Lower Bound <br> 95% Prediction Interval <br> Standard Deviation",
"Upper Bound <br> 95% Prediction Interval <br> Mean", "Upper Bound <br> 95% Prediction Interval <br> Standard Deviation")
}else{
data.out[[i]]<-data.out[[i]] %>% st_drop_geometry() %>% mutate(across(.cols=everything(), ~paste(round(.x, 1), "%"))) %>% as.data.frame()
colnames(data.out[[i]])[1]<-"Area of Interest"
}
}
kbl_out<-lapply(data.out, function(X){
kbl(X, format="html", align="c", escape=FALSE, col.names=colnames(X)) %>%
column_spec(column=c(1:ncol(X)), width_min="3.5cm") %>%
kable_styling()
})
table_formatter<-function(tname, tkbl){
paste0("<center><b><u><font size = '+2'>", tname, "</font></u></b></center>",
"<br><center>", tkbl, "</center><br>")}
HTML(table_formatter(names(data.out), kbl_out))
}else{
data.out<-data.out %>% st_drop_geometry()
table_formatter<-function(tname, tkbl){
paste0("<center><b><u><font size = '+2'>", tname, "</font></u></b></center>",
"<br><center>", tkbl, "</center><br>")}
if(input$BIO!="Species Composition"){
use_names<-c("Area of Interest","Estimate Mean", "Estimate Standard Deviation",
"Lower Bound <br> 95% Prediction Interval <br> Mean", "Lower Bound <br> 95% Prediction Interval <br> Standard Deviation",
"Upper Bound <br> 95% Prediction Interval <br> Mean", "Upper Bound <br> 95% Prediction Interval <br> Standard Deviation")
}else{
use_names<-colnames(data.out)
data.out<-data.out %>% mutate(across(.cols=everything(), ~paste(round(.x, 1), "%")))
}
kbl_out<-kbl(data.out, format="html", escape = FALSE, col.names=use_names, align="c") %>%
column_spec(column=c(1:ncol(data.out)), width_min = "3.5cm") %>%
kable_styling()
HTML(table_formatter(input$BIO, kbl_out))
}
}
})
output$downloadData<-downloadHandler(
filename <- function(){
fname<-input$BIO
paste(fname, "Polygon.gpkg", sep="_")},
content = function(file) {
# req(polys$out)
if (length(Sys.glob(paste(input$BIO, "*", sep=".")))>0){
file.remove(Sys.glob(paste(input$BIO, "*", sep=".")))
}
owd<-setwd(tempdir())
on.exit(setwd(owd))
polys_out<-bio.extract()
if(input$BIO=="All Biometrics"){
polys_out2<-rapply(polys_out, function(X){merge(X, X, by=names(X)[1])}, how="replace")
}else{
polys_out2<-polys_out
}
st_write(polys_out2, "polyExport.gpkg", "GPKG", append=FALSE)
file.rename("polyExport.gpkg", file)
if (length(Sys.glob("polyExport.*"))>0){
file.remove(Sys.glob("polyExport.*"))
}
})
}
shinyApp(ui=ui, server=server)