Based on this question I would like to also change the background color of the modebar when hovering over it.
I looked in the css, but couldn't find or change the relevant part.
Here's a small shinyApp to test around:
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("plotly")
)
server <- function(input, output, session) {
output$plotly <- renderPlotly({
plot_ly(data = mtcars) %>%
add_markers(x=~mpg, y=~disp) %>%
layout(plot_bgcolor='transparent', paper_bgcolor='transparent')
})
}
shinyApp(ui, server)
I made it transparent but then the options are also invisible so I added a color and activecolor, see here. Feel free to change as necessary.
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("plotly")
)
server <- function(input, output, session) {
output$plotly <- renderPlotly({
plot_ly(data = mtcars) %>%
add_markers(x=~mpg, y=~disp) %>%
layout(plot_bgcolor='transparent', paper_bgcolor='transparent',
modebar=list(bgcolor='transparent', color='blue', activecolor='green'))
})
}
shinyApp(ui, server)
Referencia = [https://plotly.com/javascript/reference/layout/#layout-modebar][1]
layout = {
title: '',
modebar: {
orientation: 'h',
bgcolor: '#ffffff',
color:'red',
activecolor:'red',
position: 'left'
}}
enter image description here
Related
I'm trying to make an app which shows some data after the user clicks a point. It works, except that when the data is longer than the window the scrollbar shows up, resizing the plot and erasing the data. How to make the data show and stay?
Below the code of a minimal example.
library(shiny)
library(tidyr)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
req(input$plot_click)
np <- nearPoints(mtcars, input$plot_click) %>%
pull(gear)
mtcars %>%
filter(gear == np)
})
}
shinyApp(ui = ui, server = server)
The problem here is, that once the vertical scrollbar shows up the plotOutput is resized and therefore re-rendered, this results in input$plot_click being reset to NULL causing an empty table.
We can use req()'s cancelOutput parameter to avoid this behaviour.
Please see ?req:
cancelOutput: If TRUE and an output is being evaluated, stop processing as usual but instead of clearing the output, leave it in
whatever state it happens to be in.
library(shiny)
library(tidyr)
library(dplyr)
library(ggplot2)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
req(input$plot_click, cancelOutput = TRUE)
np <- nearPoints(mtcars, input$plot_click) %>% pull(gear)
if(length(np) > 0){
mtcars %>% filter(gear == np)
} else {
NULL
}
})
}
shinyApp(ui = ui, server = server)
I have the data frame below:
Name<-c("John","Bob","Jack")
Number<-c(3,3,5)
NN<-data.frame(Name,Number)
And a simple shiny app which creates a plotly histogram out of it. My goal is to click on a bar of the histogram and display the Name in a datatable that correspond to this bar. For example if I click on the first bar which is 3 I will take a table with John and Bob names.
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
p <- plot_ly(x = NN$Number, type = "histogram")
})
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a bar in the histogram to see its values"
} else {
NN[ which(NN$Number==as.numeric(s[2])), 1]
}
})
}
shinyApp(ui, server)
I am adding the solution by modifying your data.frame as mentioned in the comment:
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
Name<-c("John","Bob","Jack")
Number<-c(3,3,5)
Count<-c(2,2,1)
NN<-data.frame(Name,Number,Count)
render_value(NN) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = NN$Number, type = "histogram",source="subset") # set source so
# that you can get values from source using click_event
})
render_value=function(NN){
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click",source = "subset")
print(s)
return(DT::datatable(NN[NN$Count==s$y,]))
})
}
}
shinyApp(ui, server)
Screenshot from solution:
I want to update the data present in a plot (displayed in plotlyOutput in a Shiny app) using Proxy Interface. Here is a minimal App.R code :
library(shiny)
library(plotly)
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
p <- plot_ly(type="scatter",mode="markers")
p <- layout(p,title="test")
p <- add_trace(p, x=0,y=0,name="ABC_test",mode="lines+markers")
})
observeEvent(input$update, {
proxy <- plotlyProxy("graphe", session) %>%
plotlyProxyInvoke("restyle", list(x=0,y=1),0)
})
}
shinyApp(ui, server)
When I run it, the plot is displayed with a dot at (0,0) (as wanted) but when I click of the button "Test", the dot does not move to (0,1). How can I achieve this ?
Thank you for any answer.
Strangely enough addTracesdoes not work with only one point but works with two points. To make it work you could add the same point twice. So you could try this:
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
p <- plot_ly(type="scatter",mode="markers")
p <- layout(p,title="test")
p <- add_trace(p, x=0,y=0,name="ABC_test",mode="lines+markers")
})
observeEvent(input$update, {
plotlyProxy("graphe", session) %>%
plotlyProxyInvoke("deleteTraces", list(as.integer(1))) %>%
plotlyProxyInvoke("addTraces", list(x=c(0, 0),y=c(1, 1),
type = 'scatter',
mode = 'markers'))
})
}
shinyApp(ui, server)
The restyle API is a bit wonky...I forget the reasoning, but data arrays like x and y need double arrays. I'd do it this way:
library(shiny)
library(plotly)
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
plot_ly() %>%
add_markers(x = 0, y = 0, name = "ABC_test") %>%
layout(title = "test")
})
observeEvent(input$update, {
plotlyProxy("graphe", session) %>%
plotlyProxyInvoke("restyle", "y", list(list(1)), 0)
})
}
shinyApp(ui, server)
library(shiny)
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
plot_ly() %>%
layout(title="test") %>%
add_trace(x=runif(2), y=runif(2), name="ABC_test", type="scatter", mode="lines+markers")
})
observeEvent(input$update, {
plotlyProxy("graphe", session, FALSE) %>%
plotlyProxyInvoke("deleteTraces", list(as.integer(0))) %>%
plotlyProxyInvoke("addTraces", list(x=runif(2),
y=runif(2),
name="ABC_test",
type = 'scatter',
mode = 'lines+markers'))
})
}
shinyApp(ui, server)
I'm desperately trying to change the default colors of the rpivotTable package. I have also posted an issue in the github of the creator of the package, but no one has answered yet, so if someone has an idea how to fix this problem, I'd be more than grateful.
My main problem is changing the blue colors in the rectangles below the variable choice: Example
With this function that I have found on the internet, I manage to change the whole background, but not the specific thing I want (outside of Shiny only so far):
style_widget <- function(hw=NULL, style="", addl_selector="") {
stopifnot(!is.null(hw), inherits(hw, "htmlwidget"))
# use current id of htmlwidget if already specified
elementId <- hw$elementId
if(is.null(elementId)) {
# borrow htmlwidgets unique id creator
elementId <- sprintf(
'htmlwidget-%s',
htmlwidgets:::createWidgetId()
)
hw$elementId <- elementId
}
htmlwidgets::prependContent(
hw,
htmltools::tags$style(
sprintf(
"#%s %s {%s}",
elementId,
addl_selector,
style
)
)
)
}
pivot_graph<-rpivotTable(mtcars)
browsable(
tagList(
style_widget(hw=pivot_graph, "background-color: rgb(245, 245, 245);", "table td")
)
)
However, when I try to do it Shiny, I can't figure out what to put where and how to do it (or even if it's at all possible with this function). Any help is appreciated. My Shiny code so far:
library(shiny)
library(rpivotTable)
library(rvest)
ui <- fluidPage(
titlePanel("Cars"),
sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose CSV File',
accept=c('text/csv','text/comma-separated-values,text/plain','.csv')),
actionButton("save1","Save Table 1")
# actionButton("save2","Save Table 2")
),
mainPanel(
tabsetPanel(
tabPanel("Pivot Table 1",
rpivotTableOutput("table")),
tabPanel("Pivot Table 2",
rpivotTableOutput("table2"))
)
)
)
)
server <- function(input, output,session)
{
session$onSessionEnded(stopApp)
observe({
file1 = input$file1
if (is.null(file1)) {
return(NULL)
}
st_data <<- read.csv(file1$datapath)
output$table <- renderRpivotTable({
rpivotTable(mtcars,
rendererName="Table",
onRefresh = htmlwidgets::JS("function(config) {Shiny.onInputChange('myData',
document.getElementById('table').innerHTML); }")
)
})
output$table2 <- renderRpivotTable({
rpivotTable(mtcars,aggregatorName="Average",
rendererName="Table",
onRefresh = htmlwidgets::JS("function(config) {Shiny.onInputChange('myData',
document.getElementById('table').innerHTML); }")
)
})
summarydf <- eventReactive(input$myData,{
input$myData %>%
read_html %>%
html_table(fill = TRUE) %>%
.[[2]]
})
observeEvent(input$save1, {
if(nrow(summarydf() )<1) return()
write.csv(summarydf(), file="./cars1.csv")
})
# summarydf1 <- eventReactive(input$myData1,{
# input$myData1 %>%
# read_html %>%
# html_table(fill = TRUE) %>%
# .[[4]]
# })
#
# observeEvent(input$save2, {
# if(nrow(summarydf1() )<1) return()
# write.csv(summarydf1(), file="./cars2.csv")
# })
})
}
shinyApp(ui = ui, server = server)
The following code will change the light blue to a very deep blue.
You can change any pivot.min.css code in a similar way: the only challenge is to identify which is the right element!
To change the colour, search for a JavaScript colour map and change #000080 to whatever you need.
library(shiny)
df <- iris
ui <- fluidPage(
tags$style(type="text/css",".pvtRows, .pvtCols { background: #000080 none repeat scroll 0 0; }" ),
fluidRow(
column(width=10, rpivotTableOutput("pivot"))
)
)
server <- function(input, output, session) {
output$pivot<-renderRpivotTable({
rpivotTable(df,
rendererName="Heatmap",
cols=c("Species"),
rows=c("Petal.Width"),
aggregatorName="Count"
)
})
}
shinyApp(ui = ui, server = server)
Please let me know if this is addressing your requirement.
I want to increase the size of highchart on clicking the zoom button. I tried using the code below to increase the size but so far I have not been able to achieve what I want to do. I actually wanted the highchart to expand and occupy the full page on clicking the zoom button. I have written the following code so far but it does not seem to work. Can anyone tell me what I am doing wrong?
require(shiny)
require(rCharts)
ui <- fluidPage(
tags$script('Shiny.addCustomMessageHandler("ZoomPlot", function(variableName){
document.getElementById(variableName).style.height = "1000px";
});
'),
headerPanel("Test app"),
actionButton("test", "Zoom"),
div(class = "chart-container", showOutput("viz", "highcharts"))
)
server <- shinyServer(function(input, output, session) {
output$viz <- renderChart2({
a <- highchartPlot(Sepal.Length ~ Sepal.Width, data=iris)
a
})
observeEvent(input$test,{
session$sendCustomMessage(type = 'ZoomPlot', message = "viz")
})
})
shinyApp(ui, server)
You can do it using only server side like
server <- shinyServer(function(input, output, session) {
hh=reactive({
if(input$test>0 ) {1000}else{400}
})
output$viz <- renderChart2({
a <- highchartPlot(Sepal.Length ~ Sepal.Width, data=iris)
a$set(height = hh()
)
a
})
})