Related
I'm trying to use reactive selectizeInput by first time in shiny modules, but It's not working. I read the documentation of modules and reactive inputs, but I don't know how to work with it together. I made a simplify code to show my doubt. This is the code without modules, It's working well:
library(shiny)
library(shinydashboard)
library(highcharter)
a<- c(1,2,3,4,5)
b<- c(0.5,1,2,6,8)
dt <- seq(as.Date("2018-01-01"), as.Date("2018-01-05"), by = "days")
ts <- xts(a, dt )
names(ts)="a"
ts$b <- xts(b, dt )
ui<-dashboardPage(title= "Dashboard", skin= "green",
dashboardHeader(title="PROYECTO"),
dashboardSidebar(
sidebarMenu(id="sidebarID",
menuItem("OVERVIEW",tabName = "datos"
)
)
),
dashboardBody(
tabItems(tabItem(tabName = "datos",
fluidRow(
column(width = 6,
selectizeInput("select",
"Choose",
c("a"="1",
"b"="2")
)),
box(width=6, column( width=12,
column(width=12,highchartOutput("y"))
),
height = 400))
)
)))
server <- function(input, output,session) {
y_react<-reactive(
highchart(type="stock") %>%
hc_add_series(ts[,as.numeric(input$select)],
type = "line",
color="red")
)
output$y <-renderHighchart(y_react())
}
shinyApp(ui, server)
Now, I was trying to adapt it into modules. I created a module:
a<- c(1,2,3,4,5)
b<- c(0.5,1,2,6,8)
dt <- seq(as.Date("2018-01-01"), as.Date("2018-01-05"), by = "days")
ts <- xts(a, dt )
names(ts)="a"
ts$b <- xts(b, dt )
yUI<-function(id) {tagList(highchartOutput(NS(id,"y")))
}
yServer<-function(id){
moduleServer(id, function(input, output, session) {
y_react<-reactive(
highchart(type="stock") %>%
hc_add_series(ts[,as.numeric(input$select)],
type = "line",
color="red")
)
output$y <-renderHighchart(y_react())
})}
And shiny dashboard:
a<- c(1,2,3,4,5)
b<- c(0.5,1,2,6,8)
dt <- seq(as.Date("2018-01-01"), as.Date("2018-01-05"), by = "days")
ts <- xts(a, dt )
names(ts)="a"
ts$b <- xts(b, dt )
yUI<-function(id) {tagList(highchartOutput(NS(id,"y")))
}
yServer<-function(id){
moduleServer(id, function(input, output, session) {
y_react<-reactive(
highchart(type="stock") %>%
hc_add_series(ts[,as.numeric(input$select)],
type = "line",
color="red")
)
output$y <-renderHighchart(y_react())
})}
But It's not working.
The issue is that in the module server you are using input$select which however is created outside of the module. Doing so the server will look for a select in the module namespace. However, as there is no input with ID select in the module namespace you get an error.
To fix that you could pass the input$select to the module server as an argument:
``` r
library(shiny)
library(shinydashboard)
library(highcharter)
library(xts)
yUI <- function(id) {
tagList(
highchartOutput(NS(id, "y"))
)
}
yServer <- function(id, choice) {
moduleServer(id, function(input, output, session) {
y_react <- reactive(
highchart(type = "stock") %>%
hc_add_series(ts[, choice],
type = "line",
color = "red"
)
)
output$y <- renderHighchart(y_react())
})
}
ui <- dashboardPage(
title = "Dashboard", skin = "green",
dashboardHeader(title = "PROYECTO"),
dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem("OVERVIEW", tabName = "datos")
)
),
dashboardBody(
tabItems(tabItem(
tabName = "datos",
fluidRow(
column(
width = 6,
selectizeInput(
"select",
"Choose",
c(
"a" = "1",
"b" = "2"
)
)
),
box(
width = 6, column(
width = 12,
column(width = 12, yUI("y"))
),
height = 400
)
)
))
)
)
server <- function(input, output, session) {
yServer("y", as.numeric(input$select))
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:3301
A second option and probably more in the spirt of what modules are meant for would be to include the selectizeInput in the module. Doing so the input with inputID select becomes part of the module namespace and can be accessed from within the module server using input$select. As you want to place the UI elements in different parts of your dashboard I decided for two module UI "functions" which adds the flexibility to place the UI elements individually:
yUI_plot <- function(id) {
tagList(
highchartOutput(NS(id, "y"))
)
}
yUI_select <- function(id) {
selectizeInput(
NS(id, "select"),
"Choose",
c(
"a" = "1",
"b" = "2"
)
)
}
yServer <- function(id) {
moduleServer(id, function(input, output, session) {
y_react <- reactive(
highchart(type = "stock") %>%
hc_add_series(ts[, as.numeric(input$select)],
type = "line",
color = "red"
)
)
output$y <- renderHighchart(y_react())
})
}
ui <- dashboardPage(
title = "Dashboard", skin = "green",
dashboardHeader(title = "PROYECTO"),
dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem("OVERVIEW", tabName = "datos")
)
),
dashboardBody(
tabItems(tabItem(
tabName = "datos",
fluidRow(
column(
width = 6,
yUI_select("y")
),
box(
width = 6, column(
width = 12,
column(width = 12, yUI_plot("y"))
),
height = 400
)
)
))
)
)
server <- function(input, output, session) {
yServer("y")
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:7210
I want to build an app by shinydashboard that work like this:
textInput
Submit actionbutton to update value box based in input text
valuebox (to show input text)
Tabbox with 5 tabpanel
Each tabpanel has histogram with different data and rendered by Highcharter
VerbatimTextOutput to indivate which tabpanel chosen
This is my code:
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(2)
Con <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(3)
Agr <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(4)
Emo <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(5)
Int <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
### Apps Atribut ========================================
header <- dashboardHeader(
title = "IPIP-BFM-50"
)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
textInput(
"unicode",
"Your Unique ID:",
placeholder = "Input your unique ID here"
),
actionButton(
"ab1_unicode",
"Submit"
),
width = 6
),
tags$head(tags$style(HTML(".small-box {height: 130px}"))),
valueBoxOutput(
"vbox1_unicode",
width = 6
)
),
fluidRow(
tabBox(
title = "Dimensi Big-Five Marker",
id = "tabset1",
height = "500px",
width = 12,
tabPanel(
"Extraversion",
"This is Extraversion",
highchartOutput(
"hist"
)
),
tabPanel(
"Conscientiousness",
"This is Conscientiousness",
highchartOutput(
"hist"
)
),
tabPanel(
"Agreeableness",
"This is Agreeableness",
highchartOutput(
"hist"
)
),
tabPanel(
"Emotional Stability",
"This is Emotional Stability",
highchartOutput(
"hist"
)
),
tabPanel(
"Intelligent",
"This is Intelligent",
highchartOutput(
"hist"
)
)
)
),
fluidRow(
box(
"Personality in a nutshell", br(),
"Second row of personality explanation",
verbatimTextOutput(
"tabset1selected"
),
width = 12,
height = "250px"
)
)
)
### Atribut server
### Apps ================================================
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output){
update_unicode <- eventReactive(input$ab1_unicode,{
input$unicode
}, ignoreNULL = F)
output$vbox1_unicode <- renderValueBox({
valueBox(
update_unicode(),
"Your Unique ID",
icon = icon("fingerprint")
)
})
dimension <- function(dim){
if(dim == "Extraversion"){
Ext
} else if(dim == "Conscientiousness"){
Con
} else if(dim == "Agreeableness"){
Agr
} else if(dim == "Emotional Stability"){
Emo
} else if(dim == "Intelligent"){
Int
}
}
output$hist <- renderHighchart({
hchart(
dimension(input$tabset1)
) %>%
hc_xAxis(
list(
title = list(
text = "Data"
),
plotBands = list(
color = '#3ac9ad',
from = update_unicode,
to = update_unicode,
label = list(
text = "Your Score",
color = "#9e9e9e",
align = ifelse(update_unicode>30,"right","left"),
x = ifelse(update_unicode>30,-10,+10)
)
)
)
)
})
output$tabset1selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui,server = server)
Problems:
valuebox dissapear
highchart didn't appear
I made only 1 histogram with conditions to save the efeciency. but it looks didn't work well.
This is what the result looked like
Please help me guys
The issue is that the the binding between an id in the UI and on the server side has to be unique. However, in your dashboard the id="hist" appears more than once in the UI, i.e. you have a duplicated binding.
This could be seen by 1. opening the dashboard in the Browser, 2. opening the dev tools 3. having a look the console output which shows a JS error message "Duplicate binding for id hist".
Not sure about your final result but to solve this issue you could e.g. add one highchartOutput per panel. To this end:
I have put the plotting code in a separate function make_hc
Added an highchartOutput for each of your panels or datasets, e.g.
output$hist1 <- renderHighchart({
make_hc("Extraversion", update_unicode())
})
This way we get 5 outputs with unique ids which could be put inside the respective panels in the UI.
Full reproducible code:
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(2)
Con <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(3)
Agr <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(4)
Emo <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(5)
Int <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
### Apps Atribut ========================================
header <- dashboardHeader(
title = "IPIP-BFM-50"
)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
textInput(
"unicode",
"Your Unique ID:",
placeholder = "Input your unique ID here"
),
actionButton(
"ab1_unicode",
"Submit"
),
width = 6
),
tags$head(tags$style(HTML(".small-box {height: 130px}"))),
valueBoxOutput(
"vbox1_unicode",
width = 6
)
),
fluidRow(
tabBox(
title = "Dimensi Big-Five Marker",
id = "tabset1",
height = "500px",
width = 12,
tabPanel(
"Extraversion",
"This is Extraversion",
highchartOutput(
"hist1"
)
),
tabPanel(
"Conscientiousness",
"This is Conscientiousness",
highchartOutput(
"hist2"
)
),
tabPanel(
"Agreeableness",
"This is Agreeableness",
highchartOutput(
"hist3"
)
),
tabPanel(
"Emotional Stability",
"This is Emotional Stability",
highchartOutput(
"hist4"
)
),
tabPanel(
"Intelligent",
"This is Intelligent",
highchartOutput(
"hist5"
)
)
)
),
fluidRow(
box(
"Personality in a nutshell", br(),
"Second row of personality explanation",
verbatimTextOutput(
"tabset1selected"
),
width = 12,
height = "250px"
)
)
)
### Atribut server
### Apps ================================================
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output){
update_unicode <- eventReactive(input$ab1_unicode,{
input$unicode
}, ignoreNULL = F)
output$vbox1_unicode <- renderValueBox({
valueBox(
update_unicode(),
"Your Unique ID",
icon = icon("fingerprint")
)
})
dimension <- function(dim){
if(dim == "Extraversion"){
Ext
} else if(dim == "Conscientiousness"){
Con
} else if(dim == "Agreeableness"){
Agr
} else if(dim == "Emotional Stability"){
Emo
} else if(dim == "Intelligent"){
Int
}
}
make_hc <- function(x, update_unicode) {
hchart(
dimension(x)
) %>%
hc_xAxis(
list(
title = list(
text = "Data"
),
plotBands = list(
color = '#3ac9ad',
from = update_unicode,
to = update_unicode,
label = list(
text = "Your Score",
color = "#9e9e9e",
align = ifelse(update_unicode>30,"right","left"),
x = ifelse(update_unicode>30,-10,+10)
)
)
)
)
}
output$hist1 <- renderHighchart({
make_hc("Extraversion", update_unicode())
})
output$hist2 <- renderHighchart({
make_hc("Conscientiousness", update_unicode())
})
output$hist3 <- renderHighchart({
make_hc("Agreeableness", update_unicode())
})
output$hist4 <- renderHighchart({
make_hc("Emotional Stability", update_unicode())
})
output$hist5 <- renderHighchart({
make_hc("Intelligent", update_unicode())
})
output$tabset1selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui,server = server)
I'm trying to make this shiny app have a collapsible panel fixed at the top. But, whenever I make the position fixed, the collapse functionality doesn't work.
What do I have to do to fix this collapsible panel on top?
library(shiny)
library(shinyWidgets)
library(shinyBS)
library(DT)
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
)
)
)
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)
Perhaps you are looking for this
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
), style="position:fixed;"
)
)
),
fluidRow(
column(width=2, textInput("searchField1", "Search")),
column(width=2, uiOutput("saveText1"), actionButton("saveBtn1", "Save"))
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)
I am trying to build a shiny app where the user can decide how many tabs he wants to be shown. Here's what I have so far:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(glue)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = NULL, min = 1, max = 5, value = 3, step = 1)
),
dashboardBody(
fluidRow(
box(width = 12,
p(
mainPanel(width = 12,
column(6,
uiOutput("reference")
),
column(6,
uiOutput("comparison")
)
)
)
)
)
)
)
server <- function(input, output) {
output$reference <- renderUI({
tabsetPanel(
tabPanel(
"Reference",
h3("Reference Content"))
)
})
output$comparison <- renderUI({
req(input$slider)
tabsetPanel(
lapply(1:input$slider, function(i) {
tabPanel(title = glue("Tab {i}"),
value = h3(glue("Content {i}"))
)
})
)
})
}
shinyApp(ui = ui, server = server)
This does not produce the desired results, as the comparison tabs are not shown properly.
I have already checked out these 2 threads:
R Shiny - add tabPanel to tabsetPanel dynamically (with the use of renderUI)
R Shiny dynamic tab number and input generation
but they don't seem to solve my problem. Yes, they create tabs dynamically with a slider, but they don't allow to fill these with content as far as I can tell.
What works for me is a combination for lapply and do.call
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(glue)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = NULL, min = 1, max = 5, value = 3, step = 1)
),
dashboardBody(
fluidRow(
box(width = 12,
p(
mainPanel(width = 12,
column(6,
uiOutput("reference")
),
column(6,
uiOutput("comparison")
)
)
)
)
)
)
)
server <- function(input, output) {
output$reference <- renderUI({
tabsetPanel(
tabPanel(
"Reference",
h3("Reference Content"))
)
})
output$comparison <- renderUI({
req(input$slider)
myTabs = lapply(1:input$slider, function(i) {
tabPanel(title = glue("Tab {i}"),
h3(glue("Content {i}"))
)
})
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui = ui, server = server)
DATA
I want to add text in rightmost region in the dashboard and the text should cover all the right space column.
dashboardPage(skin="yellow",
dashboardHeader(title = "Wheat Price dashboard ),
dashboardSidebar(
sidebarMenu(
menuItem("Punjab-khanna", tabName = "dashboard", icon = icon("area-chart"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
fluidPage(
titlePanel("Wheat DARA"),
mainPanel(fluidRow(
box( side="right",
tabPanel("Price chart", dygraphOutput("plot1")
)
),box(side = "right",height="250px",includeMarkdown("read.md")))
) )
)
))
)
SERVER.R
d1<-read_excel("data/Wheat data forecasted.xlsx",sheet = 1,col_names =
TRUE)
#stock
d2 <-subset(d1, select = c(1,2,3,4,5))
#last
d1 <-subset(d1, select = c(1,5,6,7))
d1$`Date GMT` <- as.POSIXct(d1$`Date GMT`, format = "%Y-%m-%d", tz="GMT")
ts1 <- irts(time=d1$`Date GMT`,value=as.matrix(d1[,2:4]))
#stock
d2$`Date GMT` <- as.POSIXct(d2$`Date GMT`, format = "%Y-%m-%d", tz="GMT")
ts2 <- irts(time=d2$`Date GMT`,value=as.matrix(d2[,2:5]))
shinyServer(function(input, output) {
output$plot1 <- renderDygraph({
dygraph(ts1) %>%
dyRangeSelector() %>%
dyLegend(show = "always", hideOnMouseOut = FALSE) %>%
dyHighlight(highlightCircleSize = 5) %>%
dyOptions(axisLineColor = "navy", gridLineColor = "grey")
})
} )
I am not able to arrange it to the right side.
NOTE:I have written different text(from the image) but the task is same to arrange the text to rightmost region in dashboard
I've added a minimal reproducible code myself. Please check. You just have to play with fluidrow and column with width values.
if(interactive()) {
## app.R ##
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
column(
column(
fluidRow(
box(plotOutput("plot1"))
),
fluidRow(
box(plotOutput("plot2"))
),
width = 10
),
column(
h3(
textOutput('text1')
),
width = 2
),
width = 12
)
)
)
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
hist(histdata)
})
output$plot2 <- renderPlot({
hist(histdata)
})
output$text1 <- renderText({
"Uniform: These functions provide information about the uniform distribution on the interval from min to max. dunif gives the density, punif gives the distribution function qunif gives the quantile function and runif generates random deviates."
})
}
shinyApp(ui, server)
}
Source Code modified:
Please modify your dashboard input like this below. It also has plot2, since your initial question had one.
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
column(
column(
fluidRow(
tabPanel("Price chart", dygraphOutput("plot1")
),
fluidRow(
plotOutput("plot2")
),
width = 10
),
column(
h3(
includeMarkdown("read.md")
),
width = 2
),
width = 12
)
)
)