I am building and app, that includes geolocation captures using the geoloc package
This is an example app:
library(shiny)
library(leaflet)
library(geoloc)
ui <- fluidPage(
h2("Where Am I?"),
tags$p("Click the button to get your location"),
geoloc::button_geoloc("myBtn", "Get my Location"),
tags$br(),
textOutput("coords"),
textOutput("col"),
leafletOutput("lf")
)
server <- function(input, output) {
output$coords <- renderText(paste(input$myBtn_lat, input$myBtn_lon, sep = ", "))
Lats <- reactiveValues(Lat = NULL)
observeEvent(input$myBtn_lat, {
Lats$Lat <- append(Lats$Lat, input$myBtn_lat)
})
output$col <- renderText({
Lats$Lat
})
output$lf <- renderLeaflet({
req(input$myBtn_lon)
req(input$myBtn_lat)
leaflet() %>%
addTiles() %>%
setView(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), zoom = 17) %>%
addMarkers(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), label = "You're here!")
})
}
shinyApp(ui, server)
I have two questions for this:
How to get a vector of latitudes and longitudes with the button
I need this because usually, we like to take 4 or 5 times the location and then use the median.
This has been addressed in this question, however, there are some kinks I can't figure out since the button is a custom one, and the inputs are not input$myBtn, but input$myBtn_lat and input$myBtn_lon, I find it hard to compute. This is what I am trying to do with the observe events
How to transform this into shiny modules
This will go to a larger shiny app, so I would love to generate modules for this, but again, the facto that the input in ui is "myBtn", but then in the server I have 2 inputs (MyBtn_lon and MyBtn_lat), make it very hard to figure out
Any help is welcome
How about the following code with Shiny modules? I tested and it worked.
library(shiny)
library(leaflet)
library(geoloc)
mapUI <- function(id, label = "Location in map"){
ns <- NS(id)
tagList(
geoloc::button_geoloc(ns("myBtn"), "Get my Location"),
tags$br(),
textOutput(ns("coords")),
textOutput(ns("col")),
textOutput(ns("md")), # for median latitude
leafletOutput(ns("lf"))
)
}
mapServer <- function(id){
moduleServer(
id,
function(input, output, session){
output$coords <- renderText(paste(input$myBtn_lat, input$myBtn_lon, sep = ", "))
Lats <- reactiveValues(Lat = NULL)
observeEvent(input$myBtn, {
Lats$Lat <- c(Lats$Lat, input$myBtn_lat)
})
output$col <- renderText({
Lats$Lat
})
# add median latitude
output$md <- renderText({
req(input$myBtn_lat)
if(length(Lats$Lat) %% 5 == 0){
paste0("Median latitute is: ", median(Lats$Lat))
}
})
output$lf <- renderLeaflet({
req(input$myBtn_lon)
req(input$myBtn_lat)
leaflet() %>%
addTiles() %>%
setView(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), zoom = 17) %>%
addMarkers(as.numeric(input$myBtn_lon), as.numeric(input$myBtn_lat), label = "You're here!")
})
}
)
}
ui <- fluidPage(
h2("Where Am I?"),
tags$p("Click the button to get your location"),
mapUI("map1")
)
server <- function(input, output, session) {
mapServer("map1")
}
shinyApp(ui, server)
You should click "myBtn", not "myBtn_lat". So try change observeEvent(input$myBtn_lat to observeEvent(input$myBtn.
In addition, what is the purpose to take 4 or 5 times the location? The coordinates do not change or change very little every time you click the button.
Related
why when Im using modules the clickable feature in my highchart treemap is not working.
I tried this without module and worked well.
Probably is something related no namespace, right , but I can not find what it it.
Any help ?
This is my code:
library(shiny)
library(highcharter)
library(gapminder)
library(shinyjs)
source(file = 'module_ex_2.R')
ui <- fluidPage(
mod_ex2_UI('ex1')
)
server <- function(input, output){
mod_ex2_Server('ex1')
}
shinyApp(ui, server)
My module file:
mod_ex2_UI <- function(id) {
ns <- NS(id)
tagList(
highchartOutput(ns("hcontainer")),
htmlOutput(ns("clicked"))
)
}
mod_ex2_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
click_js <- JS("function(event) {Shiny.onInputChange('treemapclick', event.point.name);}")
output$hcontainer <- renderHighchart({
gapminder::gapminder %>%
dplyr::filter(year == 2007) %>%
highcharter::data_to_hierarchical(group_vars = c(continent, country), size_var = pop) %>%
hchart(type = "treemap") %>%
hc_plotOptions(treemap = list(events = list(click = click_js)))
})
output$clicked <- renderUI({
if(is.null(input$treemapclick)){
reactable::reactable(data =gapminder::gapminder %>%
dplyr::filter(year == 2007) %>%
dplyr::filter(country == 'China'))
}else{
reactable::reactable(data =gapminder::gapminder %>%
dplyr::filter(year == 2007) %>%
dplyr::filter(country == input$treemapclick))
}
})
}
)
}
Thanks any help would be amazing.
You need to append the namespace to your custom event like so:
click_js <- JS(
glue::glue("function(event) {{
Shiny.setInputValue('{NS(id)('treemapclick')}',
event.point.name);
}}"
)
)
N.B. onInputChange is the older name for setInputValue and the latter is more verbose (cf. to this Shiny article)
Based on the answer to this question: Highcharter - Clickable Pie Chart - How to get the category name from the slice clicked on a Pie Chart in Shiny?, I am trying to capture the output of a click event on a highcharter treemap in an R Shiny app.
I think I just need the right name to replace "event.point.name" in this javascript function:
function(event) {Shiny.onInputChange('treemapclick', event.point.name);}
but I am not sure where to look.
Thanks in advance for your generosity!
library(shiny)
library(highcharter)
library(gapminder)
ui <- fluidPage(
column(12, highchartOutput("hcontainer",height = "300px")),
column(12, textOutput("clicked")))
server <- function(input, output){
click_js <- JS("function(event) {Shiny.onInputChange('treemapclick', event.point.name);}")
output$hcontainer <- renderHighchart({
gapminder::gapminder %>%
filter(year == 2007) %>%
highcharter::data_to_hierarchical(group_vars = c(continent, country), size_var = pop) %>%
hchart(type = "treemap") %>%
hc_plotOptions(events = list(click = click_js))
})
output$clicked <- renderText({
input$treemapclick
})
}
shinyApp(ui, server)
Figured out the problem! The issue was not with the event.point.name variable, but with the plot options. Changing it to this:
hc_plotOptions(treemap = list(events = list(click = click_js)))
does the trick.
Working reprex:
library(shiny)
library(highcharter)
library(gapminder)
ui <- fluidPage(
column(12, highchartOutput("hcontainer",height = "300px")),
column(12, textOutput("clicked")))
server <- function(input, output){
click_js <- JS("function(event) {Shiny.onInputChange('treemapclick', event.point.name);}")
output$hcontainer <- renderHighchart({
gapminder::gapminder %>%
filter(year == 2007) %>%
highcharter::data_to_hierarchical(group_vars = c(continent, country), size_var = pop) %>%
hchart(type = "treemap") %>%
hc_plotOptions(treemap = list(events = list(click = click_js)))
})
output$clicked <- renderText({input$treemapclick })
}
shinyApp(ui, server)
does anyone know how I can, inside a shiny application, get the cursor position inside a textAreaInput ?
library(shiny)
ui <- fluidPage(
textAreaInput("hop"
,label="textarea",value = "Supercalifragilisticexpialidocious"),
verbatimTextOutput("out")
)
server <- function(input, output, session) {
output$out <- renderText({
"here I would like to get the cursor position (an interger?) \n inside que textArea"
})
}
shinyApp(ui, server)
I think I have to use javascript, but I don't know where to start.
Regards
this is a solution I found :
library(shiny)
ui <- fluidPage(tags$head(tags$script(
'Shiny.addCustomMessageHandler("prout",
function(NULL) {
var ctl = document.getElementById("hop");
var startPos = ctl.selectionStart;
var endPos = ctl.selectionEnd;
alert(startPos + ", " + endPos);
});'
)),
textAreaInput("hop"
,label="textarea",value = "Supercalifragilisticexpialidocious"),
verbatimTextOutput("out"),
actionButton("hop","hop")
)
server <- function(input, output, session) {
output$out <- renderText({
"here I would like to get the cursor position (an interger?) \n inside que textArea"
})
observeEvent(input$hop,{
message("hop")
session$sendCustomMessage(type="prout",message=list(NULL))
})
}
shinyApp(ui, server)
I've been trying to add a row (basically a row of check boxes) on my data table, so that users will be able to decide which column they like to keep/delete. And here is what my Shiny App looks like so far. Anyone who knows any hints please help!
Any help would be appreciated!
ui <- dashboardPage(dashboardHeader(disable = T),
dashboardSidebar(disable = T),
dashboardBody(uiOutput("MainBody")))
server <- shinyServer(function(input, output){
vals <- reactiveValues()
vals$data <- data.table(vals$Data<-data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
))
output$MainBody <- renderUI({
fluidPage(
box(width = 12,
h3(strong("Template"), align = "center"),
hr(),
column(6, offset = 6,
actionButton(inputId = "Del_Col", label = "Delete Select Column"))),
column(12, dataTableOutput("MainTable")),
tags$script()
)
})
I agree with Pork Chop that you should rethink your layout. I couldn't get my head around it so I reworked it into a minimal fluidpage.
The code below should get you close. It renders buttons (you could make these checkboxes though) directly into the table using a helper function described here. The code below uses these buttons to subset and update the dataframe which I term reactiveTable. Here's the functionality:
Good luck!
library(data.table)
library(DT)
## Nice helper function to make the buttons from:
## https://github.com/rstudio/DT/issues/178
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
## Basic UI with a reset button
ui <- fluidPage(
mainPanel(
h1('Table Subsetter'),
actionButton('reset', 'Reset!'),
DT::dataTableOutput('mytable')
)
)
server <- function(input, output){
#This is the table you provided in your question
tableA <- data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
)
#make a reactive value for the table and columns to delete
reactiveTable <- reactiveValues(tab=tableA)
columnToDelete <- reactiveValues(col=NULL)
#Logic to make the buttons, reruns everytime the table is updated
tableOut <- reactive({
buttons <- shinyInput(actionButton, length(reactiveTable$tab[1,]), 'button_', label = "Delete!", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' )
buttons <- t(as.data.frame(buttons, stringsAsFactors = FALSE))
colnames(buttons) = colnames(reactiveTable$tab)
rbind(buttons, reactiveTable$tab)
})
#reset button replaces the table
observeEvent(input$reset, {
reactiveTable$tab <- tableA
})
#listener to for the delete button
observeEvent(input$select_button, {
columnToDelete$col <-as.numeric(strsplit(input$select_button, "_")[[1]][2])
reactiveTable$tab <- subset( reactiveTable$tab, select = -columnToDelete$col )
})
#output the table with DT. use escape=F so it renders the html
output$mytable <- DT::renderDataTable({
tableOut()
},server = FALSE, escape = FALSE, selection = 'none')
}
shinyApp(ui = ui, server = server)
I'm currently trying to use a googlelayer as a base layer for a leaflet map in shiny R, that's why I've been using shinyJs in order to insert a Js script into my R code in order to insert a map, the thing is that I don't manage to access the map outside of the Javascript code, and if I look up to the Js console, it says that "the map container has already been initialized". I provide you the code of the app as a reproducible science.
###################
#### Library ######
###################
library(leaflet)
library(shiny)
library(shinythemes)
library(shinyjs)
#library(raster)
###################
setwd("D:\\R")
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", href="https://unpkg.com/leaflet#1.0.3/dist/leaflet.css"),
tags$script(src="shared/shiny.js"),
tags$script(src="https://maps.googleapis.com/maps/api/js?key=AIzaSyAQvaBc5_RruTllCvOxy3i9YNFYlaDzaJ8"),
tags$script(src="https://unpkg.com/leaflet#1.0.3/dist/leaflet.js"),
tags$script(src='https://unpkg.com/leaflet.gridlayer.googlemutant#latest/Leaflet.GoogleMutant.js')
),
sidebarLayout(
sidebarPanel(
actionButton(inputId = "button",
label = "coucou")
),
mainPanel(
leafletOutput("mymap")
)
#)
),
tags$script(HTML('$(document).on("shiny:connected", function(){
var mymap = L.map("mymap").setView([45.777222,3.087025],4);
var roads = L.gridLayer.googleMutant({type : "satellite"}).addTo(mymap);
var el = document.getElementById(mymap.id);
Shiny.onInputChange("mymap",el);
})'))
)
server <- function(input, output) {
# output$mymap <- renderLeaflet({
# leaflet() %>%
# setView(-1.252441, 47.802332, 4)
# })
# jean <- reactive(input$el)
#print(output$mymap)
observeEvent(input$button, {
output$mymap <- renderLeaflet({
leafletProxy("mymap", data =input$mymap) %>%
addMarkers(45.777222,
3.087025,
"btn")
})
})
observeEvent(input$mymap_click, {
cat("vroum")
})
}
shinyApp(ui = ui, server = server)
You can plot a Google Map directly using my googleway package
library(shiny)
library(googleway)
ui <- fluidPage(
google_mapOutput(outputId = "map", height = 600)
)
server <- function(input, output){
output$map <- renderGoogle_map({
google_map(key = 'your_api_key')
})
observeEvent(input$map_map_click, {
print(input$map_map_click)
})
}
shinyApp(ui, server)
To answer your question, you can access the map using the following code:
var el = document.getElementById("mymap");
var map = $(el).data("leaflet-map"));
But this doesn't get you to add the google layer as you need leaflet version 1.0.3 and the R package uses version 0.7 and you can't just load the version 1.0.3 as you did because it will raise come compatibility issues with the R package.
I'm trying to do the same but I found nothing so far. If you managed to do it, I would be very happy to know how.