Get only InputIDs that have changed - shiny

Is it possible to select/get only the input names of the widgets that have changed? Say that I have a Shiny App and that I deselect a box of a checkboxGroupInput. Is it possible to somehow get the inputId of that widget?

Here is a solution using basic shiny:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins1",
"Number of bins 1:",
min = 1,
max = 50,
value = 30),
sliderInput("bins2",
"Number of bins 2:",
min = 1,
max = 50,
value = 30),
textOutput("printChangedInputs")
),
mainPanel(
plotOutput("distPlot1"),
plotOutput("distPlot2")
)
)
)
server <- function(input, output) {
output$distPlot1 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins1 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distPlot2 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins2 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
previousInputStatus <- NULL
changedInputs <- reactive({
currentInputStatus <- unlist(reactiveValuesToList(input))
if(is.null(previousInputStatus)){
previousInputStatus <<- currentInputStatus
changedInputs <- NULL
} else {
changedInputs <- names(previousInputStatus)[previousInputStatus != currentInputStatus]
print(paste("Changed inputs:", changedInputs))
previousInputStatus <<- currentInputStatus
}
return(changedInputs)
})
output$printChangedInputs <- renderText({paste("Changed inputs:", changedInputs())})
}
shinyApp(ui = ui, server = server)
Edit: Another way would be to listen for the JavaScript event shiny:inputchanged:
library(shiny)
ui <- fluidPage(
tags$head(
tags$script(
"$(document).on('shiny:inputchanged', function(event) {
if (event.name != 'changed') {
Shiny.setInputValue('changed', event.name);
}
});"
)
),
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins1",
"Number of bins 1:",
min = 1,
max = 50,
value = 30),
sliderInput("bins2",
"Number of bins 2:",
min = 1,
max = 50,
value = 30),
textOutput("changedInputs")
),
mainPanel(
plotOutput("distPlot1"),
plotOutput("distPlot2")
)
)
)
server <- function(input, output) {
output$distPlot1 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins1 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distPlot2 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins2 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$changedInputs <- renderText({paste("Changed inputs:", input$changed)})
}
shinyApp(ui = ui, server = server)
Please see this for more information.

Related

Shiny plot is outside the dashboardBody

Please see attached image. Do you have suggestions how to avoid that the plot is outside the white area, or to make the grey area below the plot white?
ui <- dashboardPage(
# Application title
dashboardHeader(title=h4(HTML("Virus Coverage plot"))),
dashboardSidebar(
useShinyjs(),
selectInput("Taxa", "Taxa", choices = unique(files.Vir.DNA.df.test$V1))
),
dashboardBody(
tabsetPanel(
tabPanel("Taxa", plotOutput("myplot1"))
)
)
)
server <- function(input, output, session) {
data_selected <- reactive({
filter(files.Vir.DNA.df.test, V1 %in% input$Taxa)
})
output$myplot1 <- renderPlot({
#data_selected() %>%
# filter(Cancer=="Anus" | Cancer=="Cervix") %>%
p <- ggplot(data_selected(),aes(position,rowSums, fill = V1)) +
#theme_bw(base_size = 6) +
geom_bar(stat="identity") +
facet_grid(Cancer~. , scales = "free_x", space = "free_x", switch = "x") +
theme(strip.text.y = element_text(angle = 0),
strip.text.x = element_text(angle = 90),
strip.background = element_rect(colour = "transparent", fill = "transparent"),
plot.background = element_rect(colour = "white", fill = "white"),
panel.background = element_rect(colour = "white", fill = "white"),
axis.text.x = element_blank(),
axis.ticks.x = element_blank()) +
labs(y="Sum coverage within cancer type", x="", title="") +
scale_fill_manual(values=mycolors) +
theme(legend.position = "none")
#scale_y_log10()
print(p)
},res = 100,width = 600, height = 1200)
}
shinyApp(ui, server)
Your example isn't reproducible - so I made a new one.
You just need to wrap the plotOutput in a fluidRow:
library(shiny)
library(ggplot2)
library(datasets)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
# dashboardBody(plotOutput("myplot")) # exceeds body
dashboardBody(fluidRow(plotOutput("myplot"))) # works
)
server <- function(input, output, session) {
output$myplot <- renderPlot({
scatter <- ggplot(data=iris, aes(x = Sepal.Length, y = Sepal.Width))
scatter + geom_point(aes(color=Species, shape=Species)) +
xlab("Sepal Length") + ylab("Sepal Width") +
ggtitle("Sepal Length-Width")
}, height = 1200)
}
shinyApp(ui, server)

How can I plot the model output in shiny

This is the output, that I would like to plot with shiny.
<constr <- c(+4,-3,-2,-5)
# Uhlig rejection
model1s <- uhlig.reject(Y=uhligdata, nlags=12, draws=200, subdraws=200, nkeep=100, KMIN=1,
KMAX=5, constrained = constr, constant=FALSE, steps=60)
irf1s <- model1s$IRFS
irfplot(irf1s)
# Uhlig penalty
model1d <- uhlig.penalty(Y=uhligdata, nlags=12, draws=200, subdraws=1000,nkeep=100, KMIN=1, KMAX=5, constrained=constr,
constant=FALSE, steps=60, penalty=100, crit=0.001)
irf1d <- model1d$IRFS
irfplot(irf1d)>
and below is my attemp. I am trying to have the test, lags and periods dynamic and based on them to have the IRFs plotted.
ui <- dashboardPage(
dashboardHeader(title = "НАЧАЛО"),
dashboardSidebar(
sidebarMenu(
menuItem("BVAR",
tabName = "test_tab",
icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "test_tab",
box(column(10,
radioButtons("test1",
label = "Изберете тест",
choices = c("Uhlig rejection", "Uhlig penalty")),
numericInput("nlags", "NLAGS", min = 1, max = 20, value = 1, step = 1),
numericInput("kmin", "KMIN", min = 1, max = 10, value = 1, step = 1),
numericInput("kmax", "KMAX", min = 2, max = 10, value = 2, step = 1),
submitButton("Submit"))),
box(column(12,
plotOutput("plot2",8))),)
)
))
server <- function(input, output){
modelselect <- reactive({
if(input$test1 == "Uhlig Rejection"){
fit <- uhlig.reject(uhligdata, nlags = input$nlags,constrained = constr, KMIN = input$kmin, KMAX = input$kmax)
return(fit)
}else
if(input$test1 == "Uhlig Penalty"){
fit <- uhlig.penalty(uhligdata,nlags = input$nlags, KMIN = input$kmin, KMAX = input$kmax)
return(fit)
}
})
myplot1 <- reactive({
if(input$test1 == "Uhlig Rejection"){
irfs <- modelselect()$IRFS
irfs} else
if(input$test1 == "Uglig Penalty"){
irfs <-modelselect()$IRFS
irfs}
})
output$plot2 <- renderPlot({
irfplot(myplot1())
})
}
shinyApp(ui = ui, server = server)
The dashboard loads fine but I cannot access the IRF plot. I wonder if the problem is with the reactive function or I do not access the model output correctly(I am quite a newbie to shiny)?

Small icon in DT table

Can we add a small icon next to values in DT table. Example
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
fluidRow(column(width = 12),
fluidRow(box(width = 4, dateInput("date","Date", value = Sys.time(), min = Sys.time(), max = Sys.time()-30)),
box(width = 7, selectInput("df","DF",choices = unique(iris$Species)),offset = 0),
box(width = 2, actionButton("ab","Action")))),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),caption = "Iris",options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
}
IN the above DT table, can we add upward arrow next to Setosa . (It should be clickable)
Expect Output
You could use icon to display an up arrow.
library(shiny)
library(shinyWidgets)
library(DT)
library(dplyr)
ui <- fluidPage(
tags$h3("Material switch examples"),
dataTableOutput("df")
)
server <- function(input, output) {
data <- head(iris) %>% mutate(Species = paste(Species,as.character(icon("arrow-up", lib = "glyphicon"))))
output$df <- DT::renderDataTable({
datatable(data,caption = "Iris",options = list(dom = 'ft'),escape=FALSE, selection = list(mode = 'single',target = 'cell'))
})
}
shinyApp(ui, server)

How to add a conditional 'selectInput' based on a selected checkboxInput in shiny?

I would like that if the checkboxInput Factorial parameters is selected, this would do the app to show a new selectInput with several option.
Here is a minimum working example.
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
checkboxInput("fixed", "Factorial parameters"),
conditionalPanel(condition = "fixed == 'TRUE'",
selectInput("choice",
"Choose your fixed parameter",
c("alpha"= "Alpha", "beta"="Beta"),
selected = "alpha"))
)
,
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
shinyApp(ui = ui, server = server)
Can anyone tell me what am I doing wrong?
Many thanks!
Update
I figured it out! edit as follows:
conditionalPanel(condition = "input.fixed == 1",
Previous answers
Generally, you would need input.fixed in a conditionalPanel although this doesn't seem to work for checkboxInput for some reason (maybe someone else can explain why?). There are a few alternatives. I would suggest the shinyjs package.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
checkboxInput("fixed", "Factorial parameters"),
hidden(selectInput("choice",
"Choose your fixed parameter",
c("alpha"= "Alpha", "beta"="Beta"),
selected = "alpha"))
)
,
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
observeEvent(input$fixed, {
toggle("choice")
}, ignoreInit = TRUE)
})
}
shinyApp(ui = ui, server = server)
Instead of toggle you could be more explicit with an if...else statement using shinysj::show() and shinyjs::hide() although I think this is neater (just note the ignoreInit = TRUE).
As mentioned above using checkboxGroupInput for example seems to work with conditionalPanels:
checkboxGroupInput("fixed", label = "", choices = "Factorial parameters"),
conditionalPanel(condition = "input.fixed == 'Factorial parameters'",
selectInput("choice",
"Choose your fixed parameter",
c("alpha"= "Alpha", "beta"="Beta"),
selected = "alpha"))
slightly hacky but does the job.

My First R Shiny App

I've spent two days trying to create a Shiny app to no avail. It's fine just running the examples but when I want to modify it for my own preference, I just get constant errors and lack of functionality.
I have a simple dataset of 100 X observations and 100 Y observations. I want to plot histograms of both X and Y with slider inputs for bins. I also want to create a scatterplot of Y on X. I'd really appreciate some help here.
I'm not new to R but I'm new to Shiny. Is there a way I can use ggplot to create the visuals?
Many thanks.
This is a quick example with two different layouts. Use one of the ui.R of course. Put global.R in the same folder with ui.R and server.R
ui.R v1
library(shiny)
library(ggplot2)
shinyUI(fluidPage(
titlePanel("Quick Shiny Example"),
sidebarLayout(
sidebarPanel(
sliderInput("xBins",
"Number of bins for X variable:",
min = 1,
max = 50,
value = 30),
sliderInput("yBins",
"Number of bins for Y variable:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("xDistPlot"),
plotOutput("yDistPlot"),
plotOutput("xyScatterPlot")
)
)
))
ui.R v2
library(shiny)
library(ggplot2)
shinyUI(fluidPage(
titlePanel("Quick Shiny Example"),
fluidRow(
column(width = 4,
sliderInput("xBins",
"Number of bins for X variable:",
min = 1,
max = 50,
value = 30)
),
column(width = 4,
sliderInput("yBins",
"Number of bins for Y variable:",
min = 1,
max = 50,
value = 30)
),
column(width = 4)
),
fluidRow(
column(width = 4,
plotOutput("xDistPlot")
),
column(width = 4,
plotOutput("yDistPlot")
),
column(width = 4,
plotOutput("xyScatterPlot")
)
)
))
server.R
library(shiny)
library(ggplot2)
shinyServer(function(input, output) {
output$xDistPlot <- renderPlot({
g <- ggplot(df, aes(x = x))
g <- g + geom_histogram(bins = input$xBins)
g
})
output$yDistPlot <- renderPlot({
g <- ggplot(df, aes(x = y))
g <- g + geom_histogram(bins = input$yBins)
g
})
output$xyScatterPlot <- renderPlot({
g <- ggplot(df, aes(x = x, y = y))
g <- g + geom_point()
g
})
})
global.R
df <- data.frame(
x = rnorm(100),
y = rnorm(100)*2
)
Here is my answer, with random numbers for X and Y, just as a quick idea. Adding ggplot to this should be easy.
library(shiny)
ui <- shinyUI(
fluidPage(
sliderInput("nrBinsX", "Number of bins to display for X", min = 2, max = 10, value = 5),
plotOutput("histX"),
sliderInput("nrBinsY", "Number of bins to display for Y", min = 2, max = 10, value = 5),
plotOutput("histY"),
plotOutput("scatterXY")
)
)
server <- shinyServer(function(input, output, session) {
dataFrame <- data.frame (
"X" = sample(100,100,replace = T),
"Y" = sample(100,100,replace = T)
)
getHist <- function (var,nr){
return (hist(
x = var,
breaks = seq(0,100,100/nr),
freq = T
) )
}
output$histX <- renderPlot({
return(
getHist( var = dataFrame$X,
nr = input$nrBinsX
) ) })
output$histY <- renderPlot({
return( return(
getHist( var = dataFrame$Y,
nr = input$nrBinsY
)
) ) })
output$scatterXY <- renderPlot({
return(
plot(x = dataFrame$X,
y = dataFrame$Y)
)
})
})
shinyApp(ui = ui, server = server)