I have a shiny app with list of wellPanels. They are used in jqui_sortable from shinyjqui. Panels are generated in server part (to uiOutput in ui). Order of panels can be changed by mouse and is written to file (by ids). Then I would like to open this file and change default order with loaded data.
Issue: I can't get out of rendered words "div" between panels (run code below).
Code was written with some lines from solution (thanks to #TimTeaFan):
Distorted spacing between div elements after sorting with jqui_sortable
library(shiny)
library(shinyjqui)
ui <- fluidPage(
sidebarLayout(fluid = TRUE,
sidebarPanel(helpText("HelpText")),
mainPanel(
fluidRow(column(12,
actionButton(inputId = "btn1",label = "Button1"),
tags$style(HTML(".ui-sortable {
width: 1200px !important;
} ")),
uiOutput('multiobject'),
actionButton(inputId = "btn2",label = "Button2")
))
)
)
)
server <- function(input, output, session) {
sortableorderednameList<-reactiveVal(
c("A","B","C")
)
wpFunc <- function(v,name,helptext){
return(tags$div(wellPanel(id=paste0(v,"P"),
div(style="display: inline-block; width: 10px;",
checkboxInput(paste0(v,"Chk"), label = NULL, value = TRUE)),
div(style="display: inline-block; width: 150px;",
textInput(paste0(v,"TI"), label = NULL, value = name)),
div(style="display: inline-block;",helpText(helptext)),
style = "padding: 1px;")))
}
observe({
if(is.null(input$sortablecollistJQ_order$id)) {return()}
mylist <- input$sortablecollistJQ_order$id
mylist <- unlist(lapply(mylist, function(v) substr(v,1,nchar(v)-1)))
print(mylist)
print(" ")
isolate(sortableorderednameList(mylist))
})
output$multiobject <- renderUI({
uiList <- list()
for (v in sortableorderednameList()) {
switch(v,
"A" = {uiList <- append(uiList,wpFunc(v,"A","There is A"))},
"B" = {uiList <- append(uiList,wpFunc(v,"B","There is B"))},
"C" = {uiList <- append(uiList,wpFunc(v,"C","There is C"))}
)
}
jqui_sortable(div(id = 'sortablecollistJQ',uiList))
})
}
shinyApp(ui, server)
I have got an answer after experiments. If somebody is interested.
for (i in 1:length(uiList)) {
uiList[i] <- uiList[i]$children
}
It changes structure of list, put it before jqui_sortable call.
Related
I use sortable in shiny to create a sortable list where the elements can be dragged and dropped in various positions. According to the documentation (also in the underlying javascript source) you can define handles where you can grab the items and reorder them (https://jsfiddle.net/14je5rmy/, the X in this fiddle).
I am unable to do the same thing in shiny though (even though the option exists)
library(shiny)
library(sortable)
labels <- list(
"one",
"two",
"three"
)
rank_list_basic <- rank_list(
labels = labels,
input_id = "rank_list_basic",
options = sortable_options(handle=".handle")
)
ui <- fluidPage(
tags$body(
tags$span(class="handle", "X"),
),
fluidRow(
rank_list_basic,
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
In this minimum example I created the span ("handle") that I would like to use as a handle for the items in the rank_list. Can someone point me in the right direction?
Here is the R way to create that jsFiddle:
library(shiny)
library(sortable)
labels <- lapply(c("one","two","three"), function(i) {
div(tags$span(class="handle", "X"), tags$span(i))
})
rank_list_basic <- rank_list(
labels = labels,
input_id = "rank_list_basic",
options = sortable_options(handle=".handle")
)
ui <- fluidPage(
tags$style('.handle {margin: 10px; color:red; background: cyan; border: 1px solid red; cursor: pointer}'),
fluidRow(
rank_list_basic
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
I'm trying to make check boxes for each car model in a grouping variable, 'cylinders'.
To achieve this, I'm using lapply() to go through the groups making a groupedCheckbox in a collapsing well panel, for each.
However only some of the checked car models are read. Initially all of the checked cars in the first cylinder group can be read but not those in the second two groups !
However once some of the car models in the first group are ticked, then cars in the second two groups are also read. Image of multiple checkbox groups with only checkboxes in first box are read
MultipleGroupCheckboxProblem
Does anyone know how all of the ticked cars can be extracted into a reactive vector?
I have a feeling the solution might involve proper use of lapply and/or unlist.
Also the car names originate from the row names of the input table.
Code here, using mtcars :
library(shiny)
library(shinyBS)
ui <- fixedPage(
h2("R Shiny: Multiple collapsing tickboxes"),
tags$style(HTML("
.checkbox{margin-top: -20px; margin-left: 0px; margin-bottom: -5px;padding:-5px; margin-right: -400px;}
.panel{margin: -5px;}")),
uiOutput("grouped.tickboxes"),
textOutput("selectedtext")
)
# .panel{margin: 2px;padding:1px}")),
server <- function(input, output, session) {
output$grouped.tickboxes <- renderUI({
lapply(sort(unique(mtcars$cyl)), function(x) {
fluidRow(
div(tags$style(HTML("
.checkbox{margin: 0px; ;padding:0px; margin-right: -400px;}")),
bsCollapsePanel(paste0("Cylinders: ", x),
style = "color:grey; border-top: 1px solid black",
# style = "color:grey;",
column(12,
checkboxGroupInput(inputId = "stuff",
NULL, choices = sort(row.names(subset(mtcars, cyl %in% x))))))
)
)
})
})
seltex = reactive({
## maybe need to use lapply to read values.
# paste0(input$stuff, collapse = ", ")
# paste0(as.vector(unlist(input$stuff, use.names = FALSE)), collapse = ", ")
# as.vector(unlist(input$stuff, use.names = FALSE))[1]
# head(str(input$stuff))
# lapply(input$stuff, str(input$stuff)[2]
# paste0(unlist(unlist(unlist(input$stuff), use.names = FALSE)), collapse = ", ")
# paste0(unlist(unlist(unlist(input$stuff)), use.names = FALSE), collapse = ", ")
# paste0(unlist(unlist(input$stuff)), collapse = ", ")
paste0("Selected cars : ", paste0(unlist(input$stuff), collapse = ", "))
})
output$selectedtext = renderText({ as.character(seltex() )})
}
# grouped.tickboxes
shinyApp(ui, server)
As far as I get it the issue arises because you assign the same inputId to all three checkbox panels. Hence one approach to make your app work is to assign different inputIds for the checkbox panels. Try this:
library(shiny)
library(shinyBS)
ui <- fixedPage(
h2("R Shiny: Multiple collapsing tickboxes"),
tags$style(HTML("
.checkbox{margin-top: -20px; margin-left: 0px; margin-bottom: -5px;padding:-5px; margin-right: -400px;}
.panel{margin: -5px;}")),
uiOutput("grouped.tickboxes"),
textOutput("selectedtext")
)
# .panel{margin: 2px;padding:1px}")),
server <- function(input, output, session) {
output$grouped.tickboxes <- renderUI({
lapply(sort(unique(mtcars$cyl)), function(x) {
fluidRow(
div(tags$style(HTML("
.checkbox{margin: 0px; ;padding:0px; margin-right: -400px;}")),
bsCollapsePanel(paste0("Cylinders: ", x),
style = "color:grey; border-top: 1px solid black",
# style = "color:grey;",
column(12,
checkboxGroupInput(inputId = paste0("stuff", x),
NULL, choices = sort(row.names(subset(mtcars, cyl %in% x))))))
)
)
})
})
seltex = reactive({
cars <- purrr::reduce(sort(unique(mtcars$cyl)), ~ c(.x, input[[paste0("stuff", .y)]]), .init = character(0))
paste0("Selected cars : ", paste0(cars, collapse = ", "))
})
output$selectedtext = renderText({ seltex() })
}
# grouped.tickboxes
shinyApp(ui, server)
I am trying to update divs while in a loop, some of which contain images. Using removeUI(..., immediate = TRUE) I can remove them and then replace them by new divs, with insertUI(..., immediate = TRUE). Although the texts appear in real time, the images do not load until we are out of the loop (see example below, you don't even have to load an image, a question mark will appear after the loop ends).
In my browser I can see the img tags are created in HTML, but still no images appear live.
Here is a reproducible example:
ui <- fluidPage(
actionButton("add","")
)
server <- function(input, output, session) {
for(i in 1:3){
Sys.sleep(1.5)
insertUI(
selector = "#add",
where = "afterEnd",
ui = div(style = paste0("width: 75px; height: 75px; background-color: white;"), h5("Text appears live", align = "center"),
div(h6("Text inside a div appears live")),
div(id = "img", img(src = "image.jpg", alt = "Images do not appear live")
)
),
immediate = TRUE
)
}
}
shinyApp(ui, server)
Is this normal behavior for shiny? If so is their a way to bypass it and to see the images appear directly? Another way to do it?
Here's a slightly more self-contained set of code that works for me if I run the app by hitting the "Run App" button in Rstudio.
dir.create("www")
dir.create("www/images")
library(shiny)
library(magick)
green.square <- image_blank(width=50, height =75, color= "green")
grid.total.squares <- 12*8
wordList <- 1:(grid.total.squares*2)
for (i in seq_along(wordList)){
thisImage = image_annotate(green.square, gravity="center", i,
size=30)
image_write(thisImage, format = "png", path = paste0("www/images/",i, ".png"))
}
ui <- fluidPage(
actionButton("add","Add something"),
)
server <- function(input, output, session) {
for(i in 1:3){
Sys.sleep(.5)
insertUI(
selector = "#add",
where = "afterEnd",
ui = div(style = paste0("min-width:75px; min-height: 75px; background-color: white; clear:both;"), h5("Text appears live", align = "center"),
div(h6("Text inside a div appears live")),
div(id = "img",
img(src = paste0("images/",i,".png"),
alt = "Images do not appear live"
),
hr()
)
),
immediate = TRUE
)
}
}
shinyApp(ui, server)
I've managed build a simple shiny app that takes user input from a pre-defined list and passes this input as a vector to a function, then outputs the result of that function (here I've replaced that function with print).
library(shiny)
library(shinythemes)
server <- function(input, output) {
LIST_OF_STUFF = c("A", "B", "C", "D")
other_select <- function(inputId) {
reactive({
select_ids <- grep("^select_\\d+$", names(input), value = T)
other_select_ids <- setdiff(select_ids, inputId)
purrr::map(other_select_ids, purrr::partial(`[[`, input))
})
}
render_select <- function(i, label = "Enter selections") {
renderUI({
this_id <- paste0("select_", i)
this_input <- isolate(input[[this_id]])
selected_elsewhere <- unlist(other_select(this_id)())
available_choices <- setdiff(LIST_OF_STUFF, selected_elsewhere)
selectInput(inputId = this_id, label = label, choices = available_choices,
selected = this_input, multiple = TRUE)
})
}
output$select_1 <- render_select(1)
output$selected_var <- renderTable({
as.data.frame(print(input$select_1))
})
}
ui <- fluidPage(theme = "united",
titlePanel("Title"),
mainPanel(img(src = 'testimage.png', align = "right")),
uiOutput("select_1"),
tableOutput("selected_var"))
shinyApp(ui, server)
A few questions: The resulting table has the title "print(input$select_1)" -- how can I customize this?
I'd like to apply a theme to add some color to the app, but it doesn't seem to show up. How can I make the background or header bar colored?
The results table currently prints immediately upon user selection, but I'd like it to wait until the user is finished selecting input. How can I do this?
This is my first time using shiny or making any sort of interactive application, so forgive me if these are trivial questions. Thanks!
Data frame output
To display a custom name you could add a variable name to your data frame:
output$selected_var <- renderTable({
data.frame(selections = isolate(input$select_1))
})
App customization
Since it's a web app, you can customize (almost) any element of your app. You just have to target the elements that you want to modify, for example if you want to modify the color of the background and the color of the header, you can add custom CSS within your code:
tags$head(
tags$style(
HTML("h2 {
color: red;
}
body {
background-color: grey;
}")
)
)
Delay
To wait for the user to finish the selection, I would suggest you to add an actionButton that the user will have to press to render the table. One way to do this is to use an observeEvent and to isolate the input selection.
All in all
All in all, you could have an app that looks like this:
library(shiny)
library(shinythemes)
server <- function(input, output) {
LIST_OF_STUFF = c("A", "B", "C", "D")
other_select <- function(inputId) {
reactive({
select_ids <- grep("^select_\\d+$", names(input), value = T)
other_select_ids <- setdiff(select_ids, inputId)
purrr::map(other_select_ids, purrr::partial(`[[`, input))
})
}
render_select <- function(i, label = "Enter selections") {
renderUI({
this_id <- paste0("select_", i)
this_input <- isolate(input[[this_id]])
selected_elsewhere <- unlist(other_select(this_id)())
available_choices <- setdiff(LIST_OF_STUFF, selected_elsewhere)
selectInput(inputId = this_id, label = label, choices = available_choices,
selected = this_input, multiple = TRUE)
})
}
output$select_1 <- render_select(1)
observeEvent(input$run, {
output$selected_var <- renderTable({
data.frame(selections = isolate(input$select_1))
})
})
}
ui <- fluidPage(theme = "united",
titlePanel("Title"),
tags$head(
tags$style(
HTML("h2 {
color: red;
}
body {
background-color: grey;
}")
)
),
mainPanel(img(src = 'testimage.png', align = "right")),
uiOutput("select_1"),
actionButton("run", "Run"),
tableOutput("selected_var"))
shinyApp(ui, server)
I'm building an app that allows user to pass the value from selectizeInput or checkboxInput to form a dataframe. I've searched a while and found these sources that similar to what I expect:
handsontable
It is from here: https://github.com/jrowen/rhandsontable. Mine is quite similar to this exampe:
shiny::runGitHub("jrowen/rhandsontable",
subdir = "inst/examples/rhandsontable_portfolio")
But I want to use shiny widgets to pass values to the dataframe. It should be able to add/remove rows as following example:
shinyIncubator
code here:
library("shiny")
library('devtools')
install_github('shiny-incubator', 'rstudio')
library("shinyIncubator")
# initialize data with colnames
df <- data.frame(matrix(c("0","0"), 1, 2))
colnames(df) <- c("Input1", "Input2")
server = shinyServer(
function(input, output) {
# table of outputs
output$table.output <- renderTable(
{ res <- matrix(apply(input$data,1,prod))
res <- do.call(cbind, list(input$data, res))
colnames(res) <- c("Input 1","Input 2","Product")
res
}
, include.rownames = FALSE
, include.colnames = TRUE
, align = "cccc"
, digits = 2
, sanitize.text.function = function(x) x
)
}
)
ui = shinyUI(
pageWithSidebar(
headerPanel('Simple matrixInput example')
,
sidebarPanel(
# customize display settings
tags$head(
tags$style(type='text/css'
, "table.data { width: 300px; }"
, ".well {width: 80%; background-color: NULL; border: 0px solid rgb(255, 255, 255); box-shadow: 0px 0px 0px rgb(255, 255, 255) inset;}"
, ".tableinput .hide {display: table-header-group; color: black; align-items: center; text-align: center; align-self: center;}"
, ".tableinput-container {width: 100%; text-align: center;}"
, ".tableinput-buttons {margin: 10px;}"
, ".data {background-color: rgb(255,255,255);}"
, ".table th, .table td {text-align: center;}"
)
)
,
wellPanel(
h4("Input Table")
,
matrixInput(inputId = 'data', label = 'Add/Remove Rows', data = df)
,
helpText("This table accepts user input into each cell. The number of rows may be controlled by pressing the +/- buttons.")
)
)
,
mainPanel(
wellPanel(
wellPanel(
h4("Output Table")
,
tableOutput(outputId = 'table.output')
,
helpText("This table displays the input matrix together with the product of the rows of the input matrix")
)
)
)
)
)
runApp(list(ui = ui, server = server))
The value should be entered by user from shiny widgets such as selectizeInput, checkboxInput or textInput and passed to the dataframe once the user click my actionButton. What I want is pretty similar to the combination of the above functions but I don't know how to do. Any suggestions?
Many thanks in advance.
Though I ended up using none of the two packages, this worked fine:
library(shiny)
server = shinyServer(function(input, output, session){
values <- reactiveValues()
values$DT <- data.frame(Name = NA,
status = NA,
compare = NA,
stringsAsFactors = FALSE)
newEntry <- observeEvent(input$addrow, {
newLine <- c(input$textIn, input$boxIn, input$selectIn)
values$DT <- rbind(values$DT, newLine)
})
newEntry <- observeEvent(input$revrow, {
deleteLine <- values$DT[-nrow(values$DT), ]
values$DT <- deleteLine
})
output$table <- renderTable({
values$DT
})
})
ui = shinyUI(navbarPage(
"Backtest System", inverse = TRUE, id = "navbar",
tabPanel("Strategy",
sidebarLayout(
sidebarPanel(
h4("Indicator"),
textInput("textIn", "Text", "try"),
checkboxInput("boxIn", "Box", TRUE),
selectizeInput("selectIn", "Select",
choices = c(">" = ">",
">=" = ">=",
"<" = "<",
"<=" = "<=")),
actionButton("addrow", "Add Row"),
actionButton("revrow", "Remove Row")
),
mainPanel(
tableOutput("table")
)
)
)
)
)
runApp(list(ui = ui, server = server))