I'm just learning Shiny.
Here's the code that doesn't work (along with some sample data built-in):
library(tidyverse)
library(shiny)
library(plotly)
library(shinyjs)
analysis_df<- data.frame(
report_month = c("jan","jan","jan","jan","jan","jan"),
payee_id = c("59","59","59","59","59","59"),
Payee = sample(LETTERS[1:5],6,replace = TRUE),
Attrib_1 = sample(LETTERS[6:10],6,replace = TRUE),
Attrib_2 = sample(LETTERS[11:15],6,replace = TRUE),
country_of_sale_iso2 = c("AU","AU","AU","NZ","AU","AU"),
currency = c("USD","USD","USD","USD","USD","USD"),
Attrib_3 = c("Pandora-AU","Pandora-AU","Pandora-AU","Pandora-AU","Pandora-AU","Pandora-AU"),
month_paid = c("jun","jun","jun","jun","jun","jun"),
Attrib_4 = sample(LETTERS[16:20],6,replace = TRUE),
Attrib_5 = sample(LETTERS[21:25],6,replace = TRUE),
units = c("2","8","6","2","10","4"),
gross = c("0.003254785","0.013019141","0.009764356","0.003254785","0.016273926","0.00650957"),
reserves_wh = c("0","0","0","0","0","0"),
rsrv_liq = c("0","0","0","0","0","0"),
Attrib_7 = c("0.002753548","0.011014193","0.008260645","0.002753548","0.013767741","0.005507097"),
Attrib_8 = c("3.25E-04","0.001301914","9.76E-04","3.25E-04","0.001627393","6.51E-04"),
Attrib_9 = c("1.76E-04","7.03E-04","5.27E-04","1.76E-04","8.79E-04","3.52E-04"),
Attrib_10 = c("0.03","0.03","0.03","0.03","0.03","0.03"),
Attrib_11 = c("1","1","1","1","1","1"),
Attrib_12 = c("0.003254785","0.013019141","0.009764356","0.003254785","0.016273926","0.00650957")
)
attribs <- c("Attrib_1","Attrib_2","Attrib_3","Attrib_4")
payees <- analysis_df %>% distinct(Payee) %>% as.vector()
ui <- fluidPage(
headerPanel("Product Explorer"),
sidebarPanel(
selectInput('slice_by', 'Color the Bars By:', choices = attribs, selected = "Attrib_1"),
sliderInput('plotHeight', 'Adjust Chart Size',
min = 100, max = 2000, value = 425)
),
mainPanel(
plotlyOutput('Plot', height = "900px")
)
)
server <- function(input, output) {
output$Plot <- renderPlotly({
col_cht <- analysis_df %>%
filter(payee_id == 59) %>%
plot_ly(x = ~report_month,
y = ~gross) %>%
add_bars(color = input$slice_by) %>%
layout(barmode = "stack",
height = input$plotHeight)
})
}
shinyApp(ui, server)
I want the SelectInput to work, and it doesn't.
However, if I replace
add_bars(color = input$slice_by) %>%
with
add_bars(color = ~Attrib_1) %>%
i.e., hard-code it, the plot looks the way it should.
When you are piping with
> analysis_df %>%
the analysis_df dataframe is passed to the functions. So when using ~Attrib_1 you are passing the values in the Attrib_1 column, which are
# > analysis_df$Attrib_1
# [1] H J J H H G
So the plot gets different colors for the levels in analysis_df$Attrib_1.
When you are using input$slice_by that returns only one value, the value selected in Select. So you are getting just one color in the plot.
To get it to work use
color = analysis_df[, input$slice_by]
If you don't want to use analysis_df inside pipe, search about Non-standard Evaluation in R. With lazyeval you can do this,
color = interp(~x, x = as.name(input$slice_by))
Related
I'm using flexdashboard and shiny to choose which variable to plot:
varSelectInput("button_var_fir"
, "Select first num variable"
, data = df_scat,
multiple = FALSE
)
ggplot(df_scat, aes(x = !!input$button_var_fir, y = Gen_type, fill = stat(x))) +
geom_point(size= 3, alpha = .075)
it works fine, so far. My problem is, that I would like to subset the data e.g via
df$variable > 0
ggplot(df_scat, aes(x = df$!!input$button_var_fir > 0, y = Gen_type, fill = stat(x))) +
geom_point(size= 3, alpha = .075)
but this doesn't work due to the $!!. How can I solve this?
In {ggplot2}, which uses tidy evaluation, you can use the .data pronoun to dynamically select variables. It's nicely explained outside the {shiny} context in this answer too. This doesn't apply in {plotly} so you can either select with x = data[[input$column]] or x = get(input$column). This is also explained in this question.
Here's a small example to demonstrate how to do this for each plotting function.
library(plotly)
library(tidyverse)
library(shiny)
nbins <- 10
ui <- fluidPage(titlePanel("Dynamic Variable Selection"),
sidebarLayout(sidebarPanel(
selectInput(
inputId = "y1",
label = "Select variable",
choices = names(mtcars))),
mainPanel(plotOutput(outputId = "ggplot"),
plotlyOutput(outputId = "plotly"))))
server <- function(input, output) {
# dynamically pull variable in ggplot
output$ggplot <- renderPlot({
mtcars %>%
ggplot(aes(x = .data[[input$y1]])) +
geom_histogram(bins = nbins) +
ggtitle("ggplot")})
# dynamically pull variable in plotly
output$plotly <- renderPlotly({
mtcars %>%
plot_ly(x = .[[input$y1]], type = "histogram", nbinsx = nbins) %>%
layout(title = list(text = "Plotly"),
xaxis = list(title = input$y1))
})
}
shinyApp(ui = ui, server = server)
Maybe what you want is
df[[input$button_var_fir]] > 0
instead of df$!!input$button_var_fir > 0.
Addition:
You want to subset the data that goes into the plot, right? What I would actually do is subsetting the dataframe itself before it goes into the plot function. When you use the tidyverse this could be what you want:
df_scat %>%
filter(!!input$button_var_fir > 0) %>%
ggplot(aes(x = !!input$button_var_fir, y = Gen_type, fill = stat(x))) +
geom_point(size= 3, alpha = .075)
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'm trying to build a bilingual dashboard. In this dashboard I want to choose the right language column (either ENG or NL) based on input$language. This column serves as the levels input for a function in which a plotly graph is made.
The problem is now that when I use the radiobutton and change the language, nothing changes in the plotly graph. I'm guessing the regular function is not updating when something changes in the 'custom_levels_lang' reactive variable.
How can I make this work?
server.R
library(shinydashboard)
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
#make bilangual df
ID = c("level_1_graph1","level_1_graph1")
NL = c("Ja","Nee")
ENG = c("Yes","No")
levels_lang = data.frame(ID,NL,ENG)
#create df for pie-chart
S <- c("Ja","Nee")
n <- c(645,544)
percentage <- c(54,46)
df <- data.frame(S,n,percentage)
function(input, output, session) {
# Creating levels by language
custom_levels_lang <- reactive({
#select chosen language for input$language, then transpose all levels per
#graph number to separate columns
#gives custom_levels_lang$'name'
df <- levels_lang %>%
select(ID,one_of(input$language)) %>%
mutate(row = row_number()) %>%
spread_("ID",input$language)
#make list
df <- as.list(df)
#remove na's from list
df <- lapply(df, function(x) x[!is.na(x)])
return(df)
})
#create pie-chart
plot_pie <- function(custom_levels){
plt <- renderPlotly({
#give right levels based on chosen language
levels(df$S) <- custom_levels
#construct plot
df %>%
plot_ly(
labels = df$S,
values = ~percentage,
type = 'pie',
hole = 0.5,
textinfo = 'percent',
text = ~paste("n = ", n),
hoverinfo = 'text') %>%
layout(
showlegend = TRUE,
legend = list(x = 0.2, y = -0.3),
title = "title") %>%
config(
displaylogo = FALSE,
collaborate = FALSE,
modeBarButtonsToRemove = list('zoom2d','pan2d','zoomIn2d','zoomOut2d',
'autoScale2d','resetScale2d','toggleHover',
'toggleSpikelines','hoverClosestCartesian','hoverCompareCartesian'))
})
return(plt)
}
output$plt1 <- plot_pie(custom_levels = custom_levels_lang()$level_1_graph1)
}
ui.R
library(shinydashboard)
library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
header <- dashboardHeader(
title = "Welcome",
titleWidth = 450)
sidebar <- dashboardSidebar(width = 300, radioButtons("language", label = "Kies taal", choices = list("Nederlands" = "NL", "English" ="ENG"), selected = "NL"))
body <- dashboardBody( plotlyOutput('plt1') )
dashboardPage(header,sidebar,body)
The renderPlotly function has to be outside the function call so that it gets notified whenever its dependency (custom_levels_lang()$level_1_graph1) changes.
In your code it's not in a reactive context, so it only gets rendered once.
plot_pie <- function(custom_levels){
#give right levels based on chosen language
levels(df$S) <- custom_levels
#construct plot
plt <- df %>%
plot_ly(
labels = df$S,
values = ~percentage,
type = 'pie',
hole = 0.5,
textinfo = 'percent',
text = ~paste("n = ", n),
hoverinfo = 'text') %>%
layout(
showlegend = TRUE,
legend = list(x = 0.2, y = -0.3),
title = "title") %>%
config(
displaylogo = FALSE,
collaborate = FALSE,
modeBarButtonsToRemove = list('zoom2d','pan2d','zoomIn2d','zoomOut2d',
'autoScale2d','resetScale2d','toggleHover',
'toggleSpikelines','hoverClosestCartesian','hoverCompareCartesian'))
return(plt)
}
output$plt1 <- renderPlotly(plot_pie(custom_levels = custom_levels_lang()$level_1_graph1))
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)
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.