Problem: In below Shiny app, I want to change and insert new rows to the following data via rhandsontable:
data.frame(car = c("Opel", "Nissan", "Opel", "VW"),
location = c("Ruesselsheim", "Frankreich", "Ruesselsheim", "Wolfsburg"))
If I change for example car == Opel to car == VW the location shall change from Ruesselsheim to Wolfsburg.
If I insert a new row and for example populate it with car == Opel then location shall be Ruesselsheim directly after providing the car input
Question: How can I conditionally change the cell values and define conditional default values?
Attempts: hot_col has a default argument but it only accepts a string and not a condition. Also tracking the changes via an observer seems not really the best way to do it.
Any ideas on how to approach this? Many thanks!
library(shiny)
library(rhandsontable)
ui = shinyUI(fluidPage(
titlePanel("Handsontable"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("hot")
),
mainPanel(
verbatimTextOutput("debug")
)
)
))
server = function(input, output) {
data <- reactive({
data.frame(car = c("Opel", "Nissan", "Opel", "VW"),
location = c("Ruesselsheim", "Frankreich", "Ruesselsheim", "Wolfsburg"))
})
output$hot <- renderRHandsontable({
DF <- data()
rhandsontable(DF, useTypes = FALSE, selectCallback = TRUE)
})
### DEBUG
output$debug <- renderPrint({
req(input$hot)
input$hot$changes
})
}
shinyApp(ui = ui, server = server)
The desired behaviour can be achived by using a reactiveVal and a lookup-table to merge the current selection with:
library(shiny)
library(rhandsontable)
ui = shinyUI(fluidPage(
titlePanel("Handsontable"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("hot")
),
mainPanel(
verbatimTextOutput("debug")
)
)
))
server = function(input, output) {
LUT_DF <- data.frame(car = c("Opel", "Nissan", "VW"),
location = c("Ruesselsheim", "Frankreich", "Wolfsburg"))
data <- reactiveVal(data.frame(car = c("Opel", "Nissan", "Opel", "VW"),
location = c("Ruesselsheim", "Frankreich", "Ruesselsheim", "Wolfsburg")))
output$hot <- renderRHandsontable({
rhandsontable(data(), useTypes = FALSE, selectCallback = TRUE)
})
observeEvent(input$hot, {
data(merge(LUT_DF, hot_to_r(input$hot)[1], by = "car"))
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
Related
The below reproducible code renders a user input matrix grid inside a modal dialog box (click on the single action button at the top when invoking the App), with the user input matrix: (a) automatically expanding to the right as the user inputs data into the columns, (b) automatically generating sequentially numbered column headers, and (c) rendered inside a scrollable well panel so that it expands without "scrunching" as it grows.
However, I would like to "freeze" the left-most column of the matrix input grid (the row headers), so the user doesn't lose the meanings of individual rows as the grid grows. The images at the bottom better illustrate. How can this be done?
I assume this requires some gyrations with shinyjs, an area I am very weak in. This is a follow-up evolution of earlier post In R shiny, how to incorporate scrolling into modal dialog box?
Reproducible code:
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
library(magrittr)
library(DT)
mat1DefaultRownames <- c('Item A','Item B','Item C','Item D')
mat1Default <- data.frame('Series 1'=c(1,24,0,100), row.names = mat1DefaultRownames) %>% as.matrix()
mat1Input <- function(inputId, mat1Default) {
matrixInput(
inputId = inputId,
label = "Input terms:",
value = mat1Default,
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, delete = TRUE),
class = "numeric"
)
}
ui <-
fluidPage(
shinyjs::useShinyjs(),
div(style = "margin-top: 10px"),
actionButton('modInputs','Input terms', style = 'width:25%'),
DTOutput("table1")
)
server <- function(input,output,session)({
rv1 <- reactiveValues(
mat1 = mat1Input("mat1",mat1Default),
input = mat1Default,
colHeader = colnames(input)
)
mat1Inputs <- reactive({
if (isTruthy(input$modInputs)) {
req(input$mat1)
df <- input$mat1
rv1$mat1 <- mat1Input("mat1", df)
colnames(df) <- paste("Series",rep(1:ncol(df),each=1,length.out=ncol(df)))
rownames(df) <- mat1DefaultRownames
rv1$input <- df
updateMatrixInput(session, inputId = "mat1", value = rv1$input)
} else {
df <- mat1Default
colnames(df) <- paste("Series", 1:ncol(df))
}
df[3:4, ] <- sprintf('%.2f%%', df[3:4, ])
df
})
output$table1 <-
renderDT(server = TRUE, {
datatable(
data = mat1Inputs(),
options = list(
scrollX = T,
dom = 'ft',
autoWidth = FALSE,
info = FALSE,
searching = FALSE,
columnDefs =
list(
list(className = 'dt-left', targets = 0),
list(className = 'dt-right', targets = seq_len(ncol(mat1Inputs())))
)
),
class = "display nowrap"
)
})
observeEvent(input$modInputs, {
showModal(
modalDialog(
wellPanel(div(style = "overflow-x: auto;", rv1$mat1)),
footer = tagList(actionButton("resetInputs", "Reset"),modalButton("Close"))
)
)
})
observeEvent(c(input$modInputs, input$mat1), {
runjs(
paste0(
'$("#mat1").css("width","calc(100% + ', (dim(input$mat1)[2]-1 + dim(input$mat1)[2]%%2)*115, 'px")'
) # close paste0
) # close runjs
})
observeEvent(input$resetInputs, {updateMatrixInput(session,'mat1', mat1Default)})
})
shinyApp(ui, server)
I'm working on a Shiny app and want to add a tabpanel if a condition is TRUE. I'm using conditionalpanel function and the condition to be tested is whether or not "products" from ui input contains "C".
From the first tab, if C is clicked the "second tab" is not shown.
I think the issue is the JS condition inside the conditionalpanel.
If you have any working solution (not necessarily based on conditionalpanel) I'll appreciate your help and support.
Luigi
Here below my reprex
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(reprex)
tab_input <- dashboardPage(
dashboardHeader(title = "Value boxes", disable = TRUE),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
box(
checkboxGroupButtons(
inputId = "products", label = tags$h1("Select products"),
choices = c("A", "B", "C"),
checkIcon = list(yes = icon("ok", lib = "glyphicon"), no = icon("remove", lib = "glyphicon"))
)
)
)
)
)
ui <- navbarPage("my APP",
tabPanel("first tab",
tab_input),
conditionalPanel(
condition = "input.products.contains('C')",
tabPanel("second_tab",
dashboardPage(
dashboardHeader(title = "Value boxes", disable = TRUE),
dashboardSidebar(disable = TRUE),
dashboardBody(
)
)
)
)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
Try
condition = "input.products.indexOf('C') > -1"
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)
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)
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)