Related
I have this small example app adapted from the web:
library( shiny )
library( shinyWidgets )
ui <- fluidPage(
tags$br(),
noUiSliderInput(
inputId = "noui2", label = "Slider vertical:",
min = 0, max = 1000, step = 50,
value = c(100, 400), margin = 100,
orientation = "vertical",
width = "100px", height = "300px"
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
}
shinyApp(ui, server)
Then I load an image as background like:
I am wondering if there is a way to color the specific area hight between 100 and 400 (given by the slider) in the borders of the figure like:
Below please find an approach using plotly's filled area plots:
library(shiny)
library(plotly)
library(shinyWidgets)
DF <- data.frame(
x = c(cos(seq(0.01, 10, 0.01)) * 1000:1 + 1000, cos(seq(0.01, 10, 0.01)) * 1000:1 + 1500),
y = rep(1:1000, 2),
id = c(rep("trace_1", 1000), rep("trace_2", 1000))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("plot")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
plotDF <- reactive({
plotDF <- DF[DF$y %in% input$noui2[1]:input$noui2[2], ]
plotDF$id <- paste0("filtered_", plotDF$id)
plotDF
})
output$plot <- renderPlotly({
fig <- plot_ly(
rbind(DF, plotDF()),
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("black"),
fillcolor = 'red',
showlegend = FALSE
) |> style(fill = 'tonexty', traces = 2)
})
}
shinyApp(ui, server)
This is somewhat of a first attempt, the alignment is not perfect but it gets the idea across. Note the plotting box is still there to get a bit more insight what happens while aligning.
library( shiny )
library( shinyWidgets )
ui <- fluidPage(
tags$br(),
fluidRow(
column(2,noUiSliderInput(
inputId = "noui2", label = "Slider vertical:",
min = 0, max = 1000, step = 50,
value = c(100, 400), margin = 100,
orientation = "vertical",
width = "100px", height = "300px"
)),column(10,plotOutput("plot",height = "330px"))
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
output$plot<-renderPlot({
par(mar=c(0,0,1.5,0))
plot(type='n',0:1*1000,0:1*1000, xlab='', ylab='', xaxt='n', yaxt='n')
rect(100, 1000-input$noui2[2], 300,1000-input$noui2[1] , col='red')
})
}
shinyApp(ui, server)
Let's consider my very basic application :
Created by code :
Server
library(shiny) # Load shiny package
start <- as.Date("2013-01-01")
end <- as.Date("2016-10-01")
#Apple stock
getSymbols("AAPL", src = "yahoo", from = start, to = end)
apple <- AAPL$AAPL.Close
#Gold
getSymbols('GOLD', src = 'yahoo', from = start, to = end)
gold <- GOLD$GOLD.Close
#S&P500
getSymbols('^GSPC', src = 'yahoo', from = start, to = end)
sp <- as.numeric(`GSPC`[,4])
#Microsoft
getSymbols('MSFT', src = 'yahoo', from = start, to = end)
msft <- MSFT$MSFT.Close
stock.frame <- data.frame(apple, gold, msft, sp)
colnames(stock.frame) <- c('apple', 'gold', 'msft', 'sp')
shinyServer(
function(input, output) {
output$myhist <- renderPlot({
colm <- as.numeric(input$var)
hist(stock.frame[, colm], col = input$colour, xlim = c(min(stock.frame[, colm]), max(stock.frame[, colm])), main = "Histogram of stock dataset", breaks = seq(min(stock.frame[, colm]), max(stock.frame[, colm]), l = input$bin + 1), xlab = names(stock.frame[colm]))
})
}
)
UI
library(shiny) # load the shiny package
# Define UI for application
shinyUI(fluidPage(
# Header or title Panel
titlePanel(h4('Demostration of the renderPlot() - A Histogram with stock dataset', align = "center")),
# Sidebar panel
sidebarPanel(
selectInput("var", label = "1. Select the quantitative Variable",
choices = c("Apple" = 1, "Gold" = 2, "S&P" = 3, "BTC"=4),
selected = 3),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=50, value=15),
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red",
"Yellow"), selected = "Green")
),
# Main Panel
mainPanel(
textOutput("text1"),
textOutput("text2"),
textOutput("text3"),
plotOutput("myhist")
)
)
)
I want to have another sidebarPanel (analogous to '1. Select the quantitative Variable') in which I can specify if I want 'Histogram' or 'nothing'. If histogram was choosed then I should have same thing as above. When "nothing' was choosed I should see blank page. Do you know how it can be performed ?
EDIT
I added radiobutton as #r2evans suggested. It now look's in the way following :
shinyUI(fluidPage(
radioButtons("rb", "Plot type:", choiceNames = c("Histogram", "Nothing")),
# Header or title Panel
titlePanel(h4('Demostration of the renderPlot() - A Histogram with stock dataset', align = "center")),
# Sidebar panel
sidebarPanel(
selectInput("var", label = "1. Select the quantitative Variable",
choices = c("Apple" = 1, "Gold" = 2, "S&P" = 3, "BTC"=4),
selected = 3),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=50, value=15),
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red",
"Yellow"), selected = "Green")
),
# Main Panel
mainPanel(
textOutput("text1"),
textOutput("text2"),
textOutput("text3"),
plotOutput("myhist")
)
)
)
However after running 'Run App' i see error :
Error in normalizeChoicesArgs: Please specify a non-empty vector for `choices` (or, alternatively, for both `choiceNames` AND `choiceValues`).
81: stop
80: normalizeChoicesArgs
79: radioButtons
Have I done something wrong ?
Perhaps you are looking for a solution like this
library(shiny)
library(quantmod)
start <- as.Date("2013-01-01")
end <- as.Date("2016-10-01")
#Apple stock
getSymbols("AAPL", src = "yahoo", from = start, to = end)
apple <- AAPL$AAPL.Close
#Gold
getSymbols('GOLD', src = 'yahoo', from = start, to = end)
gold <- GOLD$GOLD.Close
#S&P500
getSymbols('^GSPC', src = 'yahoo', from = start, to = end)
sp <- as.numeric(`GSPC`[,4])
#Microsoft
getSymbols('MSFT', src = 'yahoo', from = start, to = end)
msft <- MSFT$MSFT.Close
stock.frame <- data.frame(apple, gold, msft, sp)
colnames(stock.frame) <- c('apple', 'gold', 'msft', 'sp')
cmat <- cor(stock.frame)
### plot_ly(z = cmat, type = "heatmap")
### Define UI for application
ui <- fluidPage(
# Header or title Panel
titlePanel(h4('Demostration of the renderPlot() - A Histogram with stock dataset', align = "center")),
# Sidebar panel
sidebarPanel(
selectInput("var", label = "1. Select the quantitative Variable",
choices = c("Apple" = 1, "Gold" = 2, "S&P" = 3, "BTC"=4),
selected = 3),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=50, value=15),
radioButtons("graphtype", label = "Select Type of Graph",
choices = c("Heatmap", "Histogram", "DataTable"), selected = "Heatmap"),
conditionalPanel(
condition = "input.graphtype == 'Histogram' ",
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red", "Yellow"), selected = "Green")
)
),
# Main Panel
mainPanel(
textOutput("text1"),
textOutput("text2"),
textOutput("text3"),
conditionalPanel(
condition = "input.graphtype == 'Heatmap' ", plotlyOutput("heatmap", width = "100%", height="600px")
),
conditionalPanel(
condition = "input.graphtype == 'Histogram' ", plotOutput("myhist")
),
conditionalPanel(
condition = "input.graphtype == 'DataTable' ", DTOutput("tb1")
)
)
)
server <- function(input, output) {
output$myhist <- renderPlot({
colm <- as.numeric(input$var)
hist(stock.frame[, colm], col = input$colour, xlim = c(min(stock.frame[, colm]), max(stock.frame[, colm])), main = "Histogram of stock dataset", breaks = seq(min(stock.frame[, colm]), max(stock.frame[, colm]), l = input$bin + 1), xlab = names(stock.frame[colm]))
})
output$heatmap <- renderPlotly({plot_ly(x = colnames(stock.frame), y = colnames(stock.frame), z = cmat, type = "heatmap") %>%
layout(
xaxis = list(title=colnames(stock.frame)),
yaxis = list(title="ts")
)
})
output$tb1 <- renderDT(stock.frame)
}
# Run the application
shinyApp(ui = ui, server = server)
I'm new to R and shiny. I have a problem that I could not solve.
I have a histogram where I want to make the classes separately selectable.
The classes are all in one column. To make them separately selectable, I did not succeed.
How do I get it to work?
Thanks a lot
## app.R ##
set.seed(24)
df <- data.frame(Class = sample(LETTERS[1:5], 30, replace = TRUE),
Amount = sample(5:20, 30, replace = TRUE),
stringsAsFactors= FALSE, check.names = FALSE)
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
})
output$sum = renderPrint({
summary(df)
})
output$str = renderPrint({
str(df)
})
output$data = renderTable({
colm = as.numeric(input$var)
df[colm]
head(df)
})
output$myhist <- renderPlot({
colm = as.numeric(input$var)
hist(df$Amount, col =input$colour, xlim = c(0, max(df$Amount)), main = "Histogram", breaks = seq(0, max(df$Amount),l=input$bin+1),
xlab = names(df$Amount)
)}
)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("var", label = "1. Select Class",
choices = c("A" = 1, "B" = 2, "C" = 3, "D"= 4, "E" = 5),
selected = 2),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=25, value=15),
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red",
"Blue"), selected = "Green")
),
mainPanel(
tabsetPanel(type="tab",
tabPanel("Plot", plotOutput("myhist")),
tabPanel("Summary", verbatimTextOutput("sum")),
tabPanel("Structure", verbatimTextOutput("str")),
tabPanel("Data", tableOutput("data"))
)
)
)
)
shinyApp(ui = ui, server = server)
I appreciate your help.
You have a few options:
Allow the selectInput to have multiple selections, by adding multiple = TRUE:
selectInput("var", label = "1. Select Class", choices = c("A" = 1, "B" = 2, "C" = 3, "D"= 4, "E" = 5), multiple = TRUE)
Use a checkbox group:
checkboxGroupInput('var', label = "1. Select Class", choices = c("A" = 1, "B" = 2, "C" = 3, "D"= 4, "E" = 5))
I recommend the 2nd option, using a checkbox group, as I believe they are easy for users to understand.
EDIT
As requested here is the full code, with the checkbox group linked to the chart:
## app.R ##
library(shiny)
set.seed(24)
df <- data.frame(Class = sample(LETTERS[1:5], 30, replace = TRUE),
Amount = sample(5:20, 30, replace = TRUE),
stringsAsFactors= FALSE, check.names = FALSE)
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
})
output$sum = renderPrint({
summary(df)
})
output$str = renderPrint({
str(df)
})
output$data = renderTable({
colm = as.numeric(input$var)
df[colm]
head(df)
})
output$myhist <- renderPlot({
df_plot <- df[df$Class %in% input$var, ]
hist(df_plot$Amount, col = input$colour, xlim = c(0, max(df_plot$Amount)), main = "Histogram", breaks = seq(0, max(df_plot$Amount),l=input$bin+1),
xlab = names(df_plot$Amount)
)}
)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput('var', label = "1. Select Class", choices = c("A", "B", "C", "D", "E"), selected = "B"),
sliderInput("bin", "2. Select the number of histogram BINs by using the slider below", min=5, max=25, value=15),
radioButtons("colour", label = "3. Select the color of histogram",
choices = c("Green", "Red",
"Blue"), selected = "Green")
),
mainPanel(
tabsetPanel(type="tab",
tabPanel("Plot", plotOutput("myhist")),
tabPanel("Summary", verbatimTextOutput("sum")),
tabPanel("Structure", verbatimTextOutput("str")),
tabPanel("Data", tableOutput("data"))
)
)
)
)
shinyApp(ui = ui, server = server)
I have a table being display in a shiny app. I want to format the tables based on the values and color it accordingly. I have seen the formattable area coloring where based on the range of the values it defines the breaks and then color gradients are generated which are applied to the table. What I want to do is allow the user to fill the min and max value and depending on it the values in the table will be colored. So if the values range from 1-20 and if the user inputs are 5 and 15 , values below 5 and above 15 shouldnt have any color gradients applied to them. Below is the code of how I am doing currently using formatable area formatting.
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(DT)
sidebar <- dashboardSidebar(
sidebarMenu(id = "tab",
menuItem("1", tabName = "1")
)
)
body <- ## Body content
dashboardBody(box(width = 12,fluidRow(
fluidRow( column(
width = 3, textInput("text1", label = h5("Min"), value = "Enter min")),
column(
width = 3, textInput("text2", label = h5("Max"), value = "Enter max"))),
DT::dataTableOutput("op")
)))
ui <- dashboardPage(dashboardHeader(title = "Scorecard"),
sidebar,
body)
# Define the server code
server <- function(input, output,session) {
df <- data.frame(month = c("mazda 3", "mazda cx5", "mazda 6","mazda miata","honda civic","honda accord"),
april = c(.1,.2,.3,.3,.4,.5),
may = c(.3,.4,.5,.2,.1,.5),
june = c(.2,.1,.5,.1,.2,.3))
brks <- reactive({ quantile(df$april, probs = seq(.05, .95, .05), na.rm = TRUE)})
clrs <- reactive({ round(seq(255, 175, length.out = length(brks()) + 1), 0) %>%
{paste0("rgb(",.,",", ., ",255 )")}})
df_format<- reactive ({datatable(df,options = list(searching = FALSE,pageLength = 15, lengthChange = FALSE))%>%
formatStyle(names(df),backgroundColor = styleInterval(brks(), clrs()))})
output$op <-renderDataTable({
df_format()
})
}
shinyApp(ui = ui, server = server)
Here is your working code.
You must use that input minimal and maximal value as limits for your sequence (I just change it to range - is easier for user to put a range like that)
Then you generate sequence - according your notation - brks() - in my case I use length.out of 10 but you can put as many breaks as you want or dynamically.
Then generate on
number of colors - 1
and in the end in styleInterval() for background add limits of white - or any other color you want.
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(DT)
sidebar <- dashboardSidebar(
sidebarMenu(id = "tab",
menuItem("1", tabName = "1")
)
)
body <- ## Body content
dashboardBody(box(width = 12,fluidRow(
fluidRow(column(
width = 3,
sliderInput("range_value",
label = h3("Put a range value"),
min = 0,
max = 100,
value = c(5, 15)
)
)
),
DT::dataTableOutput("op")
)))
ui <- dashboardPage(dashboardHeader(title = "Scorecard"),
sidebar,
body)
# Define the server code
server <- function(input, output,session) {
df <- data.frame(month = c("mazda 3", "mazda cx5", "mazda 6","mazda miata","honda
civic","honda accord"),
april = c(9, 8, 11,14,16,1),
may = c(3,4,15,12,11, 19),
june = c(2,11,9,7,14,1))
brks <- reactive({
seq(input$range_value[1], input$range_value[2], length.out = 10)
})
clrs <- reactive({ round(seq(255, 175, length.out = length(brks()) - 1), 0) %>%
{paste0("rgb(",.,",", ., ",255)")}})
df_format<- reactive ({datatable(df,options = list(searching = FALSE, pageLength = 15, lengthChange = FALSE)) %>%
formatStyle(names(df),
backgroundColor = styleInterval(c(brks()), c('white', clrs() ,'white'))
)
})
output$op <-renderDataTable({
df_format()
})
}
shinyApp(ui = ui, server = server)
I am building a shiny app. In the drop down menu I have the categories of a factor variable. I think the problem is in the server but I dont know how to fix it.
Also, I would like that to add a vertical in the histograms at 15 when the colour chosen is yellow, and a vertical line at 20 when the colour chose in the histogram is Red. Can you please help me with my code?
Thanks
library(shiny)
# Creating a fake data frame
categories <- c("A", "B", "c")
values <- c(12, 15, 20)
data <- merge(categories, values)
# Define UI for application
ui <- shinyUI(fluidPage(
# Title panel
titlePanel(title = h1("Title", align = "center")),
sidebarLayout(
# Sidebar panel
sidebarPanel(
# Options
selectInput(inputId = "xcol", label = "Select", choices = levels(data$x)),
br(),
#Colours histogram
radioButtons(inputId = "colour", label = strong("Select the colour of
histogram"), choices = c("Yellow", "Red"), selected = "Yellow"),
br(),
#Bins for histogram
sliderInput(inputId = "bins", label = "Select the number of Bins for the
histogram", min=5, max = 25, value = 15),
br(),
#Density curve
checkboxInput(inputId = "density", label = strong("Show Density Curve"),
value = FALSE),
# Display this only if the density is shown
conditionalPanel(condition = "input.density ==true",
sliderInput(inputId = "bw_adjust",
label = "Bandwidth adjustment:",
min = 0.2, max = 3, value = 1, step = 0.2))
),
# Main Panel
mainPanel(
#plot histogram
plotOutput("plot"),
# Output: Verbatim text for data summary
verbatimTextOutput("summary"))
)))
# Define server logic
server <- shinyServer(function(input, output) {
output$plot <-renderPlot({
hist(data[input$xcol, data$x], breaks = seq(0, max(data[input$xcol,
data$x]), l= input$bins+1), col = "lightblue",
probability = TRUE, xlab = "Values", main = "")
abline(v = mean(data[input$xcol, data$x]), col = "red", lty = 2)
title(main = levels(data$x[input$xcol]))
if (input$density) {
dens <- density(data[input$xcol, data$x], adjust = input$bw_adjust)
lines(dens, col = "blue", lwd = 1)
}
# Generate the summary
output$summary <- renderPrint({
xcol <- xcolInput()
summary(xcol)
})
})
})
# Run the application
shinyApp(ui = ui, server = server)
It looks like you were subsetting data incorrectly. I created a reactive expression for the data subset: data2(), and used that to make the plot outputs. I also added the vertical lines you mention with an if(){...}else{...} statement.
library(shiny)
# Creating a fake data frame
categories <- c("A", "B", "c")
values <- c(12, 15, 20)
data <- merge(categories, values)
# Define UI for application
ui <- shinyUI(fluidPage(
# Title panel
titlePanel(title = h1("Title", align = "center")),
sidebarLayout(
# Sidebar panel
sidebarPanel(
# Options
selectInput(inputId = "xcol", label = "Select", choices = levels(data$x)),
br(),
#Colours histogram
radioButtons(inputId = "colour", label = strong("Select the colour of
histogram"), choices = c("Yellow", "Red"), selected = "Yellow"),
br(),
#Bins for histogram
sliderInput(inputId = "bins", label = "Select the number of Bins for the
histogram", min=5, max = 25, value = 15),
br(),
#Density curve
checkboxInput(inputId = "density", label = strong("Show Density Curve"),
value = FALSE),
# Display this only if the density is shown
conditionalPanel(condition = "input.density ==true",
sliderInput(inputId = "bw_adjust",
label = "Bandwidth adjustment:",
min = 0.2, max = 3, value = 1, step = 0.2))
),
# Main Panel
mainPanel(
#plot histogram
plotOutput("plot"),
# Output: Verbatim text for data summary
verbatimTextOutput("summary"))
)))
# Define server logic
server <- shinyServer(function(input, output) {
data2 <- reactive({data[as.character(data$x)==input$xcol, "y"]})
output$plot <-renderPlot({
hist(data2(), breaks = seq(0, max(c(1, data2()), na.rm=TRUE), l= input$bins+1), col = input$colour,
probability = TRUE, xlab = "Values", main = "")
abline(v = mean(data2()), col = "red", lty = 2)
title(main = input$xcol)
if (input$density) {
dens <- density(data2(), adjust = input$bw_adjust)
lines(dens, col = "blue", lwd = 1)
}
if(input$colour=="Red"){
abline(v=20)}else{abline(v=15)}
# Generate the summary
output$summary <- renderPrint({
#xcol <- xcolInput()
summary(data2())
})
})
})
# Run the application
shinyApp(ui = ui, server = server)