I have the shiny app below in which I want to pan and zoom the .svg.
library(shiny)
library(DiagrammeR)
library(tidyverse)
# probably don't need all of these:
library(DiagrammeRsvg)
library(svglite)
library(svgPanZoom)
library(rsvg)
library(V8)# only for svg export but also does not work
library(xml2)
ui <- fluidPage(
grVizOutput("grr",width = "100%",height = "90vh")
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <-
renderGrViz(reactives$graph
)
}
# Run the application
shinyApp(ui = ui, server = server)
I tried with the svgPanZoom package but could make it work. How does this work? Or an alternative option?
ui <- fluidPage(
svgPanZoomOutput("grr")
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <-
renderSvgPanZoom({
svgPanZoom(reactives$graph)
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can use the panzoom JavaScript library.
library(shiny)
library(DiagrammeR)
library(magrittr)
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/panzoom#9.4.0/dist/panzoom.min.js")
),
grVizOutput("grr", width = "100%", height = "90vh"),
tags$script(
HTML('panzoom($("#grr")[0])')
)
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <- renderGrViz(reactives$graph)
}
shinyApp(ui, server)
Related
Hello and thanks for reading me. I am currently trying to make a simple app in shiny that allows you to filter a dataframe, but I would like the filter to update every time I press the button. It works the first time, but apparently afterwards the observeEvent stays activated and the information is filtered even if you don't press the button. Is there any way to avoid this?
The code is the following:
library(shiny)
library(dplyr)
library(shinyWidgets)
x <- tibble(
val1 = 1:5,
val2 = sample(letters,5)
)
shinyApp(
ui = fluidPage(
column(width = 3, pickerInput("filt", "filter",
choices = x$val1,
selected = x$val1,
multiple = TRUE
),
actionButton("ready", "filter data")
),
column(width = 6, textOutput("text"))
),
server = function(input, output, session){
observeEvent(input$ready,{
output$text <- renderText({
x <- x |>
filter(val1 %in% input$filt)
print(x$val2)
})
})
}
)
I think the problem is in this part:
observeEvent(input$ready,{
output$text <- renderText({
x <- x |>
filter(val1 %in% input$filt)
print(x$val2)
})
})
Thanks a lot for the help
Use the bindEvent function in shiny
library(shiny)
library(dplyr)
library(shinyWidgets)
x <- tibble(
val1 = 1:5,
val2 = sample(letters,5)
)
shinyApp(
ui = fluidPage(
column(width = 3, pickerInput("filt", "filter",
choices = x$val1,
selected = x$val1,
multiple = TRUE
),
actionButton("ready", "filter data")
),
column(width = 6, textOutput("text"))
),
server = function(input, output, session){
output$text <- renderText({
x <- x |>
filter(val1 %in% input$filt)
print(x$val1)
}) |>
bindEvent(input$ready)
}
)
Try putting it in an eventReactive() call instead of observeEvent(). Your server function would look like this instead:
server = function(input, output, session) {
filter_data <- eventReactive(input$ready, {
x <- x %>%
filter(val1 %in% input$filt)
})
output$text <- renderText({
filter_data()$val2
})
}
I have used panzoom package in order to pan and zoom on my svg file in my shiny app. Is there a way to have controls like this?
library(shiny)
library(DiagrammeR)
library(magrittr)
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/panzoom#9.4.0/dist/panzoom.min.js")
),
grVizOutput("grr", width = "100%", height = "90vh"),
tags$script(
HTML('panzoom($("#grr")[0])')
)
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <- renderGrViz(reactives$graph)
}
shinyApp(ui, server)
Here is a way, but if you click too quickly on the +/- buttons, there's an undesirable effect.
library(shiny)
library(shinyWidgets)
library(DiagrammeR)
library(magrittr)
js <- '
$(document).ready(function(){
var element = document.getElementById("grr");
var instance = panzoom(element);
$("#zoomout").on("click", function(){
instance.smoothZoom(0, 0, 0.9);
});
$("#zoomin").on("click", function(){
instance.smoothZoom(0, 0, 1.1);
});
});
'
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/panzoom#9.4.0/dist/panzoom.min.js"),
tags$script(HTML(js))
),
grVizOutput("grr", width = "100%", height = "90vh"),
actionGroupButtons(
inputIds = c("zoomout", "zoomin"),
labels = list(icon("minus"), icon("plus")),
status = "primary"
)
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(
create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3
)
)
)
})
output$grr <- renderGrViz(reactives$graph)
}
shinyApp(ui, server)
EDIT
Add this JavaScript to prevent the undesirable effect:
$("#zoomout").on("dblclick", function(){
return false;
});
$("#zoomin").on("dblclick", function(){
return false;
});
Below is a Shiny app in which a Highcharter map is displayed.
When a user clicks a country, the name of the country is displayed below the map.
The app below works when it does not use modules. When implemented using a module, the country selected does not display anymore.
library(shiny)
library(highcharter)
library(dplyr)
# MODULE UI
module_ui <- function(id){
ns <- NS(id)
div(
highchartOutput(ns("hcmap")),
verbatimTextOutput(ns("country"))
)
}
# SERVER UI
module_server <- function(id){
ns <- NS(id)
moduleServer(id, function(input, output, session){
# Data
data_4_map <- download_map_data("custom/world-robinson-highres") %>%
get_data_from_map() %>%
select(`hc-key`) %>%
mutate(value = round(100 * runif(nrow(.)), 2))
# Map
click_js <- JS("function(event) {Shiny.onInputChange('hcmapclick',event.point.name);}")
output$hcmap <- renderHighchart({
hcmap(map = "custom/world-robinson-highres",
data = data_4_map,
value = "value",
joinBy = "hc-key",
name = "Pop",
download_map_data = F) %>%
hc_colorAxis(stops = color_stops()) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
# Clicked country
output$country <- renderPrint({
print(input$hcmapclick)
})
})
}
# APP UI
ui <- fluidPage(
tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"),
fluidRow(
module_ui(id = "moduleID")
)
)
# APP SERVER
server <- function(input, output, session) {
module_server(id = "moduleID")
}
shinyApp(ui, server)
EDIT
Adding the module ID to the Shiny.onInputChange function as follows, does not solve the problem.
click_js <- JS("function(event) {console.log(event.point.name); Shiny.onInputChange('moduleID-hcmapclick', event.point.name);}")
You have to add the module ID to your call back function. We can do this programmatically by using the module id in paste0 inside the JS() call:
library(shiny)
library(highcharter)
library(dplyr)
# MODULE UI
module_ui <- function(id){
div(
highchartOutput(ns("hcmap")),
verbatimTextOutput(ns("country"))
)
}
# SERVER UI
module_server <- function(id){
moduleServer(id, function(input, output, session){
# Data
data_4_map <- download_map_data("custom/world-robinson-highres") %>%
get_data_from_map() %>%
select(`hc-key`) %>%
mutate(value = round(100 * runif(nrow(.)), 2))
# Map
click_js <- JS(paste0("function(event) {Shiny.onInputChange('",id,"-hcmapclick',event.point.name);}"))
output$hcmap <- renderHighchart({
hcmap(map = "custom/world-robinson-highres",
data = data_4_map,
value = "value",
joinBy = "hc-key",
name = "Pop",
download_map_data = F) %>%
hc_colorAxis(stops = color_stops()) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
# Clicked country
output$country <- renderPrint({
print(input$hcmapclick)
})
})
}
# APP UI
ui <- fluidPage(
tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"),
fluidRow(
module_ui(id = "moduleID")
)
)
# APP SERVER
server <- function(input, output, session) {
module_server(id = "moduleID")
}
shinyApp(ui, server)
I have a shiny application where the filters here are reactive with respect to each other. Not sure there is some issue in the code. The values are not to be seen here. Can anyone help me here?
Is there any alternate way?
library(shiny)
library(readxl)
library(dplyr)
library(shinyWidgets) ## for picker input
library(shinydashboard)
library(DT)
library(tidyverse)
library(xtable)
library(shinycssloaders)
library(plotly)
library(htmlwidgets)
library(sparkline)
library(data.table)
require(reshape2)
library(glue)
data_13_Sam <- data.frame(
Ratings = c(1,2,3,4,5,1,2,3,4,5), flag = c("Yes","No","Yes","No","Yes","No","Yes","No","Yes","Yes")
)
ui <- fluidPage(
column(offset = 0, width = 1,uiOutput("rat")),
column(offset = 0, width = 2, uiOutput("nt"))
)
server <- function(input, output, session) {
filter_data <- reactive({
data_13_Sam %>% filter(flag %in% input$nt, Ratings %in% input$rat)
})
##### nt
output$nt <- renderUI({
selectInput("nt",label = tags$h4("New"),choices = unique(filter_data()$flag))
})
###### rat
output$rat <- renderUI({
selectInput("rat",label = tags$h4("Rat"),choices = unique(filter_data()$Ratings))
})
}
shinyApp(ui, server)
I also tried with this second approach as well . But did not work. Writing to csv file and then pulling from that
library(shiny)
library(readr)
library(dplyr)
data_13_Sam <- data.frame(
Ratings = c(1,2,3,4,5,1,2,3,4,5), flag = c("Yes","No","Yes","No","Yes","No","Yes","No","Yes","Yes"),
fle = c("All","All","All","All","All","All","All","All","All","All")
)
ui <- fluidPage(
column(offset = 0, width = 1,uiOutput("all")),
column(offset = 0, width = 1,uiOutput("rat")),
column(offset = 0, width = 2, uiOutput("nt")),
tableOutput('data')
)
server <- function(input, output, session) {
observeEvent(input$rat,{
grp_by <- data_13_Sam %>% filter(Ratings %in% input$rat) %>% group_by(flag) %>% summarise(Det= n())
write.csv(grp_by,"grp_by.csv")
})
observeEvent(input$nt,{
grp_by_nt <- data_13_Sam %>% filter(flag %in% input$nt) %>% group_by(Ratings) %>% summarise(Det= n())
write.csv(grp_by_nt,"grp_by_nt.csv")
})
output$rat <- renderUI({
if(!is.null(input$nt)){grp_by_nt_read <- read_csv("grp_by_nt.csv")}
selectInput("rat",label = tags$h4("Rat"),choices = unique(grp_by_nt_read$Ratings))
})
output$nt <- renderUI({
if(!is.null(input$rat)){grp_by_read <- read_csv("grp_by.csv")}
selectInput("nt",label = tags$h4("New"),choices = unique(grp_by_read$flag))
})
}
shinyApp(ui, server)
You have created a circular dependency. A needs B, B needs C but C needs A. So it is not able to complete anything.
You can try this -
library(shiny)
data_13_Sam <- data.frame(
Ratings = c(1,2,3,4,5,1,2,3,4,5), flag = c("Yes","No","Yes","No","Yes","No","Yes","No","Yes","No")
)
ui <- fluidPage(
column(offset = 0, width = 1,uiOutput("rat")),
column(offset = 0, width = 2, uiOutput("nt")),
tableOutput('data')
)
server <- function(input, output, session) {
filter_data <- reactive({
data_13_Sam %>% filter(flag %in% input$nt, Ratings %in% input$rat)
})
output$rat <- renderUI({
selectInput("rat",label = tags$h4("Rat"),choices = unique(data_13_Sam$Ratings))
})
output$nt <- renderUI({
req(input$rat)
selectInput("nt",label = tags$h4("New"),choices = unique(data_13_Sam$flag[data_13_Sam$Ratings == input$rat]))
})
output$data <- renderTable({filter_data()})
}
shinyApp(ui, server)
So rat displays all the ratings and only for those ratings we display the nt values. You can also reverse this condition if needed to show all values of nt and based on it's selection show rat values.
I would like to update a table which is edited in Shiny App. I can't figure out why in below code mean() works fine within observeEvent() but fails to update itself in output$tekst.
library(shiny)
library(DT)
ui <- fluidPage(
textOutput('tekst'),
DTOutput('tabela')
)
server <- function(input, output) {
A <- data.frame("a" = c(1,2,6,5,NA,1), "b" = c(2,2,NA,5,7,NA))
output$tabela = renderDT(A
, selection = 'none'
, editable = 'column')
observeEvent(input$tabela_cell_edit, {
A <<- editData(A, input$tabela_cell_edit, 'tabela')
cat(mean(A$a, na.rm = TRUE), "\n\n")
})
output$tekst <- renderText({mean(A$a, na.rm = TRUE)})
}
shinyApp(ui = ui, server = server)
Help :)
Use a reactive value:
library(shiny)
library(DT)
ui <- fluidPage(
textOutput('tekst'),
DTOutput('tabela')
)
server <- function(input, output) {
A <- data.frame("a" = c(1,2,6,5,NA,1), "b" = c(2,2,NA,5,7,NA))
reactA <- reactiveVal(A)
output$tabela = renderDT(A
, selection = 'none'
, editable = 'column')
observeEvent(input$tabela_cell_edit, {
reactA(editData(reactA(), input$tabela_cell_edit, 'tabela'))
})
output$tekst <- renderText({mean(reactA()$a, na.rm = TRUE)})
}
shinyApp(ui = ui, server = server)