I have the following code on my Server. R
data_agg_plot1<- reactive({
brush1 <- linked_brush(keys = data_agg()$id, "navy" )
data_agg <- data_agg()
plot1<-data_agg%>%
ggvis(x = ~dates_all) %>%
group_by(factor(dates_all.1)) %>%
layer_points(y = ~ value, fill =~dates_all.1, shape =~dates_all.1) %>%
layer_paths(y = ~ value, stroke = ~dates_all.1 , strokeOpacity := 0.5) %>%
scale_ordinal("fill", range = c("green", "red", "blue"))%>%
scale_ordinal("shape", range = c("triangle-up","triangle-down","circle")) %>%
scale_ordinal("stroke",range=c("green","red","blue")) %>%
brush1$input() %>%
hide_legend(c('stroke','fill'))%>%
add_legend(c('shape','fill'),
title = "Symbol", orient = "left",
values = c("New hires", "Attrition" , "Net Growth"),
properties = legend_props(
title = list(fontSize = 16))) %>%
add_axis("x",properties= axis_props(labels = list(angle=60,align = "left")),
tick_padding =0,
title = "") %>%
add_axis("y", title = "Total Count") %>%
set_options(width = "auto",height = 400) %>%
scale_numeric('y',clamp = TRUE)
return(list(plot1,brush1))
})
so this is a reactive function that returns me a list of 2 functions, a plot and my brush object.
the purpose of doing so is so that I can make my keys reactive - this is so that I can make an additional plot based on my user's selection. think of it as the second plot depends on what the first user highlights in the first plot.
this is my following code:
plot1_data<-reactive({
data_agg_plot1()[[1]]
})
plot1_data%>%bind_shiny("plot1")
selected_plot1 <- reactive({
data_agg_plot1()[[2]]
})
output$test <- renderPrint({
temp <- selected_plot1()$selected()
print(temp)
})
however, when I print out the selection, it is all false,
please refer to the image below:
can anybody explain to me how to overcome this?
I highly suspect I have to re-write my linkedbrush function,
I have tried both solutions from:
linked_brush in ggvis cannot work in Shiny when data change
but it does not work.
Related
I have a shiny app that lets the user add categories to the facet_wrap. When I start with one category the plot fills the entire box but when I add a second category, the initial plot adjusts to half the initial size. Is there any way I can set the size, such that the first facet fits half the box and doesn't adjust in size when I add a second category?
Here's what I happens when I choose a second facet category:
Current behavior
Here's what I want to happen:
desired behavior
Here is a simple reprex--when you add a second feature from select feature, it adjusts the size of the first plot.
I found a decent solution and added it to this example using the ggh4x::facet_manual. However, this solution does not work with ggplotly and in a bs4dash box, it starts to look crammed in my app where there are upwards of 40 plots. Ideally, I'd like the box to be scrollable. Thanks in advance for any suggestions!
library(shiny)
library(tidyverse)
library(glue)
library(ggh4x)
library(plotly)
library(janitor)
library(bs4Dash)
iris_df <- iris %>%
clean_names() %>%
mutate(extra_feature1 = sepal_length,
extra_feature2 = sepal_width,
extra_feature3 = petal_length,
extra_feature4 = petal_width,
extra_feature5 = sepal_length,
extra_feature6 = sepal_width,
extra_feature7 = petal_length,
extra_feature8 = petal_width) %>%
select(species, everything()) %>%
pivot_longer(-species) %>%
mutate(feature = glue("{name}_{species}"))
iris_species <- iris_df %>%
clean_names() %>%
distinct(species) %>%
pull()
iris_features <- iris_df %>%
clean_names() %>%
distinct(feature) %>%
pull()
# Define UI for application that draws a histogram
ui <- dashboardPage(dark = FALSE,
# Application title
dashboardHeader("Reprex"),
# Sidebar with a slider input for number of bins
dashboardSidebar(skin = "light",
selectInput("species",
"Select species:",
choices = iris_species,
selectize = FALSE,
multiple = TRUE,
selected = iris_species[1]
),
selectInput("features",
"Select feature:",
choices = iris_features,
selectize = TRUE,
multiple = TRUE,
selected = iris_features[1]
),
radioButtons("facets", label = "View all features:",
choices = list("On" = "facet_wrap", "Off" = ""),
selected = "", inline = FALSE)),
# Show a plot of the generated distribution
dashboardBody(
fluidRow(box(
plotOutput("densityPlot"),
width=12,
headerBorder = FALSE,
collapsible = FALSE))
))
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observeEvent(input$species,
{updateSelectInput(session,
"features",
choices = unique(iris_df$feature[iris_df$species == input$species]),
selected = iris_df$feature[1])
})
design <- matrix(c(1:12), 2, 6, byrow = FALSE)
output$densityPlot <- renderPlot({
if (input$facets == '') {
p1 <- iris_df %>%
filter(species %in% input$species) %>%
filter(feature %in% input$features) %>%
ggplot(aes(value, fill = species)) +
geom_density(alpha = .5) +
theme_light() +
facet_manual(~name, scales = "free", design = t(design), respect = FALSE)
#facet_wrap(~name, scales = "free")
p1
}
else {
iris_df %>%
filter(species %in% input$species) %>%
ggplot(aes(value, fill = species)) +
geom_density(alpha = .5) +
theme_light() +
facet_wrap(~name, ncol = 2, scales = "free")
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am mapping out zip code areas in leaflet and coloring the polygon based on the Dealer.
Dealer Zipcodes geometry
A 32505 list(list(c(.....)))
B 32505 ....
This code is used to create the colors, labels, and the map.
factpal <- colorFactor(topo.colors(5), data$Dealer)
labels <- paste0("Zip Code: ",data$Zipcodes, ", Dealer: ", data$Dealer)
leaflet(data) %>%
addTiles() %>%
addPolygons( color = ~factpal(Dealer),),
label = labels) %>%
leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright")
When the zip code (and thus the geometry) are the same between two dealers, only one label is visible, though it is clear colors are overlapping. All I want is for that label to somehow show the info for both dealers in that zip code. Please let me know if there is code missing you need, or clarification needed.
Not sure whether you could have multiple tooltips but to show all Dealers in the tooltip you could change your labels such that they include all dealer names per zip code, e.g. making use of dplyr you could do:
library(leaflet)
library(dplyr)
factpal <- colorFactor(topo.colors(5), data$Dealer)
data <- data %>%
group_by(Zipcodes) %>%
mutate(labels = paste(Dealer, collapse = ", "),
labels = paste0("Zip Code: ", Zipcodes, ", Dealer: ", labels))
leaflet(data) %>%
addTiles() %>%
addPolygons(
color = ~factpal(Dealer),
label = ~labels,
weight = 1
) %>%
# leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(
pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright"
)
DATA
nycounties <- rgdal::readOGR("https://eric.clst.org/assets/wiki/uploads/Stuff/gz_2010_us_050_00_20m.json")
nycounties_sf <- sf::st_as_sf(nycounties)
nycounties_sf_n <- nycounties_sf %>%
filter(STATE == "01") %>%
select(Zipcodes = COUNTY, geometry)
data <- list(
A = sample_n(nycounties_sf_n, 40),
B = sample_n(nycounties_sf_n, 40),
C = sample_n(nycounties_sf_n, 40),
D = sample_n(nycounties_sf_n, 40)
)
data <- purrr::imap(data, ~ mutate(.x, Dealer = .y))
data <- do.call("rbind", data)
at the moment I try to create an interactive heatmap in R with apexcharter. This works fine at manual chart creation but fails on interactive use within shiny.
library(shiny)
library(tidyverse)
library(apexcharter)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Test Heatmap"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "heatmap_filter",
label = "heatmap filter",
choices = c(1999, 2008),
selected = 2008
)
),
mainPanel(
apexchartOutput("heatmap")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$heatmap <- renderApexchart({
df <- mpg %>% filter(year == input$heatmap_filter) %>% mutate_if(is.character, as.factor) %>% group_by(manufacturer, class) %>% summarise(cnt = n()) %>% tidyr::complete(class, fill = list(cnt = 0))
q20 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[2],0)
q40 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[3],0)
q60 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[4],0)
q80 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[5],0)
apex(
data = df,
type = "heatmap",
mapping = aes(x = manufacturer, y = class, fill = cnt)
) %>%
ax_dataLabels(enabled = TRUE) %>%
ax_plotOptions(
heatmap = heatmap_opts(
enableShades = FALSE,
colorScale = list(
ranges = list(
list(from = 0, to = q20, color = "#106e45"), #grün
list(from = q20, to = q40, color = "#90dbba"), #leichtes grün
list(from = q40, to = q60, color = "#fff33b"), #gelb
list(from = q60, to = q80, color = "#f3903f"), # orange
list(from = q80, to = 20, color = "#e93e3a") #rot
)
)
)
) %>%
ax_title(
text = paste("Test interactive heatmap",
input$heatmap_filter
), align = "center"
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
With the manual approach everthing works as expected. But when I change the input select only the values changes but not the heatmap quantil ranges and not the title input. Its seems like the input value is not pushing the changes to already calculated variables. I already tried to use an reactive df or reactive variables but so far nothing works.
I added a minimal example where you could change the year input and this should change the title and the color ranges.
Can you help me?
Thanks in advance.
Try setting auto_update to FALSE in the call to apex
apex(
data = df,
type = "heatmap",
auto_update = FALSE,
...
I am in the process of creating an R flexdashboard. The dashboard contains several maps for Bangladesh, which are linked to a (Highcharts) chart that is activated by clicking on a polygon (e.g. region). I am able to make it work for one page. However, if I set it up for two pages, things no longer work.
It seems that flexdashboard (at least how I set it up) is not able to handle two input$map_shape_click operations at the same time. At the moment it only works on the first page, while the map does not react on the second page although a figure is produced. I welcome any suggestions to make this work.
Below a reproducible example. Note that (1) I omitted the flexdashboard yaml in the example and (2) markdown used by stackoverflow automatically renders the first, second and third header level. They render differently when run in flexdasboard (i.e. A Large Header is a new page in flexdashboard).
# Packages
library(tidyverse)
library(raster)
library(sf)
library(highcharter)
library(leaflet)
library(htmltools)
# Get data
adm1 <- getData('GADM', country='BGD', level=1)
adm1 <- st_as_sf(adm1)
# Create dummy data.frames with link to polygon
df1 <- data.frame(NAME_1 = adm1$NAME_1,
value_1 = c(1:7))
df2 <- data.frame(NAME_1 = adm1$NAME_1,
value_2 = c(8:14))
Page 1
Column {data-width=350}
Map 1
# MAIN MAP --------------------------------------------------------------------------------
output$map <- renderLeaflet({
# Base map
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
clearShapes() %>%
addPolygons(data = adm1,
smoothFactor = 0,
color = "black",
opacity = 1,
fillColor = "transparent",
weight = 0.5,
stroke = TRUE,
label = ~htmlEscape(NAME_1),
layerId = ~NAME_1,
)
})
leafletOutput('map')
# REGION SELECTION -----------------------------------------------------------------------
# Click event for the map to draw chart
click_poly <- eventReactive(input$map_shape_click, {
x <- input$map_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
observe({
req(click_poly()) # do this if click_poly() is not null
# Add the clicked poly and remove when a new one is clicked
map <- leafletProxy('map') %>%
removeShape('NAME_1') %>%
addPolygons(data = adm1[adm1$NAME_1 == click_poly(), ],
fill = FALSE,
weight = 4,
color = '#d01010',
opacity = 1,
layerId = 'NAME_1')
})
Column {data-width=350}
Plot 1
data <- reactive({
# Fetch data for the click poly
out <- df1[df1$NAME_1 == click_poly(), ]
print("page 1") # print statement to show which click_poly is used
return(out)
})
output$plot <- renderHighchart({
req(data()) # do this if click_poly() is not null
chart <- highchart() %>%
hc_chart(type = 'column') %>%
hc_legend(enabled = FALSE) %>%
hc_xAxis(categories = c('A'),
title = list(text = 'Title 1')) %>%
hc_yAxis(title = list(text = 'Value 1')) %>%
hc_plotOptions(series = list(dataLabels = list(enabled = TRUE))) %>%
hc_add_series(name = 'Series',
data = c(data()$value_1)) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_colors(c('#d01010'))
})
highchartOutput('plot')
Page 2
Column {data-width=350}
Map 2
# MAIN MAP --------------------------------------------------------------------------------
output$map2 <- renderLeaflet({
# Base map
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
clearShapes() %>%
addPolygons(data = adm1,
smoothFactor = 0,
color = "black",
opacity = 1,
fillColor = "transparent",
weight = 0.5,
stroke = TRUE,
label = ~htmlEscape(NAME_1),
layerId = ~NAME_1,
)
})
leafletOutput('map2')
# REGION SELECTION -----------------------------------------------------------------------
# Click event for the map to draw chart
click_poly2 <- eventReactive(input$map_shape_click, {
x <- input$map_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
observe({
req(click_poly2()) # do this if click_poly() is not null
# Add the clicked poly and remove when a new one is clicked
map <- leafletProxy('map2') %>%
removeShape('NAME_1') %>%
addPolygons(data = adm1[adm1$NAME_1 == click_poly2(), ],
fill = FALSE,
weight = 4,
color = '#d01010',
opacity = 1,
layerId = 'NAME_1')
})
Column {data-width=350}
Plot 2
data2 <- reactive({
# Fetch data for the click poly
out <- df2[df2$NAME_1 == click_poly2(), ]
print("page 2") # print statement to show which click_poly is used
return(out)
})
output$plot2 <- renderHighchart({
req(data2()) # do this if click_poly() is not null
chart <- highchart() %>%
hc_chart(type = 'column') %>%
hc_legend(enabled = FALSE) %>%
hc_xAxis(categories = c('A'),
title = list(text = 'Title 2')) %>%
hc_yAxis(title = list(text = 'Value 2')) %>%
hc_plotOptions(series = list(dataLabels = list(enabled = TRUE))) %>%
hc_add_series(name = 'Series',
data = c(data2()$value_2)) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_colors(c('#d01010'))
})
highchartOutput('plot2')
In your click_poly2 <- eventReactive(input$map_shape_click, you have click_poly2 being the 2nd map, but you have the same map_shape_click, what if you made it map_shape_click2, hopefully flexdashboard will handle it differently as now they are 2 different maps
I figured out the answer myself following a similar question I found somewhere else. As I am quite new to shiny and based my code on examples I found, I did not realize that 'map_shape_click' applies 'shape_click' on 'map' where 'map' corresponds with the map in output$map. As I have two maps: map and map2, the eventReactive statement for page2 should be changed into
click_poly2 <- eventReactive(input$map2_shape_click, {
x <- input$map2_shape_click
y <- x$id
return(y)
}, ignoreNULL = TRUE)
Now responding to a shape_click on map2
I created a chart using highcharter in a shiny dashboard and I am trying to customize the tooltip. The chart is combined line and scatter plot. I would like it to do the following:
1) Have a single box for hover information (it currently has one for the line and one for scatter)
2) Be able to use different column of information that is not used in the series x or y values
I would like the tooltip to display the following information (whether I hover over the scatter point or line) for each particular x-axis value.
Overall
Mean: 2 [Mean: data$avghours]
Dog: 1 [data$animal: data$hours]
Below is the example code I've written that demonstrates my problem:
library (shiny)
library (shinydashboard)
library (highcharter)
header <- dashboardHeader(title = "Example")
body <- dashboardBody(
fluidRow(
box(title = "example", status = "primary", solidHeader = TRUE,
highchartOutput("chart")
)
)
)
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
date <- c(1,2,3,4,5,6,7,8,9,10)
hours <- c(1,5,4,1,6,5,7,5,4,3)
avghours <- c(2,2,2,3,3,3,2,2,2,2)
animal <- c("dog","cat","cat","cat","cat","cat","cat","cat","dog","dog")
data <- data.frame(date,hours,avghours,animal)
output$chart <- renderHighchart({
highchart() %>%
hc_add_series(name = "Shipments", data=data$hours, type = "scatter", color = "#2670FF", marker = list(radius = 2), alpha = 0.5) %>%
hc_add_series(name = "Rolling Mean", data=data$avghours, color = "#FF7900") %>%
hc_yAxis(min = 0, title = list(text = "Hours")) %>%
hc_tooltip(crosshairs = TRUE)
})
}
shinyApp(ui, server)
Firt of all, you need to add all the data instead give only the vector (the vector DON´T have all the information to the tooltip you want).
To do this you need change the data argument using the data.frame with the hcaes helper function in the mapping argument to define which variable use in every axis:
highchart() %>%
hc_add_series(data = data, mapping = hcaes(x=date, y=hours), name = "Shipments", type = "scatter", color = "#2670FF", marker = list(radius = 2), alpha = 0.5) %>%
hc_add_series(data = data, hcaes(date, avghours), name = "Rolling Mean", type = "line", color = "#FF7900") %>%
hc_yAxis(min = 0, title = list(text = "Hours")) %>%
hc_tooltip(crosshairs = TRUE)
Then you can use the tooltip argument in every hc_add_series to define the tooltip in each series:
highchart() %>%
hc_add_series(data = data, hcaes(date, hours), name = "Shipments", type = "scatter",
tooltip = list(pointFormat = "tooltip with 2 values {point.animal}: {point.hours}")) %>%
hc_add_series(data = data, hcaes(date, avghours), name = "Rolling Mean", type = "line",
tooltip = list(pointFormat = "Avg hour text! {point.avghours}")) %>%
hc_yAxis(min = 0, title = list(text = "Hours")) %>%
hc_tooltip(crosshairs = TRUE)