{ "collab_server" : "", "contents" : "\n\nshinyServer(function(input, output, session) {\n \n \n ## Interactive Map ###########################################\n \n # get species observations\n # species <- reactive({\n # pol = st_sfc(st_polygon(list(cbind(c(7.55,7.55,12.09,12.09,7.55),c(56.99,58.05,58.05,58.05,56.99)))))\n # pol_ext = st_buffer(pol, dist = 1)\n # obsData <- occurrence(scientificname = c(\"Buccinum undatum\"), geometry = st_as_text(pol_ext))\n # obsData\n # \n # })\n \n # Create the map\n output$map <- renderLeaflet({\n factpal <- colorFactor(topo.colors(5), emodnet_habitat_cl_sp$HAB_TYPE)\n pal <- colorNumeric(c(\"green\", \"white\", \"red\"), values(kriged_wulk),\n na.color = \"transparent\")\n leaflet() %>%\n addTiles(group = \"OSM (default)\") %>%\n addPolygons(data = emodnet_habitat_cl_sp, \n weight = 1, fillOpacity = 1, \n color = ~factpal(HAB_TYPE),\n label = ~htmlEscape(HAB_TYPE),\n group = \"EMODnet habtype\") %>%\n addCircleMarkers(data = obsData,\n lng = ~decimalLongitude, \n lat = ~decimalLatitude,\n group = \"speciesObservations\", \n weight = ~individualCount,\n label = ~htmlEscape(paste(eventDate))) %>%\n addRasterImage(x = kriged_wulk,\n colors = pal, \n opacity = 0.8,\n group = \"kriged observations\") %>%\n addLayersControl(\n baseGroups = c(\"OSM (default)\"),\n overlayGroups = c(\"EMODnet habtype\", \"speciesObservations\", \"kriged observations\"),\n options = layersControlOptions(collapsed = FALSE)) %>%\n hideGroup(c())\n \n })\n \n # A reactive expression that returns the set of benthos data that are\n # in bounds right now\n \n # samplesInBounds <- reactive({\n # if (is.null(input$map_bounds))\n # return(benthos[FALSE,])\n # bounds <- input$map_bounds\n # latRng <- range(bounds$north, bounds$south)\n # lngRng <- range(bounds$east, bounds$west)\n \n # benthos %>% \n # dplyr::filter(parameter.omschrijving %in% benthosselection &\n # grootheid.code == input$variable )%>%\n # dplyr::filter(lat >= latRng[1] & \n # lat <= latRng[2] & \n # lon >= lngRng[1] & \n # lon <= lngRng[2]) \n # })\n \n # output$benthosTable <- renderTable({\n # # samplesInBounds() %>% \n # # # filter() %>%\n # # group_by(meetpunt.identificatie) %>%\n # # summarise(\n # # noOfSamples = length(meetpunt.identificatie),\n # # noOfSpecies = length(unique(soortnaam))) %>% \n # # dplyr::select(meetID = meetpunt.identificatie, noOfSamples, noOfSpecies)\n # })\n \n # Precalculate the breaks we'll need for the two histograms\n # benthosBreaks <- hist(plot = FALSE, mybenthos()$sum_of_benthos, breaks = 20)$breaks\n \n # output$histBenthos <- renderPlot({\n # # If no points are in view, don't plot\n # if (nrow(samplesInBounds()) == 0)\n # return(NULL)\n # \n # hist(samplesInBounds()$sum_of_benthos,\n # # breaks = benthosBreaks,\n # main = \"Benthos (visible samples)\",\n # xlab = \"Percentile\",\n # # xlim = range(samplesInBounds()$sum_of_benthos),\n # col = '#00DD00',\n # border = 'white')\n # })\n \n # output$timeSeriesBenthos <- renderPlot({\n # # If no points are in view, don't plot\n # # if (nrow(samplesInBounds()) == 0)\n # # return(print(\"no data in view\")) # should print in the UI, not in de console\n # # timebox <- ggplot(samplesInBounds(), (aes(x = year, y = numeriekewaarde))) + \n # # geom_boxplot(aes(group = year))\n # # if(input$plotlog) {timebox = timebox + scale_y_log10()}\n # # if(!input$plotlog) {timebox = timebox}\n # # timebox\n # # # print(xyplot(monsternemingsdatum ~ numeriekewaarde, data = samplesInBounds(), xlim = range(samplesInBounds$monsternemingsdatum), ylim = range(samplesInBounds$numeriekewaarde)))\n # })\n # \n # This observer is responsible for maintaining the circles and legend,\n # according to the variables the user has chosen to map to color and size.\n # observe({\n # colorBy <- input$color\n # sizeBy <- input$size\n # \n # if (colorBy == \"superzip\") {\n # # Color and palette are treated specially in the \"superzip\" case, because\n # # the values are categorical instead of continuous.\n # colorData <- ifelse(zipdata$centile >= (100 - input$threshold), \"yes\", \"no\")\n # pal <- colorFactor(\"Spectral\", colorData)\n # } else {\n # colorData <- zipdata[[colorBy]]\n # pal <- colorBin(\"Spectral\", colorData, 7, pretty = FALSE)\n # }\n # \n # if (sizeBy == \"superzip\") {\n # # Radius is treated specially in the \"superzip\" case.\n # radius <- ifelse(zipdata$centile >= (100 - input$threshold), 30000, 3000)\n # } else {\n # radius <- zipdata[[sizeBy]] / max(zipdata[[sizeBy]]) * 30000\n # }\n # \n # leafletProxy(\"map\", data = zipdata) %>%\n # clearShapes() %>%\n # addCircles(~longitude, ~latitude, radius=radius, layerId=~zipcode,\n # stroke=FALSE, fillOpacity=0.4, fillColor=pal(colorData)) %>%\n # addLegend(\"bottomleft\", pal=pal, values=colorData, title=colorBy,\n # layerId=\"colorLegend\")\n # })\n \n # Show a popup at the given location\n # showZipcodePopup <- function(zipcode, lat, lng) {\n # selectedZip <- allzips[allzips$zipcode == zipcode,]\n # content <- as.character(tagList(\n # tags$h4(\"Score:\", as.integer(selectedZip$centile)),\n # tags$strong(HTML(sprintf(\"%s, %s %s\",\n # selectedZip$city.x, selectedZip$state.x, selectedZip$zipcode\n # ))), tags$br(),\n # sprintf(\"Median household income: %s\", dollar(selectedZip$income * 1000)), tags$br(),\n # sprintf(\"Percent of adults with BA: %s%%\", as.integer(selectedZip$college)), tags$br(),\n # sprintf(\"Adult population: %s\", selectedZip$adultpop)\n # ))\n # leafletProxy(\"map\") %>% addPopups(lng, lat, content, layerId = zipcode)\n # }\n \n # When map is clicked, show a popup with city info\n # observe({\n # leafletProxy(\"map\") %>% clearPopups()\n # event <- input$map_shape_click\n # if (is.null(event))\n # return()\n # \n # isolate({\n # showZipcodePopup(event$id, event$lat, event$lng)\n # })\n # })\n \n \n ## Data Explorer ###########################################\n \n # observe({\n # cities <- if (is.null(input$states)) character(0) else {\n # filter(cleantable, State %in% input$states) %>%\n # `$`('City') %>%\n # unique() %>%\n # sort()\n # }\n # stillSelected <- isolate(input$cities[input$cities %in% cities])\n # updateSelectInput(session, \"cities\", choices = cities,\n # selected = stillSelected)\n # })\n # \n # observe({\n # zipcodes <- if (is.null(input$states)) character(0) else {\n # cleantable %>%\n # filter(State %in% input$states,\n # is.null(input$cities) | City %in% input$cities) %>%\n # `$`('Zipcode') %>%\n # unique() %>%\n # sort()\n # }\n # stillSelected <- isolate(input$zipcodes[input$zipcodes %in% zipcodes])\n # updateSelectInput(session, \"zipcodes\", choices = zipcodes,\n # selected = stillSelected)\n # })\n # \n # observe({\n # if (is.null(input$goto))\n # return()\n # isolate({\n # map <- leafletProxy(\"map\")\n # map %>% clearPopups()\n # dist <- 0.5\n # zip <- input$goto$zip\n # lat <- input$goto$lat\n # lng <- input$goto$lng\n # showZipcodePopup(zip, lat, lng)\n # map %>% fitBounds(lng - dist, lat - dist, lng + dist, lat + dist)\n # })\n # })\n # \n # output$ziptable <- DT::renderDataTable({\n # df <- cleantable %>%\n # filter(\n # Score >= input$minScore,\n # Score <= input$maxScore,\n # is.null(input$states) | State %in% input$states,\n # is.null(input$cities) | City %in% input$cities,\n # is.null(input$zipcodes) | Zipcode %in% input$zipcodes\n # ) %>%\n # mutate(Action = paste('', sep=\"\"))\n # action <- DT::dataTableAjax(session, df)\n # \n # DT::datatable(df, server = TRUE, options = list(ajax = list(url = action)),\n # escape = FALSE)\n # })\n})\n", "created" : 1510846673071.000, "dirty" : false, "encoding" : "UTF-8", "folds" : "", "hash" : "2675624684", "id" : "2EE53CBF", "lastKnownWriteTime" : 1510851348, "last_content_update" : 1510851348843, "path" : "D:/REPOS-CHECK-OUTS/opensealab/EMODnetBootcamp/server.R", "project_path" : "server.R", "properties" : { }, "relative_order" : 8, "source_on_save" : false, "source_window" : "", "type" : "r_source" }