This is my .server, I was trying to give an example using countries to simplify, since it includes many other things that may not be of interest.
My data is arraged so every column is an environmental variable and every row is an individual. I have 300ish environmental variables (columns) and more than 1000 rows (individuals). When i plote them using leaflet, i do get the grey dots corresponding to NAs, and I would like to avoid plotting them
library(shiny)
library(shinyjs)
library(shiny)
library(shinyjs)
library(shinyURL)
library(leaflet.extras)
credentials <- list("123" = "202cb962ac59075b964b07152d234b70")
shinyServer(function(input, output) {
shinyURL.server()
USER <- reactiveValues(Logged = FALSE)
observeEvent(input$.login, {
if (isTRUE(credentials[[input$.username]]==input$.password)){
USER$Logged <- TRUE
} else {
show("message")
output$message = renderText("Invalid user name or password")
delay(2000, hide("message", anim = TRUE, animType = "fade"))
}
})
output$app = renderUI(
if (!isTRUE(USER$Logged)) {
fluidRow(column(width=4, offset = 4,
wellPanel(id = "login",
textInput(".username", "Username:"),
passwordInput(".password", "Password:"),
div(actionButton(".login", "Log in"), style="text-align: center;")
),
textOutput("message")
))
} else {
output$map <- renderLeaflet({
print('render map')
leaflet(FULL) %>%
addSearchOSM(options = searchOSMOptions(position = 'topleft', zoom = 5)) %>%
addProviderTiles("OpenStreetMap.Mapnik", group = "OpenStreetmap") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addProviderTiles("Esri.WorldGrayCanvas", group = "Esri.WorldGrayCanvas") %>%
addProviderTiles("Esri.NatGeoWorldMap", group = "Esri.NatGeoWorldMap") %>%
addProviderTiles("Esri.OceanBasemap", group = "Esri.OceanBasemap") %>%
addProviderTiles("CartoDB.DarkMatter", group = "DarkMatter (CartoDB)") %>%
setView(lng = 0, lat = 50, zoom = 2) %>%
addLayersControl(baseGroups = c('Esri.WorldImagery',"OpenStreetmap","Esri.WorldGrayCanvas","Esri.NatGeoWorldMap","Esri.OceanBasemap",'DarkMatter (CartoDB)' ),
options = layersControlOptions(collapsed = TRUE, autoZIndex = F, position = 'bottomleft' ))
})
df <- datasets[['FULL']]
makeReactiveBinding('df')
observeEvent(input$makeReactiveBinding,{
print('dataset')
leafletProxy('map')%>%clearShapes()
df <<- datasets[[input$dataset]]
i.active <<- NULL
})
coords <- reactive({
print('coords')
crds <- data.frame(coordinates(df))
leafletProxy('map')%>%fitBounds(lng1=min(crds[,1]),lng2=max(crds[,1]),
lat1=min(crds[,2]),lat2=max(crds[,2]))
crds
})
output$yvar <- renderUI(selectInput('yvar',label='Environment',choices = list("Coordinates" = c("lng"="lng", "lat"="lat"),....etc, too many variables to be able to post it here))))
output$xvar <- renderUI(selectInput('color',label='Phenotype',choices = list("paper A" =c("F at 10 °C", "F16\"),
"Paper B"=c(" cell length (µm)", " M length (µm)"),
etc, too many variables to post here
)))
xVar <- reactive({
out <- data %>%
filter(color == input$color,
!is.na(value))
return(out)
})
xVar <- reactive({
print('xVar')
if(is.null(input$xvar)) return(names(df)[1])
xvar_ <<- input$xvar
input$xvar})
yVar <- reactive({
if(is.null(input$yvar)) return(names(df)[2])
input$yvar})
xVar <- reactive({
print('colVar')
if(is.null(input$color)) return(names(df)[2])
input$color})
IDVar <- reactive({
print('ID')
if(is.null(input$ID)) return(names(df)[3])
input$ID})
ggvisdf <- reactive({
print('ggvesdf1')
df1 <- isolate(df@data)
gdf <- df1[, c(xVar(), yVar())]
names(gdf) <- c("x", "y")
gdf
})
colorData <- reactive({
print(names(input))
print('colData')
df1 <- isolate(df@data)
df1[,xVar()]})
colorpal <- reactive(colorNumeric(input$pal, colorData()))
pal <- reactive({colorpal()(colorData())})
observe({
print('update map size/opa/color')
x <- coords()[,1]
y <- coords()[,2]
leafletProxy('map')%>%
addCircleMarkers(lng=x,fillColor = pal(),
lat=y,
stroke = F,
layerId = as.character(1:length(x)),
radius = input$size/10,
color = 'blue',
fillOpacity = 1,
popup = paste("ID:", FULL$id, "<br>",
"Name: ", FULL$name, "<br>",
"Country: ", FULL$country, "<br>",
"CS number: ", FULL$CS_number, "<br>",
"Admixture group: ", FULL$group) )
})
observe({
print('legend')
leafletProxy("map")%>%
clearControls() %>%
addLegend(opacity = 1,position = "bottomright",title = xVar(),
pal = colorpal(), values = rev(colorData()))
})
mapData <- reactive({
print('mapdata')
mb <- input$map_bounds
if(is.null(mb))
return(1)#as.vector(rep(1,nrow(coords()))))
if(nrow(coords())!=nrow((ggvisdf())))
return(1)
as.numeric(coords()[,1]>mb$west&coords()[,1]<mb$east&
coords()[,2]>mb$south&coords()[,2]<mb$north)+0.1
})
tooltip <- function(x) {
ggvisHover <<- x
if(is.null(x)) return(NULL)
tt<<-paste0(c(xVar(),yVar()), ": ", format(x[1:2]), collapse = "<br/>")
leafletProxy('map') %>%addControl(tt,layerId = 'tt',position = 'topright')
tt
}
ggvisHover <- NULL
makeReactiveBinding('ggvisHover')
i.active <- NULL
makeReactiveBinding('i.active')
observeEvent(ggvisHover,{
h <- ggvisHover[1:2]
i.active <<- ggvisdf()[,'x']==h[[1]]&ggvisdf()[,'y']==h[[2]]
})
observeEvent(input$map_marker_mouseover,{
id <- as.numeric(input$map_marker_mouseover$id)
if(!is.na(id)){
i.active <<- id
}
})
observeEvent(i.active,{
leafletProxy('map') %>%
removeMarker('hover') %>%
addCircleMarkers(lat=coords()[i.active,2],opacity = 1,
fillOpacity = 0,
radius = (input$size/5),
lng=coords()[i.active,1],
layerId = 'hover',weight = 6,
color = 'red',fill = FALSE)
})
mouseOver <- reactive({
p <- ggvisdf()[i.active,c('x','y')]
if(class(i.active)=='numeric'){tooltip(p)}
p
})
########
#######Table
output$PHENOTYPES <- DT::renderDataTable(PHENOTYPES, filter = 'top', options = list(
pageLength = 5, autoWidth = TRUE))
output$FULL <- DT::renderDataTable(FULL.val, filter = 'top', options = list(
pageLength = 5, autoWidth = TRUE))
######Big plot X vs y
ggvisdf %>%
ggvis(~y,~x) %>%
set_options(width = "auto", height = "auto", resizable=FALSE) %>%
# add_axis("x", title = xVar()) %>%
add_axis("x", title = "Phenotype", grid = TRUE, title_offset = 40, properties = axis_props(
axis = list(stroke = "red"),title = list(fontSize = 32),
labels = list(fontSize = 16))) %>%
add_axis("y", title = "Environment", grid = TRUE, title_offset = 60, properties = axis_props(
axis = list(stroke = "blue"),title = list(fontSize = 32),
labels = list(fontSize = 16))) %>%
layer_points(size := input_slider(1, 100, value = 50,id='size',label = 'Size'),
opacity := 1,
fill := pal) %>%
add_tooltip(tooltip, "hover") %>%
layer_points(data =mouseOver,stroke:='blue',size := 150,fillOpacity=0,strokeWidth:=5) %>%
layer_model_predictions(model = "lm", se = TRUE) %>%
bind_shiny("p",'ui')
#####density plot y
ggvisdf %>%
ggvis(~y) %>%
set_options(width = "auto", height = "auto", resizable=FALSE) %>%
add_axis("x", title = "Phenotype", properties = axis_props(
axis = list(stroke = "red"),
title = list(fontSize = 30),
labels = list(fontSize = 10))) %>%
add_axis("y", title = 'count', properties = axis_props(
axis = list(stroke = "red"),
title = list(fontSize = 20),
labels = list(fontSize = 10))) %>%
layer_histograms(width = 0.5, center = 35, fill := "red") %>% set_options(width = "auto", height = "auto", resizable=FALSE) %>%
layer_points(data =mouseOver,stroke:='black',shape := "triangle-down", size := 50) %>%
bind_shiny("p2")
#####density plot x
ggvisdf %>%
ggvis(~x) %>%
layer_histograms(width = 0.5, center = 35, fill := "blue") %>% set_options(width = "auto", height = "auto", resizable=FALSE) %>%
add_axis("x", title = "Environment", properties = axis_props(
axis = list(stroke = "blue"),
title = list(fontSize = 30),
labels = list(fontSize = 10))) %>%
add_axis("y", title = 'count', properties = axis_props(
axis = list(stroke = "red"),
title = list(fontSize = 20),
labels = list(fontSize = 10))) %>%
layer_points(data =mouseOver,stroke:='black',shape := "triangle-down", size := 50) %>%
bind_shiny("p3")
})
})