I have multiple HTML files, and I would like to create a reactive function that changes according to the user input selections as follow:
library(shiny)
library(shinydashboard)
ui <-
dashboardPage(
dashboardSidebar( sliderTextInput(
inputId = "mySliderText",
label = "Story line",
grid = TRUE,
force_edges = TRUE,
choices = c('1','2')
)
),
dashboardBody(
fluidRow(
column(9,
box(
title = "Operations ",
closable = FALSE,
width = 9,
status = "primary",
solidHeader = FALSE,
collapsible = TRUE,
uiOutput("operations")
)
)
)
)
)
server <- function(input, output,session) {
operations_reactive <- reactive({
if (input$mySliderText ==1)
{
return(includeHTML("trial1.html"))
}
else
{
return(includeHTML("trial2.html"))
}
})
output$operations<-renderUI({operations_reactive()})
}
shinyApp(ui = ui, server = server)
it works but not in a proper way, the operations_reactive does not change when input$mySliderText changes
Related
I would like to fix scrolling according to the title in shinydashboard.
I tried some CSS tricks and functions but i don't get the expected result.
Here's my apps :
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
############# UI ############
body <- dashboardBody(
tabItems(
tabItem(tabName = "tab1",
fluidRow(
div(tags$h1('My title : Fix scrolling according to this title')),
),
fluidRow(
tags$p('some text')
)
)
)
)
ui <- dashboardPage(
title = "Example",
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(disable = FALSE),
sidebar = dashboardSidebar(
minified = TRUE, collapsed = TRUE,
sidebarMenu(id="menu",
menuItem("first tab", tabName = "mytab", icon = icon("fas fa-acorn"),
menuSubItem('menu1',
tabName = 'tab1',
icon = icon('fas fa-hand-point-right'))
)
)
),
body
)
############# SERVER ############
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
Some help would be appreciated
try this
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
############# UI ############
body <- dashboardBody(
tabItems(
tabItem(tabName = "tab1",
fluidRow(
id = "mytitle",
div(tags$h1('My title : Fix scrolling according to this title')),
),
fluidRow(
lapply(1:50, br),
h3('some text'),
lapply(1:50, br),
h3('some text'),
lapply(1:50, br),
h3('some text')
),
tags$script(HTML(
"
$(window).scroll(function() {
var height = $(window).scrollTop();
var el = $('#mytitle');
if(height > 50) {
el.addClass('fix-top');
} else {
el.removeClass('fix-top');
}
});
"
)),
tags$style(
"
.fix-top {
position: fixed;
height: 80px;
width: 100%;
background-color: #ecf0f5;
top: 0;
}
"
)
)
)
)
ui <- dashboardPage(
title = "Example",
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(disable = FALSE),
sidebar = dashboardSidebar(
minified = TRUE, collapsed = TRUE,
sidebarMenu(id="menu",
menuItem("first tab", tabName = "mytab", icon = icon("fas fa-acorn"),
menuSubItem('menu1',
tabName = 'tab1',
icon = icon('fas fa-hand-point-right'))
)
)
),
body
)
############# SERVER ############
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
I am trying with the below code.
library(shiny)
app <- shinyApp(
ui = fluidPage(
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- reactive({ head(mtcars)})
output$mydatatable = DT::renderDataTable(mycars(), selection = 'single',
rownames = FALSE, options = list(dom = 't'))
selected_row <- reactiveVal(value = NULL)
observeEvent(input$mydatatable_rows_selected,{
selected_row(input$mydatatable_rows_selected)
})
observeEvent(selected_row(),
{
showModal(modalDialog(
title = "You have selected a row!",
ifelse(
mycars()$mpg[selected_row()] > 21,
tags$div(HTML(paste('cyl = ', tags$span(style = "color:red", mycars()$cyl[selected_row()]), sep = ""))),
tags$div(HTML(paste('cyl = ', tags$span(style = "color:blue", mycars()$cyl[selected_row()]), sep = "")))
)
))
})
})
)
app
Here I am trying to change color of 'cyl' value to red if 'mpg' value is greater than 21 else 'cyl' value will print in blue.
I have tried with few html codes but failed.
Thanks!
For this purpose the dataframe does not have to be reactive, so I removed that part in here. Make use of the formatStyle functionality:
app <- shinyApp(
ui = fluidPage(
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- mtcars
output$mydatatable = DT::renderDataTable(datatable(mycars) %>%
formatStyle('cyl', 'mpg',
color = styleInterval(21.001, c('blue', 'red'))),
selection = 'single',
rownames = FALSE, options = list(dom = 't'))
})
)
app
I have an example, where dateRangeInput and actionButton are added dynamically.
I need elements to be positioned side by side and not in the block.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(), #Set up shinyjs
tabsetPanel(
tabPanel("Settings",
br(),
fluidRow(
column(width = 8,
box(
title = "Set parameters", id = "RO_05_param_box", width = NULL, solidHeader = TRUE, status ="primary", collapsible = TRUE,
fluidRow(
box(radioButtons("RO_05_param_radio", h6("Company"), choices = list("A" = 1,
"B" = 2), selected = 1), br(),
dateRangeInput("date_range_view", h6("Timeline"), start = "2019-06-30", end = "2020-06-30"), br(),
selectInput("RO_05_param_select", h6("Distribute over time"), choices = list("Stepped line" = 2, "Linear funcion" = 1))
),
box(id= "step_box", dateRangeInput("RO05_date1", h6("Start and end date"), start = "2019-06-30", end = "2020-06-30"),
tags$div(id = 'placeholder_dateRangeInput'),
actionButton("add_lag", "Add dates")
)
)
)
)
)
)
)
)
)
server <- function(input, output) {
observeEvent(input$RO_05_param_select, {
if(input$RO_05_param_select == 2){
show(id = "step_box")
} else {
hide(id = "step_box")
}
})
observeEvent(input$add_lag, {
add <- input$add_lag + 1
addID <- paste0("NO", add)
daterangeID <- paste0('RO05_date', add)
removeID <- paste0('remove_lag', add)
insertUI(
selector = '#placeholder_dateRangeInput',
ui = tags$span(id = addID,
tags$span(dateRangeInput(daterangeID, h6("Near lag and far lag"), start = "2019-06-30", end = "2020-06-30")),
tags$span(actionButton(removeID, label= '', icon("minus")))
)
)
observeEvent(input[[removeID]], {
removeUI(selector = paste0('#', addID))
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I tried adding this css:
#placeholder_dateRangeInput {
display: inline-block;
}
But all it does it only shrinks dateRangeInput widget.
However, #placeholder_dateRangeInput wraps all added elements, so I think that css should be wrapped around addID.
Here is a way that you can use to make your elements side by side. In css, you tell the element that your want on the left to be
float:left;
and the element that you want on the right to be
float:right;
This should make them side by side.
Here is an example of this being used:
https://www.geeksforgeeks.org/how-to-float-three-div-side-by-side-using-css/
I am wondering if there is a way to remove the index column (1st column) from the data table in Shiny.
For example, column of (1, 2, 3) before Name column as shown in the screenshot below:
Below is my code:
header <- dashboardHeader(
title = "Test"
)
sidebar <- dashboardSidebar(
)
body <- dashboardBody(
box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
output$df = DT::renderDataTable(df, options = list(
autoWidth = TRUE,
columnDefs = list(list(width = '10px', targets = c(1,3)))))
}
# Shiny dashboard
shiny::shinyApp(ui, server)
Thanks in advance.
There is some excellent documentation of the package available at https://rstudio.github.io/DT/ I would highly recommend reading through.
At any rate, use the rownames = FALSE argument provided by the DT package as follows:
library(shinydashboard)
library(DT)
df <- mtcars
header <- dashboardHeader(
title = "Test"
)
sidebar <- dashboardSidebar(
)
body <- dashboardBody(
box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
output$df = DT::renderDataTable(df, rownames = FALSE,
options = list(
autoWidth = TRUE,
columnDefs = list(list(width = '10px', targets = c(1,3)))))
}
# Shiny dashboard
shiny::shinyApp(ui, server)
After the success of the dynamic box in shiny here : R/Shiny : Color of boxes depend on select I need you to use these boxes but in a loop.
Example :
I have an input file which give this :
BoxA
BoxB
BoxC
I want in the renderUI loop these values as a variable to generate dynamically a Box A, B and C. (if I have 4 value, i will have 4 boxes etC.)
Here is my actually code:
for (i in 1:nrow(QRSList))
{
get(QRSOutputS[i]) <- renderUI({
column(4,
box(title = h3(QRSList[1], style = "display:inline; font-weight:bold"),
selectInput("s010102i", label = NULL,
choices = list("Non commencé" = "danger", "En cours" = "warning", "Terminé" = "success"),
selected = 1) ,width = 12, background = "blue", status = get(QRSIntputS[i])))
})
column(4,
observeEvent(input$s010102i,{
get(QRSOutputS[i]) <- renderUI({
box(title = h3(QRSList[1], style = "display:inline; font-weight:bold"),
selectInput("s010102i", label = NULL,
choices = list("Not good" = "danger", "average" = "warning", "good" = "success"),
selected = get(QRSIntputS[i])) ,width = 12, background = "blue",status = get(QRSIntputS[i]))
})
The aim is to replace these box names to a variable like input$s010102 for example. But get and assign function does not exist.
Any idea ?
Thanks a lot
Here is an example how to generate boxes dynamically
library(shinydashboard)
library(shiny)
QRSList <- c("Box1","Box2","Box3","Box4","Box5")
ui <- dashboardPage(
dashboardHeader(title = "render Boxes"),
dashboardSidebar(
sidebarMenu(
menuItem("Test", tabName = "Test")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Test",
fluidRow(
tabPanel("Boxes",uiOutput("myboxes"))
)
)
)
)
)
server <- function(input, output) {
v <- list()
for (i in 1:length(QRSList)){
v[[i]] <- box(width = 3, background = "blue",
title = h3(QRSList[i], style = "display:inline; font-weight:bold"),
selectInput(paste0("slider",i), label = NULL,choices = list("Not good" = "danger", "average" = "warning", "good" = "success"))
)
}
output$myboxes <- renderUI(v)
}
shinyApp(ui = ui, server = server)