CoordinateMapper/app.R at master · RhettRautsaw/CoordinateMapper · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
#    http://shiny.rstudio.com/
#

library(shiny)
library(leaflet)
library(leaflet.extras2)
library(htmltools)
library(RColorBrewer)
library(sf)
library(terra)

#brPal <- colorRampPalette(c("#543005","#8C510A","#BF812D","#DFC27D","#F6E8C3","#F5F5F5","#C7EAE5","#80CDC1","#35978F","#01665E","#003C30"))
brPal <- colorRampPalette(brewer.pal(8,"Dark2"))
pal <- brPal(255)

# Define UI for application that draws a histogram
ui <- navbarPage("Coordinate Mapper", id="nav",

    tabPanel("Interactive Map",
        div(class="outer",
            # Include custom styles and javascript
            tags$head(includeCSS("styles.css"), includeScript("gomap.js")),
            # If not using custom CSS, set height of leafletOutput to a number instead of percent
            leafletOutput("map", width="100%", height="100%"),

            absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
                draggable = TRUE, top = 60, left = "auto", right = 20, bottom = "auto",
                width = 550, style = "overflow-y: scroll;",

                h3("Input Data"),
                textAreaInput(inputId = "data", label = h5("Sample\tCategory\tLatitude\tLongitude"), width='500px', height='500px',
                    value = paste0("KW1547\tAgkistrodon_conanti\t28.2663\t-82.5496\nAp07\tAgkistrodon_piscivorus_leucostoma\t31.5337\t-92.5046")),

                actionButton("update", "Update"),
            )
        )
    )
)


# Server
server<-function(input, output, session) {

    output$map<-renderLeaflet({
        leaflet() %>%
            addProviderTiles(providers$Esri.WorldTerrain, group="Terrain") %>%
            addProviderTiles(providers$Esri.WorldStreetMap, group="Open Street Map") %>%
            addWMSTiles('http://ows.mundialis.de/services/service?', layers='TOPO-WMS', group="Topography") %>%
            addProviderTiles(providers$Esri.WorldImagery, group="Satellite") %>%
            addProviderTiles(providers$Stadia.StamenTonerLines, group="Boundaries") %>%
            addProviderTiles(providers$Stadia.StamenTonerLabels, group="Labels") %>%
            addLayersControl(
                baseGroups=c("Terrain","Open Street Map","Topography", "Satellite"),
                overlayGroups=c("Boundaries","Labels"),
                options=layersControlOptions(collapsed=F, position="bottomleft")
            ) %>%
            hideGroup(c("Labels")) %>%
            addScaleBar(position = c("topleft"), options = scaleBarOptions()) %>%
            addEasyprint(options=easyprintOptions(exportOnly = T, sizeModes = list("A4Landscape")))
    })

    observeEvent(input$update, {
        pointsData<-read.table(text=input$data, header=FALSE, sep="\t", col.names = c("Sample","Category","Latitude","Longitude"))
        pointsData$Latitude <- as.numeric(pointsData$Latitude)
        pointsData$Longitude <- as.numeric(pointsData$Longitude)
        pointsData <- pointsData[stats::complete.cases(pointsData[, c("Latitude", "Longitude")]), ]
        pointsSf <- st_as_sf(pointsData, coords = c("Longitude", "Latitude"), crs = 4326, remove = FALSE)
        terra::vect(pointsSf)

        sp_factpal<-colorFactor(pal,levels=sort(unique(pointsSf$Category)), ordered=T, reverse=T)

        leafletProxy("map")%>%
            clearMarkers() %>% clearGroup("points") %>%
            clearControls() %>%
            addCircleMarkers(data=pointsSf,
                             radius = 8,
                             color = ~sp_factpal(Category),
                             stroke = T, fillOpacity = 0.8,
                             #clusterOptions = markerClusterOptions(),
                             label = ~htmlEscape(Sample),
                             group = "points") %>%
            addLegend(position = "topleft", pal=sp_factpal, values = sort(unique(pointsSf$Category)), layerId = "points") %>%
            fitBounds(min(pointsSf$Longitude, na.rm = T)-1,
                      min(pointsSf$Latitude, na.rm =T)-1,
                      max(pointsSf$Longitude, na.rm =T)+5,
                      max(pointsSf$Latitude, na.rm =T)+1)
    })
}

# Run the application
shinyApp(ui = ui, server = server)