I have below app using multiInput() from shinyWidgets package
library(shinyWidgets)
library(shiny)
ui <- fluidPage(
div(style = "height: 200px;",
tags$head(
tags$style(".multi-wrapper {height: 90%;}"),
tags$style(".multi-wrapper .non-selected-wrapper, .multi-wrapper .selected-wrapper {height: 100%;}")
),
div(style = "height: 100%; background-color: rgba(0,0,0,.3);",
multiInput(
inputId = "id", label = "Fruits :",
choices = c("Banana", "Blueberry", "Cherry",
"Coconut", "Grapefruit", "Kiwi",
"Lemon", "Lime", "Mango", "Orange",
"Papaya"),
selected = "Banana", width = "400px",
options = list(
enable_search = FALSE,
non_selected_header = "Choose between:",
selected_header = "You have selected:"
)
)
)),
verbatimTextOutput(outputId = "res")
)
server <- function(input, output, session) {
output$res <- renderPrint({
input$id
})
}
shinyApp(ui = ui, server = server)
I want multiInput() should occupy entire height of parent Div which is not the case here. Any idea how to achieve this would be helpful
This seems to work:
library(shinyWidgets)
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(".multi-wrapper {height: 350px;}"), # 350 = 400-50 (400 is the height of the div)
tags$style(".multi-wrapper .non-selected-wrapper, .multi-wrapper .selected-wrapper {height: 100%;}")
),
div(style = "height: 400px",
multiInput(
inputId = "id", label = "Fruits :",
choices = c("Banana", "Blueberry", "Cherry",
"Coconut", "Grapefruit", "Kiwi",
"Lemon", "Lime", "Mango", "Orange",
"Papaya"),
selected = "Banana", width = "400px",
options = list(
enable_search = FALSE,
non_selected_header = "Choose between:",
selected_header = "You have selected:"
)
)
),
verbatimTextOutput(outputId = "res")
)
server <- function(input, output, session) {
output$res <- renderPrint({
input$id
})
}
shinyApp(ui = ui, server = server)
Related
I want the user to complete his email address to restore the password. I need the user to populate part of his email address in a inputText that is in the same line with the rest. I want something like this:
but this is what i get:
This is my code:
library(shiny)
ui <- fluidPage(
uiOutput("completeMailMessage")
,actionButton("Restore","Restore user")
)
server <- function(input, output, session) {
emailAddress<-"someone#gmail.com"
dotPosition<-tail(unlist(gregexpr("#", emailAddress)), n=1)
firstPart<-substr(emailAddress,1,1)
secondPart<-substr(emailAddress,2,dotPosition-2)
thirdPart<-substr(emailAddress,dotPosition-1,nchar(emailAddress))
observeEvent(input$Restore,{
emailAddress2<-paste0(firstPart,input$b,thirdPart)
print(emailAddress2)
})
output$completeMailMessage<-renderUI({
fluidRow(
tags$head(
tags$style(type="text/css","label{ display: table-cell; text-align: center;vertical-align: middle; } .form-group { display: table-row;}")
),
h4("Complete the email to restore the password:"),
div(style= " text-align: left;"
,tags$h5(firstPart)
,textInput(inputId = "b",
label = div(style = "font-size:10pX;", ""), value=secondPart,width = "200px")
,tags$h5(thirdPart)
)
)
})
}
shinyApp(ui = ui, server = server)
Any suggestion?
Thanks!
One solution:
library(shiny)
ui <- fluidPage(
uiOutput("completeMailMessage")
,actionButton("Restore","Restore user")
)
server <- function(input, output, session) {
emailAddress<-"someone#gmail.com"
dotPosition<-tail(unlist(gregexpr("#", emailAddress)), n=1)
firstPart<-substr(emailAddress,1,1)
secondPart<-substr(emailAddress,2,dotPosition-2)
thirdPart<-substr(emailAddress,dotPosition-1,nchar(emailAddress))
observeEvent(input$Restore,{
emailAddress2<-paste0(firstPart,input$b,thirdPart)
print(emailAddress2)
})
output$completeMailMessage<-renderUI({
fluidPage(
fluidRow(h4("Complete the email to restore the password:")),
fluidRow(
tags$head(
tags$style(HTML(
".form-control { height:auto; padding:1px 1px;}"
))
),
column(width = 1,
div(style = "white-space: nowrap;",
h5(firstPart,style="display:inline-block"),
div(style="display: inline-block; width: 100%;margin-left:0px",textInput("b", label = NULL, value = secondPart, width = 80)),
h5(thirdPart,style="display:inline-block")
)
)
)
)
})
}
shinyApp(ui = ui, server = server)
Lets take the example of the reference: https://rstudio.github.io/shinydashboard/structure.html#sidebar-menu-items-and-tabs. When put more items in the menuItem(), your associate tab don't works anymore. I tried in this simple modification in example below and just shown the widgets' tab:
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard",
tabName = "dashboard",
icon = icon("dashboard"),
selected = TRUE,
startExpanded = TRUE,
numericInput("num1",
"Put the First Number",
value = 1,
min = 0),
numericInput("num2",
"Put the Second Number",
value = 1,
min = 0)
),
menuItem("Widgets",
icon = icon("th"),
tabName = "widgets")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content"),
fluidRow(
valueBoxOutput("box1", width = 6),
valueBoxOutput("box2", width = 6)
)
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# Put them together into a dashboardPage
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "Example"),
sidebar,
body
)
server <- function(input, output){
output$box1 <- renderValueBox({
valueBox(input$num1,
"First Number",
color = "aqua",
icon = icon("chart-line"))
})
output$box2 <- renderValueBox({
valueBox(input$num2,
"Second Number",
color = "aqua",
icon = icon("chart-line"))
})
}
shinyApp(ui, server)
That is because childfull menuItem behaves differently as noted here. Therefore, you need to define a menuItem or a menSubItem within that dashboard page so that your desired content can be displayed.
Try this
sidebarMenu(id = "tabs",
menuItem("Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt"),
selected = TRUE,
startExpanded = TRUE,
#icon = icon(fontawesome:::fa_tbl[[1]][505]),
menuItem("Sub-item 1", tabName = "subitem1"),
### menuSubItem("Sub-item 1", tabName = "subitem1"), ## it can be menuSubItem instead of menuItem
numericInput("num1",
"Put the First Number",
value = 1,
min = 0),
numericInput("num2",
"Put the Second Number",
value = 2,
min = 0)
),
menuItem("Widgets",
icon = icon("th"),
tabName = "widgets")
)
)
body <- shinydashboard::dashboardBody(
tabItems(
tabItem(tabName = "subitem1",
h2("Sub item1 tab content in Dashboard"),
fluidRow(
valueBoxOutput("box1", width = 6),
valueBoxOutput("box2", width = 6)
)
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# Put them together into a dashboardPage
ui <- shinydashboard::dashboardPage(
skin = "green",
shinydashboard::dashboardHeader(title = "Example"),
sidebar,
body
)
server <- function(input, output, session){
output$box1 <- renderValueBox({
valueBox(input$num1,
"First Number",
color = "aqua",
icon = icon("chart-line"))
})
output$box2 <- renderValueBox({
valueBox(input$num2,
"Second Number",
color = "aqua",
icon = icon("chart-line"))
})
observe({print(input$tabs)})
}
shinyApp(ui, server)
in the dashboardBody, in tabPanel- "tab2" title="plot", I have a selectInput object whose choices are based on the dataTable output "contents2" from the server. While doing so, I am not getting any choices populated in the dropdown menu of selectInput object and also when I am trying to plot the histogram based on the choices from selectInput, I am getting an error : "object 'contents2' not found"
Please can someone guide me here.
library(shinyWidgets)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title="Test"),
dashboardSidebar(
sidebarMenu(id = 'sbar', verbatimTextOutput("text1"),
menuItem("File Selection", tabName = 'page1', icon = icon('line-chart'),
fileInput("file1", "Select CSV File", accept = c("text/csv","text/comma-
separated-values,text/plain",".csv")),
menuSubItem(actionButton(inputId="next1", label="NEXT"), tabName="next",
icon="") ),
menuItem('File Edit', tabName = 'page2',icon = icon('line-chart')),
menuItem('Section 3',tabName = 'page3',icon = icon('line-chart')) )
),
dashboardBody(
tabItems(
tabItem(tabName = "next",fluidRow(
tabBox(id = "tabset1", height = "650px", width=12,
tabPanel("Input Data", value="tab1", " ",
# fluidRow(tags$head(tags$style(HTML(" label {float:left;} "))),
radioGroupButtons("disp", "",label=NULL,
choices = c('Display head data'="head",'Display entire
data'="all"), selected=NULL),
fluidRow(DT::dataTableOutput("contents1"),style = "height:500px;
overflow-y: scroll;overflow-x: scroll;",
title = "Dashboard example") ),
tabPanel("Plot", value="tab2", " ",
selectInput("select1","Select Variable for display",choices =
c(colnames(DT::dataTableOutput("mydata")))),
fluidRow(plotOutput("plot1"))),
tabPanel("tab3 title", value='tab3', " ",
valueBoxOutput('tab3_valuebox'))
) ) ),
tabItem(tabName="page2", fluidRow(
tabBox(id = "tabset2", height = "650px", width=12, title = "My Page2 info",
tabPanel("Input Data", value="tab1", " ",
fluidRow(DT::dataTableOutput("contents2"))),
tabPanel("Plot", value="tab2", " ",
fluidRow(plotOutput("plot2")) )
) ) ) ) ) )
server <- function(input, output, session) {
observeEvent(input$next1, {
updateTabItems(session, "sbar", "next")
req(input$next1)
if (input$next1 == 0) {
return(NULL)
}else if (input$next1 == 1 & is.null(input$file1)) {
return(NULL)
}else {
inFile <- input$file1
myfile <- read_csv(inFile$datapath)
output$contents1 <- renderDataTable({
if(input$disp == "head") {
return(head(myfile))
}else {
return(myfile) }})
output$contents2 <- renderDataTable({
myfile }) }
})
observe(input$select1)
output$text1 <- renderText(print(input$sbar))
output$plot1 <- renderPlot({hist(contents2$input$select1)})
output$plot2 <- renderPlot({hist(rnorm(20))})
output$tab3_valuebox <- renderValueBox({
valueBox('2020',subtitle = "Need to use this in future",icon = icon("car"),
color = "red") })
}
shinyApp(ui, server)
Process the selectInput on the server side and create a reactive dataframe to work with. The code below works.
ui <- dashboardPage(
dashboardHeader(title="Test"),
dashboardSidebar(
sidebarMenu(id = 'sbar', verbatimTextOutput("text1"),
menuItem("File Selection", tabName = 'page1', icon = icon('line-chart'),
fileInput("file1", "Select CSV File", accept = c("text/csv","text/comma-
separated-values,text/plain",".csv")),
menuSubItem(actionButton(inputId="next1", label="NEXT"), tabName="next",
icon="") ),
menuItem('File Edit', tabName = 'page2',icon = icon('line-chart')),
menuItem('Section 3',tabName = 'page3',icon = icon('line-chart')) )
),
dashboardBody(
tabItems(
tabItem(tabName = "next",fluidRow(
tabBox(id = "tabset1", height = "650px", width=12,
tabPanel("Input Data", value="tab1", " ",
# fluidRow(tags$head(tags$style(HTML(" label {float:left;} "))),
radioGroupButtons("disp", "",label=NULL,
choices = c('Display head data'="head",'Display entire
data'="all"), selected=NULL),
fluidRow(DT::dataTableOutput("contents1"),style = "height:500px;
overflow-y: scroll;overflow-x: scroll;",
title = "Dashboard example") ),
tabPanel("Plot", value="tab2", " ", uiOutput("selectvar"),
# selectInput("select1","Select Variable for display",choices =
# c(colnames(DT::dataTableOutput("mydata")))),
fluidRow(plotOutput("plot1"))),
tabPanel("tab3 title", value='tab3', " ",
valueBoxOutput('tab3_valuebox'))
) ) ),
tabItem(tabName="page2", fluidRow(
tabBox(id = "tabset2", height = "650px", width=12, title = "My Page2 info",
tabPanel("Input Data", value="tab1", " ",
fluidRow(DTOutput("contents2"))),
tabPanel("Plot", value="tab2", " ",
fluidRow(plotOutput("plot2")) )
) ) ) ) ) )
server <- function(input, output, session) {
observeEvent(input$next1, {
updateTabItems(session, "sbar", "next")
req(input$next1)
if (input$next1 == 0) {
return(NULL)
}else if (input$next1 == 1 & is.null(input$file1)) {
return(NULL)
}else {
inFile <- input$file1
#myfile <- read_csv(inFile$datapath)
myfile <- reactive(read_csv(inFile$datapath))
output$contents1 <- renderDataTable({
if(input$disp == "head") {
return(head(myfile()))
}else {
return(myfile()) }})
output$contents2 <- renderDT(myfile())
output$selectvar <- renderUI({
req(input$file1)
selectInput("select1", "Select Variable for display",
choices = c(colnames(myfile())))
})
output$plot1 <- renderPlot({hist(myfile()[[input$select1]])})
}
})
#observe(input$select1)
output$text1 <- renderText(print(input$sbar))
output$plot2 <- renderPlot({hist(rnorm(20))})
output$tab3_valuebox <- renderValueBox({
valueBox('2020',subtitle = "Need to use this in future",icon = icon("car"),
color = "red") })
}
shinyApp(ui, server)
How can I use a download button instead of hc_exporting function to download a highchart in shiny?
library(shiny)
library(shinydashboard)
library(highcharter)
library(shinyWidgets)
RecruitmentFunneldb_struct <-
structure(list(
yyyy = c(2019L, 2019L, 2019L, 2019L, 2019L, 2019L),
stages = c(
"Phone Scrining",
"Interview",
"Offer",
"Pre-Onboarding",
"Post-Joining",
"Joined"
),
pop = c(8L, 25L, 23L, 32L, 8L, 4L)
),
row.names = c(NA,
6L),
class = "data.frame")
ui <-
dashboardPage(
dashboardHeader(
title = HTML("Analytic view - Recruitment"),
titleWidth = 280
),
dashboardSidebar(disable = T),
dashboardBody(fluidPage(fluidRow(
box(
title = fluidRow(
column(10, "Recruitment Funnel"),
column(
2,
align = "right",
downloadButton("download", label = NULL, class = "butt1"),
tags$head(
tags$style(
".butt1{display: inline-block;} .butt1{font-size: 20px;} .butt1{border: none;} .butt1{padding-top: 1px} .butt1{background-color: transperent .butt1{padding-right: 50px}}"
)
)
)
),
solidHeader = T,
width = 4,
collapsible = F,
highchartOutput("Recruitment_Funnel", height = "240px")
)
)))
)
server <- function(input, output, session) {
output$Recruitment_Funnel <- renderHighchart({
Reserve_Data <- RecruitmentFunneldb_struct %>% arrange(-pop)
Reserve_Data %>%
hchart("funnel", hcaes(x = stages, y = pop))
})
output$download <- downloadHandler(
filename = function() {
paste("Funnel", ".", "pdf")
},
content = function(file) {
pdf(file)
output$Recruitment_Funnel()
dev.off()
}
)
}
shinyApp(ui, server)
I have below app using shinyWidgets package
library(shinyWidgets); library("shiny")
ui <- fluidPage(
multiInput(
inputId = "id", label = "Fruits :",
choices = c("Banana", "Blueberry", "Cherry",
"Coconut", "Grapefruit", "Kiwi",
"Lemon", "Lime", "Mango", "Orange",
"Papaya"),
selected = "Banana", width = "400px",
options = list(
enable_search = FALSE,
non_selected_header = "Choose between:",
selected_header = "You have selected:"
)
),
verbatimTextOutput(outputId = "res")
)
server <- function(input, output, session) {
output$res <- renderPrint({
input$id
})
}
shinyApp(ui = ui, server = server)
Is it possible to customize this further. Particularly I want to change the font color to Black for all choices. I added below line, however it failed to change the font color
tags$head(tags$style(HTML('#id {color:#000 !important;}'))),
Any pointer will be highly appreciated.
Use this CSS:
css <- "#id+div div a {color: black;}"
ui <- fluidPage(
tags$head(tags$style(css)),
......