We Keep Coding

R Shiny colResize restore column widths

Following up on this post, I seem to have forgotten to include an important thing in my question. I would also like to restore the column width that was communicated to R.
How can I expand the code from the answer to my previous question in an idiomatic way to include such a functionality?

There's a 'reset' method in this plugin. In order to use it, you have to define initial column widths with the sWidth option.
The behavior is a bit strange. I found that it is better by initially applying the 'reset' method, and then applying it by clicking a button:
"table.colResize.reset();", # initial reset
"$('#reset').on('click', function(){",
" table.colResize.reset();",
"});"
You can try to remove the initial reset to see what I mean.
library(shiny)
library(DT)
library(htmltools)
dep <- htmlDependency(
name = "colResize",
version = "1.6.1",
src = normalizePath("colResize"),
script = "jquery.dataTables.colResize.js",
stylesheet = "jquery.dataTables.colResize.css",
all_files = FALSE
)
js <- c(
"function(column, columns){",
" Shiny.setInputValue('colwidth', column);",
"}"
)
callback <- c(
"table.colResize.reset();",
"$('#reset').on('click', function(){",
" table.colResize.reset();",
"});"
)
dat <- head(iris, 6)
ui <- fluidPage(
br(),
actionButton("reset", "Reset widths", class = "btn-primary"),
fluidRow(
column(
width = 8,
DTOutput("dtable")
),
column(
width = 4,
verbatimTextOutput("columnWidth")
)
)
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
dtable <- datatable(
dat,
callback = JS(callback),
options = list(
columnDefs = list(
list(targets = "_all", sWidth = "17%")
),
colResize = list(
onResizeEnd = JS(js)
)
)
)
deps <- dtable[["dependencies"]]
deps <- c(deps, list(dep))
dtable[["dependencies"]] <- deps
dtable
})
output[["columnWidth"]] <- renderPrint({
input[["colwidth"]]
})
}
shinyApp(ui, server)
EDIT: save/restore column widths
library(shiny)
library(DT)
library(htmltools)
dep <- htmlDependency(
name = "colResize",
version = "1.6.1",
src = normalizePath("colResize"),
script = "jquery.dataTables.colResize.js",
stylesheet = "jquery.dataTables.colResize.css",
all_files = FALSE
)
js <- c(
"function(column, columns){",
" Shiny.setInputValue('colwidth', column);",
"}"
)
callback <- c(
"table.colResize.reset();",
"$('#saveWidths').on('click', function(){",
" table.colResize.save();",
" Shiny.setInputValue('savedWidths', true, {priority: 'event'});",
"});",
"$('#restoreWidths').on('click', function(){",
" table.colResize.restore();",
"});"
)
dat <- head(iris, 6)
ui <- fluidPage(
br(),
actionButton("saveWidths", "Save widths", class = "btn-primary"),
actionButton("restoreWidths", "Restore widths", class = "btn-primary"),
br(),
fluidRow(
column(
width = 8,
DTOutput("dtable")
),
column(
width = 4,
verbatimTextOutput("columnWidth")
)
)
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
dtable <- datatable(
dat,
callback = JS(callback),
options = list(
columnDefs = list(
list(targets = "_all", className = "dt-center", sWidth = "17%")
),
colResize = list(
onResizeEnd = JS(js)
)
)
)
deps <- dtable[["dependencies"]]
deps <- c(deps, list(dep))
dtable[["dependencies"]] <- deps
dtable
})
output[["columnWidth"]] <- renderPrint({
input[["colwidth"]]
})
observeEvent(input[["savedWidths"]], {
showNotification("Column widths have been saved", type = "message")
})
}
shinyApp(ui, server)

Is there a way for R to restrict browseURL to only fire when clicked?

So, I have attached what my data looks like. I have all of the variables in 1 column and their values for a specific date and state in another column.
I want my users to be able to click on the graph and it take them to the corresponding data. You can do this in Javascript, but I am using Shiny, so my project is in R. So, I made the proper changes, using this and this as an examples, and this as a guide. Instead of using location.href like I would in Javascript, I used browseURL. When I use browseURL, it fires as soon as the page opens up instead of firing when I click the line graph. Is there a way to restrict browseURL so that it only fires when clicked?
library(shiny)
library(highcharter)
library(dplyr)
data <- read.csv("data/daily states.csv")
ui <- fluidPage(
titlePanel("Timeline"),
sidebarLayout(
sidebarPanel(
h2("Actions", align="center"),
fluidRow(
column(5,
selectizeInput("state",
h3("State:"),
c("All",
unique(data$state))))
),
fluidRow(
column(5,
selectInput("outcome",
h3("Outcome:"),
c("All",
unique(data$variable))))
),
fluidRow(
column(5,
dateRangeInput("date",
h3("Date range"),
min = "2020-01-22",
start = "2020-01-22",
end = as.character(Sys.Date())))
),
fluidRow(
column(5,
checkboxInput("federal",
"Show federal level",
value = TRUE))
)
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plot", highchartOutput("hcontainer")),
tabPanel("Table", DT::dataTableOutput("table"))),
)
)
)
server <- function(input, output, session){
newData <- reactive({
if (input$state != "All"){
data <- filter(data, state == input$state)
}
if (input$outcome != "All"){
data <- filter(data, variable == input$outcome)
}
data
})
output$table <- DT::renderDataTable(DT::datatable({
newData()
}))
output$hcontainer <- renderHighchart({
hc <- highchart(type = "chart") %>%
hc_xAxis(categories = unique(newData()$date)) %>%
hc_plotOptions(series = list(
allowPointSelect = TRUE,
cursor = "pointer",
point = list(
events = list(
click = browseURL(paste('https://covidtracking.com/data/state/',input$state,'/#historical', sep = ""))
)
)
)
) %>%
hc_add_series(name = (paste(input$state,input$outcome)), data = newData()$value)
hc
})
}
shinyApp(ui = ui, server = server)

R shiny DT hover shows detailed table

I am trying to work on an R shiny app where I want to show a consolidated table on top and when the user hovers on any line item it would show the detailed section of that table.So here's the code for the first table
library(ggplot2)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new row for the table.
DT::dataTableOutput("table")
)
server <- function(input, output) {
data <- mpg
data <-data %>% group_by(manufacturer,year) %>%
summarise(cty = round(mean(cty),2),hwy = round(2,mean(hwy)))
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data
}))
}
shinyApp(ui,server)
Now when the user hovers on Audi for example it should show a detailed version just forAudi something like this in a table below.Can this be done in shiny with DT on hover or click.

Here is a way. If you prefer to display the child table on click rather than on hover, replace "table.on('mouseover', 'td', function(){" with "table.on('click', 'td', function(){".
library(shiny)
library(DT)
data(mpg, package = "ggplot2")
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});"
)
ui <- fluidPage(
br(),
DTOutput("tbl")
)
server <- function(input, output, session){
dat <- mpg
output[["tbl"]] <- renderDT({
datatable(
dat,
callback = JS(callback)
)
})
filteredData <- eventReactive(input[["cell"]], {
i <- input[["cell"]]$row + 1
j <- input[["cell"]]$column
if(j > 0){
dat[dat[[j]] == dat[i,j], , drop = FALSE]
}else{
NULL
}
})
output[["tblfiltered"]] <- renderDT({
datatable(
filteredData(),
fillContainer = TRUE,
options = list(
pageLength = 5
)
)
})
observeEvent(filteredData(), {
showModal(
modalDialog(
DTOutput("tblfiltered"),
size = "l",
easyClose = TRUE
)
)
})
}
shinyApp(ui, server)

The select drop down menu appear behind other elements in shiny

Can any one give me a solution to the following issue where the drop down goes under the plotly hover when going to select the fist item in the drop down.
I used the following code. But didn't work.
in UI,
fluidRow(
tags$hr(style="z-index: 10000;"),
column(width = 3,h2("Device Type")),
column(width = 3,htmlOutput("disselect")),
column(width = 3,htmlOutput("cityeselect")),
column(width = 3,h2("Property Type"))
),
in server
output$disselect <- renderUI({
selectInput("district", "District", c("All",unique(bookings$District)), selected = "All")
})
Any hacks?

Set the z-index of the drop-down so that it's greater than that of the plotly modebar, for instance 1002 would work:
column(width = 3, offset = 9,
selectInput("y", "y", colnames(mtcars)),style="z-index:1002;")
A working example:
library(shiny)
library(plotly)
ui <- fluidPage(
fluidRow(
column(width = 3, offset = 9,
selectInput("y", "y", colnames(mtcars)),style="z-index:1002;")
),
fluidRow(plotlyOutput("plot"))
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
g <- ggplot(mtcars, aes_string("disp", input$y)) +
geom_point()
g <- ggplotly(g) %>%
config(displayModeBar = TRUE)
g
})
}
shinyApp(ui, server)

If you don't need the plotly modebar, you can just remove it.
Here's an example:
library(shiny)
library(plotly)
ui <- fluidPage(
fluidRow(
column(width = 3, offset = 9,
selectInput("y", "y", colnames(mtcars)))
),
fluidRow(plotlyOutput("plot"))
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
g <- ggplot(mtcars, aes_string("disp", input$y)) +
geom_point()
### code to hide the modebar ###
g <- ggplotly(g) %>%
config(displayModeBar = FALSE)
g
})
}
shinyApp(ui, server)

R Shiny Dynamic text in header (reactive renderUI)

I am trying to put dynamic text in shiny's header, and have managed to put text in it, but cannot get it to update after it has received new data from an reactive expression. To put text in the header, I have used a basic Java call, tags$script.
My concern is that renderUI only renders the 1st time, and does not force render whenever the reactive value (val) is updated, which is exactly what I require.
Apologies for the weird example below, I have a HUGE dashboard which has several chained dependencies, and I have tried to replicate the types of dependencies in the reproducible example below.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(skin = 'black',
dashboardHeader(title = "test"),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("dummy", tabName = "rawanalysis", selected = TRUE, icon = icon("dashboard"))
)
),
dashboardBody(
uiOutput(outputId = 'Header'),
fluidRow(
box(
actionButton("change", "Change")
)
))))
server <- function(input, output) {
Go_rv <- reactiveValues(val = 0)
observeEvent(input$change, {
sam <- rnorm(1)
if(sam > 0){
Go_rv$val <- TRUE
} else {
Go_rv$val <- FALSE
}
})
val <- reactive({
print(Go_rv$val)
if(Go_rv$val){
out <- 0
} else {
out <- -5
}
return(out)
})
output$Header <- renderUI({
removeUI(
selector = "div:has(> #Header)"
)
header_text <- paste0('$(document).ready(function() {
$("header").find("nav").append(\'<div class="myClass">', val(), '</div>\');})')
tags$script(HTML(header_text),
id = 'Header'
)
})
}
shinyApp(ui = ui, server = server)

Basically, a reactive text output with observeEvent should do this job!
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(skin = 'black',
dashboardHeader(title = textOutput('test')),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("dummy", tabName = "rawanalysis", selected = TRUE, icon = icon("dashboard"))
)
),
dashboardBody(
#uiOutput(outputId = 'Header'),
fluidRow(
box(
actionButton("change", "Change")
)
))))
server <- function(input, output,session) {
title_change <- reactive({
input$change
as.character(Sys.time())
})
observeEvent(input$change, { output$test <- renderText({ title_change()
})
})
}
shinyApp(ui = ui, server = server)