display of text in a new line below the uioutput display [Shiny] - html

uiOutput('myTable') followed by p("Here is some text....") puts the text next to uioutput display, but I like to print the text in a new line starting from left side of the page. Adding br() is simply adding empty space equivalent to screen width, therefore, text starts from a new line but not from from the left side of the page. Interestingly, adding any control widget, e.g., dateInput displays the widget in a new line. In my case, uioutput input comes from map [ package purrr]. I combined map output and HTML("<br>") via list, but no solution. Here is reproducible code:
library(shiny)
ui <- fluidPage(
tabPanel("Test",
numericInput("samsize","specify sample size",4,1,52),
uiOutput('myTable'),
#dateInput("date", label = "Today's Date")
#br(""),
p("Here is some text...")
))
server <- function(input, output) {
data <- reactive({
alphabets <- c(letters,LETTERS)
Index <- seq(1,length(alphabets),1)
names(Index) <- alphabets
# Notice I don't put the vector in a one row matrix as in you example
sample(Index,input$samsize)
})
library(purrr) # map is a nice alternative to lapply
output$myTable <- renderUI(map(names(data()),~div(strong(.),
div(data()[.]),
style="float:left;padding:10px 20px;")))
}
shinyApp(ui, server)
Here is screen shot. As it is seen, Here is some text is next to uioutput display, which I want to be in a new line below the display

After using div with style float:left, you need to clear the floating, for example with clear:left:
ui <- fluidPage(
tabPanel("Test",
numericInput("samsize","specify sample size",4,1,52),
uiOutput('myTable'),
div("Here is some text...", style="clear:left;"),
dateInput("date", label = "Today's Date")
))
You will find more info about floating div here

Related

Is it possible to have fixed width verbatimTextOutput and have texts change lines in Shiny?

I have a simple app that uses verbatimTextOutput to display some texts. I am wondering if it is possible to have the width of verbatimTextOutput to be fixed and have the text output change lines?
Please see this example (https://yuchenw.shinyapps.io/verbatimtext_bookmark/). I also attached the code below.
As the attached screenshot shows, when the string is very long, the verbatimTextOutput would not show all the text. Instead, the verbatimTextOutput would show a scroll bar at the bottom.
However, I hope there will be no scroll bar at the bottom of the verbatimTextOutput. I also need that when the texts are long, change lines to fit in the verbatimTextOutput. Taking the following as an example, which is by clicking the bookmark button. We can see that this lengthy URL change lines, and there is no scroll bar at the bottom of the output. If the bookmark button can do that, I hope I can also make the verbatimTextOutput show similar characteristics and appearance of the bookmark.
Please let me know if you have any questions.
Code
library(shiny)
ui <- function(request){
fluidPage(
column(
width = 6,
textInput(inputId = "txt", label = "Type in some texts",
value = paste0(rep(letters, 10), collapse = "")),
strong("Show the texts"),
verbatimTextOutput("txt_out"),
br(),
bookmarkButton()
)
)
}
server <- function(input, output, session){
output$txt_out <- renderText({
input$txt
})
}
enableBookmarking("url")
shinyApp(ui, server)
Please try the following css:
library(shiny)
ui <- function(request){
fluidPage(
tags$style(type='text/css', '#txt_out {white-space: pre-wrap;}'),
column(
width = 6,
textInput(inputId = "txt", label = "Type in some texts",
value = paste0(rep(letters, 10), collapse = "")),
strong("Show the texts"),
verbatimTextOutput("txt_out"),
br(),
bookmarkButton()
)
)
}
server <- function(input, output, session){
output$txt_out <- renderText({
input$txt
})
}
enableBookmarking("url")
shinyApp(ui, server)

Shiny renderText: half italicized, half not?

In my shiny app, I have a textOutput named acronym where I would like to renderText some text which is half non-italicized, half-italicized.
I tried doing it like this:
output$acronym_1 <- renderText(paste("SID SIDE:", tags$em("Siderastrea siderea")))
But this did not get the second half in italics. How do I do this?
Thanks in advance.
The following code will produce italicized text
library(shiny)
ui = fluidPage(uiOutput("htmlText"))
server <- function(input, output)
output$htmlText <- renderUI(HTML(paste(
"Non-italic text.", em("Italic text")
)))
shinyApp(ui, server)
I don't think textOutput is capable of text markup since the output string will be created by cat according to the documentation.
renderText(expr, env = parent.frame(), quoted = FALSE,
outputArgs = list())
expr An expression that returns an R object that can be used as an argument to cat.

visNetwork not displaying in panel div

I have started to use shinyLP to make html elements and also make network diagrams using visNetwork. I noticed that visNetwork displays fine when placed in either a well panel or no panel at all. However, it does not display when placed in a panel div, either with shinyLP or through raw HTML. Just to be brief, I am only showing the code differences between not being in a panel and being in a panel div. Does anyone know of a way to make visNetwork appear in this specific container type? I want to use this container type because I want to keep my CSS the way it is and not change things just for this one container. Anyone know the cause of this issue?
This works when visNetworkOutput is not in a panel
library(shinyLP)
library(visNetwork)
ui <- fluidPage(
visNetworkOutput("network")
)
server <- function(input, output) {
output$network <- renderVisNetwork({
# minimal example
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes, edges)
})
}
shinyApp(ui, server)
This fails to display when visNetworkOutput is in a panel
ui <- fluidPage(
panel_div("default", "", visNetworkOutput("network"))
)
server <- function(input, output) {
output$network <- renderVisNetwork({
# minimal example
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes, edges)
})
}
shinyApp(ui, server)
It is a bug in shinyJS version 1.1.0. I found a (awkward) workaround and posted it as a bug in htmlwidgets and Joe Cheng saw it and give me a fix it in like 10 minutes. Awesome...
Here is the code with a better workaround (a new definition of pandel_div):
library(shiny)
library(shinyLP)
library(visNetwork)
# override the currently broken definition in shinyLP version 1.1.0
panel_div <- function(class_type, panel_title, content) {
div(class = sprintf("panel panel-%s", class_type),
div(class = "panel-heading",
h3(class = "panel-title", panel_title)
),
div(class = "panel-body", content)
)
}
ui <- fluidPage(
panel_div("default", "panel1",visNetworkOutput("network") )
)
server <- function(input, output) {
output$network <- renderVisNetwork({
# minimal network
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes,edges)
})
}
shinyApp(ui, server)
And this is what that looks like:
update: Tried with another htmlwidget package (sigma) and got the same behavior. So filing this as an htmlwidget bug: panel_div htmlwidget issue
update: JC identified it as a shinyJS bug. Changed my solution above to reflect his suggestion.

Displaying a vector of values wrapping at screen width [Shiny]

I have a vector of values and each value is associated with a name; length of vector changes as per the user input. Although I used table related commands, I like to know other ways to display this kind of data, which is essentially a vector (a single row) of values with names). The problem shows up when selected sample size produces the output that is greater than screen width. Scrolling horizontally allows flexibility to glance over the data, but I am looking for a solution that wraps up the data at the screen width and prints in multiple rows without the need to scroll. Here is the code to play:
ui <- fluidPage(
tabPanel("Test",
numericInput("samsize","specify sample size",4,1,52),
tableOutput('table')
))
server <- function(input, output) {
data <- reactive({
# create a vector of lower- and upper- case alphabets
# create a vector assigning numbers to alphabets
alphabets <- c(letters,LETTERS)
Index <- seq(1,length(alphabets),1)
names(Index) <- alphabets
# sample values
SampleIndex <- sample(Index,input$samsize)
# convert it into a matrix
data <- matrix(SampleIndex,nrow=1)
colnames(data)=names(SampleIndex)
data
})
output$table <- renderTable(data(),digits = 0)
}
shinyApp(ui, server)
As you see in the below picture, for a sample size '36' one need to scroll the page horizontally to see all the values. width in renderTable did not offer any solution Converting data into a html object/text might be one option, but not sure how to retain the names.
You can use renderUI together with uiOutput to create yourself the HTML object you want to display for example using div:
library(shiny)
ui <- fluidPage(
tabPanel("Test",
numericInput("samsize","specify sample size",4,1,52),
uiOutput('myTable')
))
server <- function(input, output) {
data <- reactive({
alphabets <- c(letters,LETTERS)
Index <- seq(1,length(alphabets),1)
names(Index) <- alphabets
# Notice I don't put the vector in a one row matrix as in you example
sample(Index,input$samsize)
})
library(purrr) # map is a nice alternative to lapply
output$myTable <- renderUI(map(names(data()),~div(strong(.),
div(data()[.]),
style="float:left;padding:10px 20px;")))
}
shinyApp(ui, server)

Removing multiple elements with removeUI / wrapping multiple elements with tags$div() assigning an id for each variable

I was suggested using insertUI here and found that it is a great feature. The following code allows to generate control widgets for a single or multiple elements using insertUI, but struck on incorporating removeUI related part. Tried jQuery options to remove inserted UI elements but did not work out. I found the following from Shiny dynamic UI, i.e., Note that, if you are inserting multiple elements in one call, you must wrap them in either a tagList() or a tags$div() (the latter option has the advantage that you can give it an id to make it easier to reference or remove it later on). Also, comments here gave some clues, i.e., tags$div(id="sepal.width.div", sliderInput("sepal.width.slider", ...)), but my lack of HTML/CSS knowledge stops me going forward. I'm looking at (a) wrapping multiple widget element(s) with tags$div() assigning a unique id for each variable, which will be used in removeUI; (b) calling multiple elements via removeUI.
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
ListofSelVars <<- vector(mode="character")
# control widgets for all elements
allControls <- lapply(setNames(varnames, varnames), function(x) {
sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2)
})
ui <- navbarPage(
tabPanel("Plot",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
# add an action button
actionButton("add", "Update UI elements")
),
mainPanel()
)
)
)
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector ='#add',
where = "afterEnd",
ui = allControls[setdiff(input$ConditioningVariables,ListofSelVars)]
)
## removeUI related goes, here
## removeUI(selector=paste0())
## setdiff(ListofSelVars,input$ConditioningVariables) gives elements to be removed
## Global variable, keep track of elements that are selected
ListofSelVars <<- input$ConditioningVariables
})
}
shinyApp(ui, server)
Here is the working code. The main issue is with the names here, i.e. Sepal.Width. I wrapped each slider with a div with id like div.Sepal.Width so that it is easier to remove. removeUI requires a jQuery selector, so it appears that something like #div.Sepal.Width would work, except that it does not, because . is itself a jQuery selector that means class, so we need to double escape the .. Of course you can also remove the . when you first create the divs, thus avoiding the trouble...
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
ListofSelVars <<- vector(mode="character")
# control widgets for all elements
allControls <- lapply(setNames(varnames, varnames), function(x) {
tags$div(id=paste0("div.",x), sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2))
})
ui <- fluidPage(
titlePanel("Dynamic sliders"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
# add an action button
actionButton("add", "Update UI elements")
),
mainPanel(
uiOutput("plot_out")
)
)
)
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector ='#add',
where = "afterEnd",
ui = allControls[setdiff(input$ConditioningVariables,ListofSelVars)]
)
ListofRemoval <- setdiff(ListofSelVars,input$ConditioningVariables)
for (item in ListofRemoval) {
item = gsub(".", "\\.", item, fixed=TRUE)
item = paste0("#div\\.", item)
removeUI(item)
}
ListofSelVars <<- input$ConditioningVariables
})
}
shinyApp(ui, server)