I have a perplexing issue that must be related to some difference in my RStudio sessions. I am attempting to build an interactive shiny app that allows users to draw a polygon on a "leaflet" map using the "leafpm" package, and then extract and summarize raster data using terra::extract() function. I am able to make my app work as expected on one machine, but on a different machine, I get the following error:
Warning: Error in cbind: inherits(y, "data.frame") is not TRUE
3: runApp
2: print.shiny.appobj
1: <Anonymous>
I have been able to isolate the offending line of code to this one (see the end of my post for the full reproducible example):
bio_extract<-reactive({coords$dtf<-data.frame(do.call(rbind, do.call(cbind,input$MAP_draw_new_feature$geometry$coordinates)))
This is the line of code that parses the coordinates for all of the vertices that the user drew, and concatenates them into a dataframe that I later pass to sf::st_as_sf() to create a simple feature polygon.
Here is the session info for the machine it is working properly on:
R version 4.2.2 (2022-10-31 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 19045)
Matrix products: default
locale:
[1] LC_COLLATE=English_United States.utf8 LC_CTYPE=English_United States.utf8 LC_MONETARY=English_United States.utf8
[4] LC_NUMERIC=C LC_TIME=English_United States.utf8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] dplyr_1.1.0 sf_1.0-9 shinydashboard_0.7.2 terra_1.6-47 leafpm_0.1.0
[6] leaflet_2.1.1 shiny_1.7.4
loaded via a namespace (and not attached):
[1] tidyselect_1.2.0 bslib_0.4.2 listenv_0.9.0 vctrs_0.5.2 generics_0.1.3 htmltools_0.5.4
[7] yaml_2.3.7 utf8_1.2.2 blob_1.2.3 rlang_1.0.6 e1071_1.7-12 later_1.3.0
[13] pillar_1.8.1 jquerylib_0.1.4 glue_1.6.2 withr_2.5.0 DBI_1.1.3 bit64_4.0.5
[19] lifecycle_1.0.3 fontawesome_0.5.0 future_1.30.0 htmlwidgets_1.6.1 memoise_2.0.1 codetools_0.2-18
[25] fastmap_1.1.0 httpuv_1.6.9 crosstalk_1.2.0 parallel_4.2.2 class_7.3-20 fansi_1.0.4
[31] Rcpp_1.0.10 KernSmooth_2.23-20 xtable_1.8-4 promises_1.2.0.1 classInt_0.4-8 cachem_1.0.6
[37] jsonlite_1.8.4 mime_0.12 parallelly_1.34.0 bit_4.0.5 hms_1.1.2 digest_0.6.31
[43] grid_4.2.2 cli_3.6.0 odbc_1.3.4 tools_4.2.2 magrittr_2.0.3 sass_0.4.5
[49] proxy_0.4-27 tibble_3.1.8 future.apply_1.10.0 pkgconfig_2.0.3 ellipsis_0.3.2 rstudioapi_0.14
[55] R6_2.5.1 globals_0.16.2 units_0.8-1 compiler_4.2.2
And here is the session info for the machine that throws the error:
R version 4.3.1 (2023-06-16 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 19045)
Matrix products: default
locale:
[1] LC_COLLATE=English_United States.utf8 LC_CTYPE=English_United States.utf8 LC_MONETARY=English_United States.utf8
[4] LC_NUMERIC=C LC_TIME=English_United States.utf8
time zone: America/Los_Angeles
tzcode source: internal
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] dplyr_1.1.3 sf_1.0-15 shinydashboard_0.7.2 terra_1.7-73 leafpm_0.1.0 shiny_1.7.5.1 leaflet_2.2.0
loaded via a namespace (and not attached):
[1] sass_0.4.7 utf8_1.2.4 generics_0.1.3 class_7.3-22 KernSmooth_2.23-22 digest_0.6.33 magrittr_2.0.3
[8] grid_4.3.1 fastmap_1.1.1 jsonlite_1.8.7 e1071_1.7-13 DBI_1.1.3 promises_1.2.1 fansi_1.0.5
[15] crosstalk_1.2.0 codetools_0.2-19 jquerylib_0.1.4 cli_3.6.1 rlang_1.1.1 crayon_1.5.2 units_0.8-4
[22] ellipsis_0.3.2 cachem_1.0.8 tools_4.3.1 memoise_2.0.1 httpuv_1.6.12 vctrs_0.6.4 R6_2.5.1
[29] mime_0.12 proxy_0.4-27 lifecycle_1.0.3 classInt_0.4-10 htmlwidgets_1.6.2 fontawesome_0.5.2 pkgconfig_2.0.3
[36] pillar_1.9.0 bslib_0.5.1 later_1.3.1 glue_1.6.2 Rcpp_1.0.12 tibble_3.2.1 tidyselect_1.2.0
[43] rstudioapi_0.15.0 xtable_1.8-4 htmltools_0.5.6.1 compiler_4.3.1
Here is the full reproducible example: (N.B. When drawing the polygon, attempt to draw in Tillamook, Washington, or Lincoln Counties, as I am 100% sure that the fake raster will cover those areas. The counties will display on the map tiles I call).
library(leaflet)
library(shiny)
library(leafpm)
library(terra)
library(shinydashboard)
library(sf)
library(dplyr)
fake<-rast(xmin= -124.0, xmax=-121.0, ymin=44.0, ymax=46.0, nrows=500, ncols=500, crs="epsg:4326")
values(fake)<-rnorm(250000, 1000, 200)
rastpath<-tempdir()
if(!dir.exists(rastpath)){
dir.create(tempdir)
}
writeRaster(fake, paste(rastpath, "fake.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("Fake Biometric", "All Biometrics"),
selected = "Fake Biometric"),
downloadButton('downloadData', 'Download Polygon')
),
dashboardBody(
leafletOutput(outputId = "MAP", "100%", 800),
verbatimTextOutput("debug_out")
)
)
server<-function(input, output, session){
Bios<-c("Fake Biometric", "All Biometrics")
tifnames<-c('fake.tif')
inpath<-rastpath
rastdf<-data.frame(Bio=Bios[order(Bios)], paths=paste(inpath, tifnames, sep="/"))
#addResourcePath("maptiles", path)
output$MAP<-renderLeaflet({
leaflet() %>% addTiles() %>%
setView(lng=-123.5, lat=45.5, zoom = 10) %>%
#addTiles(urlTemplate = "/maptiles/{z}/{x}/{y}.png", options=list(tms=TRUE, crs=6557, minZoom=7, maxZoom=16)) %>%
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_ras<-reactiveValues()
observeEvent(input$MAP_draw_new_feature, {
req(input$BIO)
bio_extract<-reactive({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)
#coords$df %>%
#st_as_sf(coords = c("long", "lat"), crs = 4326) %>%
#summarise(geometry = st_combine(geometry)) %>%
#st_cast("POLYGON") %>% st_transform(crs=6557)
if(input$BIO=="All Biometrics"){
tmp<-lapply(rastdf$paths, rast)
bio_ras$biom<-rast(tmp)
} else{
bio_ras$biom<-rast(rastdf$paths[rastdf$Bio==input$BIO])
}
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<-sfp
st_as_sf(extract(bio_ras$biom, shapevect, fnx, bind=TRUE))})
poly$out<-bio_extract()
})
# 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$debug_out<-renderPrint({poly$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<-poly$out
st_write(polys_out, "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)
The culprit is not the line you mention. The error is generated by
extract(biom, shapevect, fnx, bind = TRUE)
Here, biom is SpatRaster and shapevect is sf. Then extract does:
y <- vect(y)
extract(x, y, ......)
Now y is SpatVector. In the extract method for such types, there is:
if (bind) {
if (nrow(e) == nrow(y)) {
e <- cbind(y, e[, -1, drop = FALSE])
}
......
And this is this call to cbind which throws the error. So it looks like a bug.
I think (not sure) you can do:
e <- extract(biom, shapevect, fnx, bind = FALSE)
and then do
cbind(shapevect, e[, -1, drop = FALSE])
That should give the expected output of extract(biom, shapevect, fnx, bind = TRUE).
But there are some problems in your code... Check your parentheses and your curly braces. There's also some bad coding, e.g. you define a reactive inside an observer.