[Previous question]How to include an action link into a button's label?
How I can align "get help" on the right of sidbarPanel?
library(shiny)
ui <- fluidPage(
br(),
selectInput(
inputId = "some_id",
label = HTML("Please choose A or B",
as.character(actionLink(inputId = 'action_link', label = 'get help'))),
choices = c("choice A", "choice B"),
selected = "choice A",
selectize = F
)
)
server <- function(input, output) {}
shinyApp(ui, server)
as far as I understand from the problem is you want a helper icon or link on the side of you select input.
you can use shinyhelper library for that.For Detailed Documentation yo can refer to here
I tried a sample for using this: hope this help
library(shiny)
library(shinyhelper)
library(magrittr)
ui <- fluidPage(
titlePanel(title = "Demo APP"),
sidebarLayout(
sidebarPanel = sidebarPanel(
selectInput(inputId = "dataset", "choose DataSet",
choices = c("MTCARS","IRSIS")
) %>%
helper(type = "inline",
title = "Inline Help",
content = c("This helpfile is defined entirely in the UI!",
"This is on a new line.",
"This is some <b>HTML</b>."),
size = "s")
),
mainPanel = mainPanel(
verbatimTextOutput(outputId = "TABLE")
)
)
)
server <- function(input, output) {
observe_helpers()
output$TABLE<-renderText({
paste0("Dataset selcted: ",input$dataset)
})
}
shinyApp(ui, server)
Output Looks like:
after clicking the icon:
Related
I have an app set up as this is. As the user selects multiple items from the Animals dropdown, the printout of what they have selected gets longer and pushes the elements under it down
I would like for the elements under it to be justified to the bottom of the page so that they don't move as more animals are selected
library(tidyverse)
library(ggplot2)
library(dplyr)
library(shiny)
# Define UI for app
ui <-
fillPage(
column(2,
fluidRow(
# Input 1: animal
selectInput(
inputId = 'FilterFieldSelection',
label = 'Animal Of Choice',
choices = c('Dog','Cat','Inu','Neko','Giraffe','Kirin','Mouse','Nezumi'),
selected = 'Dog',
multiple = TRUE
),
# Output 1: Active Filters
htmlOutput('ActiveFiltersText')
),
fluidRow(
h4("Counts"),
# Input 2: color
selectInput(
inputId = 'ColorChoice',
label = 'Color Of Choice',
choices = c('red','blue','green'),
selected = 'red'
),
# Output 2: Filtered Well Count
htmlOutput('WellCountFilteredText'),
)
),
column(10,
plotOutput('myplot')
)
)
# Define Server
server <- function(input, output, session) {
# Text Outputs ----
## Text Output Of Active Filters ----
output$ActiveFiltersText <- renderUI({
full_text <- ""
full_text <- paste0(full_text, '<b>','There Is A','</b>:<br/>',
paste(input$FilterFieldSelection,collapse="<br/>"),'<br/>'
)
full_text <- HTML(full_text)
})
## Text Output Of Filtered Well Count ----
output$WellCountFilteredText <- renderUI({
HTML(paste0('<b>','Filtered','</b>:<br/>',150000))
})
## Plot
output$myplot <- renderPlot({
m <- matrix(rnorm(50), ncol = 5)
colnames(m) <- c("a", "b", "c", "d", "e")
as_tibble(m) %>%
ggplot(aes(x=a, y=b) ) +
geom_point(color=input$ColorChoice)
})
}
# Run App
shinyApp(ui = ui, server = server)
I have tried putting the elements to not move in another fluidRow, but that didn't change anything. They're still fully top-justified
You can put the elements in a div with CSS style properties position: fixed; bottom: 0;.
ui <- fluidPage(
fluidRow(
column(
2,
selectInput(
inputId = 'FilterFieldSelection',
label = 'Animal Of Choice',
choices = c('Dog','Cat','Inu','Neko','Giraffe','Kirin','Mouse','Nezumi'),
selected = 'Dog',
multiple = TRUE
),
tags$div(
style = "position: fixed; bottom: 0;",
# Output 1: Active Filters
htmlOutput('ActiveFiltersText'),
tags$hr(),
h4("Counts"),
# Input 2: color
selectInput(
inputId = 'ColorChoice',
label = 'Color Of Choice',
choices = c('red','blue','green'),
selected = 'red'
),
# Output 2: Filtered Well Count
htmlOutput('WellCountFilteredText'),
)
),
column(
10,
plotOutput("myplot")
)
)
)
As shown in the below image, I'm trying to place a line of text in front of an info icon rendered using the popify() function in the shinyBS package. The code at the bottom works for the situation where there is no text in front of info icon and commented-out is one of my attempts to insert the text. Uncomment, run the code, and you'll see garbled output.
So how would one insert text in front of the icon? One option is to split the text and icon into 2 separate columns, but I don't want to fiddle with the column widths to make it look right. I want the text to "flow into" the icon.
I thought this Stack Overflow question might provide an answer but it is a dead end: How to place both text and image output in one html div (rshiny)
Code:
library(shiny)
library(shinyBS)
app = shinyApp(
ui =
fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("bins","Number of bins:",min = 1,max = 50,value = 30)
),
mainPanel(
plotOutput("distPlot"),
uiOutput("uiExample")
)
)
),
server =
function(input, output, session) {
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')
})
output$uiExample <- renderUI({
# paste( #uncomment
# "Look at the little circle >>", #uncomment
tags$span(
popify(icon("info-circle", verify_fa = FALSE),
"Placeholder",
"This icon is <b>placeholder</b>. It will be fixed</em>!")
)
# ) #uncomment
})
}
)
runApp(app)
This could be achieved via a tagList and another span:
library(shiny)
library(shinyBS)
app = shinyApp(
ui =
fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("bins","Number of bins:",min = 1,max = 50,value = 30)
),
mainPanel(
plotOutput("distPlot"),
uiOutput("uiExample")
)
)
),
server =
function(input, output, session) {
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')
})
output$uiExample <- renderUI({
tagList(
tags$span(
"Look at the little circle >>"
),
tags$span(
popify(icon("info-circle", verify_fa = FALSE),
"Placeholder",
"This icon is <b>placeholder</b>. It will be fixed</em>!")
)
)
})
}
)
runApp(app)
I'm trying to update a radiobutton list on the server side with HTML code but I'm not succeeding.
I'm using this example for you to understand what I'm trying to do. I refer again that has to be on the server side because the elements on my list will be related to other inputs made by the user.
Can someone help to figure out how it can be made?
thanks
## Only run examples in interactive R sessions
if (interactive()) {
ui <- fluidPage(
radioButtons("rb", "Choose one:",
choiceNames = list("icon", "html", "text"),
choiceValues = c(1,2,3)),
textOutput("txt")
)
server <- function(input, output,session) {
a<-HTML("<p style='color:red;'>option2</p>")
list1=as.list(c("option1",a,"option3"))
updateRadioButtons(session, "rb", choiceNames = list1, choiceValues = c(1,2,3))
output$txt <- renderText({
paste("You chose", input$rb)
})
}
shinyApp(ui, server)
}
There are some problems in your code:
choiceValues must be an atomic vector, not a list
ui <- fluidPage(
radioButtons("rb", "Choose one:",
choiceNames = list("icon", "html", "text"),
choiceValues = c(1,2,3)),
textOutput("txt")
)
if you use updateXXX you have to set the argument session to the server function:
server <- function(input, output, session) {
in updateRadioButtons you have to set both choiceNames and choiceValues:
if(TRUE){
list=list(icon("calendar"),
HTML("<p style='color:red;'>Red Text</p>"),
"Normal text"
)
updateRadioButtons(session, "rb", choiceNames = list, choiceValues = c(1,2,3))
}
And the icon does not work.
I am attempting to code a Shiny application that hits a JSON API as its main data source. The app would hit the API once per minute to retrieve updated data in JSON format, then use jsonlite package to parse it into a data frame for use in the Shiny app. My goal is to create valueBox and chart outputs and have those update each minute as the data count goes up and changes, to create a "stream-like" dashboard.
I've attempted to use these two examples to code this out, but my app does not seem to be able to access my data source when it's loaded.
Twitter Sentiment Analysis
Shiny CRANDash
Here's some sample code. Right now, I am just using a dummy test JSON source and appending the current time to see that the 60 second update is working.
helper_functions.R:
library(jsonlite)
getDataSet <- function() {
URL = "http://jsonplaceholder.typicode.com/posts"
results <- fromJSON(URL)
results_df <- data.frame(results)
results_df$RowCreated <- Sys.time()
#I have also added this call to return (results_df) to no avail, so it is commented out
#return(results_df)
}
server.R
source('helper_functions.R')
shinyServer(function(input, output, session) {
autoInvalidate = reactiveTimer(6000,session)
get_input = reactive({
autoInvalidate()
#show progress bar
withProgress(session, {
setProgress(message = 'Collecting API data...')
getDataSet()
})
})
output$currentTime <- renderText({
invalidateLater(1000,session)
format(Sys.time())
})
#attempting to just write the data frame to a table to see it
output$SampleDataFrame <- renderDataTable(
getDataSet
)
#simply output the first row's RowCreated as a text field
output$RowCreated <- renderText(
getDataSet[1,]$RowCreated
)
})
ui.R
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Tab 1", tabName = "Tab 1", icon = icon("check-circle"), badgeLabel = "testing", badgeColor = "red"),
menuItem("Tab 2", tabName = "Tab 2", icon = icon("database"), badgeLabel = "testing", badgeColor = "blue"),
menuItem("Tab 3", tabName = "Tab 3", icon = icon("database"), badgeLabel = "testing", badgeColor = "blue")
)
)
body <- dashboardBody(
fluidRow(
tags$code(
"Data Last Updated from API: ", textOutput("currentTime", container = span)
),
h2("Example Header"),
fluidRow(
textOutput("RowCreated")
)
)
)
dashboardPage(
skin="black",
dashboardHeader(title = "Sample"),
sidebar,
body
)
The dashboard renders, but in the section that outputs "RowCreated" this is the message:
error: object of type 'closure' is not subsettable
I'd expect this to update every 6 seconds, per the invalidate call.
Any help is appreciated. Thanks!
Corrected code which works.
helper_functions.R:
library(jsonlite)
getDataSet <- function() {
URL = "http://jsonplaceholder.typicode.com/posts"
results <- fromJSON(URL)
results_df <- data.frame(results)
results_df$RowCreated <- Sys.time()
return(results_df)
}
server.R
source('helper_functions.R')
shinyServer(function(input, output, session) {
autoInvalidate = reactiveTimer(6000,session)
get_input = reactive({
autoInvalidate()
#show progress bar
withProgress(session, {
setProgress(message = 'Collecting API data...')
getDataSet()
})
})
output$currentTime <- renderText({
invalidateLater(1000,session)
format(Sys.time())
})
output$SampleDataFrame <- renderDataTable(
getDataSet()
)
#simply output the first row's RowCreated as a text field
#minor tweak to format date correctly
output$RowCreated <- renderText(
format(getDataSet()[1,]$RowCreated[1])
)
})
ui.R
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Tab 1", tabName = "Tab 1", icon = icon("check-circle"), badgeLabel = "testing", badgeColor = "red"),
menuItem("Tab 2", tabName = "Tab 2", icon = icon("database"), badgeLabel = "testing", badgeColor = "blue"),
menuItem("Tab 3", tabName = "Tab 3", icon = icon("database"), badgeLabel = "testing", badgeColor = "blue")
)
)
body <- dashboardBody(
fluidRow(
tags$code(
"Data Last Updated from API: ", textOutput("currentTime", container = span)
),
h2("Example Header"),
fluidRow(
textOutput("RowCreated")
)
)
)
dashboardPage(
skin="black",
dashboardHeader(title = "Sample"),
sidebar,
body
)
I know I am way late to this party, but I don't think your solution should work...
you have:
output$currentTime <- renderText({
then in your second renderText you have:
output$RowCreated <- renderText(
notice the none existent { in the second one?
Just trying to replicate the code, but found that in my attempt
Reproducible example:
require(shiny)
runApp(list(ui = pageWithSidebar(
headerPanel("Example"),
sidebarPanel(
sliderInput("index",
label = "Select a number",
min = 1,
max = 4,
step = 1,
value = 2)),
mainPanel(
htmlOutput("text")
)),
server = function(input, output) {
output$text <- renderUI({
HTML(paste(c("banana","raccoon","duck","grapefruit")))
})
}
))
I would like to have the word corresponding to index ("raccoon" in the default) displayed in bold and the other words in normal font.
If I do:
HTML(
<b>paste(c("banana","raccoon","duck","grapefruit")[input$index])<\b>,
paste(c("banana","raccoon","duck","grapefruit")[setdiff(1:4,input$index)])
)
I receive an error (< is not recognized)...
One more try, is this helpful?
require(shiny)
fruits <- c("banana","raccoon","duck","grapefruit")
runApp(list(ui = pageWithSidebar(
headerPanel("Example"),
sidebarPanel(
sliderInput("index",
label = "Select a number",
min = 1,
max = 4,
step = 1,
value = 2)),
mainPanel(
htmlOutput("text")
)),
server = function(input, output) {
output$text <- renderUI({
fruits[input$index] <- paste("<b>",fruits[input$index],"</b>")
HTML(paste(fruits))
})
}
))
This might help you:
shinyApp(
ui <- basicPage(
uiOutput(outputId = "text")
),
server <- function(input,output){
output$text <- renderText({
HTML(paste0("<b>","bold","</b>", " not bold"))
})
})
Is that what you were looking for?
If you're not set on using the HTML function, I believe you should be able to use strong(paste(character_vector[index])) instead.
Just use renderPrint instead of renderText
renderPrint({
HTML(paste0("El valor 1 es:", input$val1,"\n","el valor 2 es:",input$val2))
})