I'd like to be able to use results of an input in the Ui part of my shiny app, to set the default value and the maximum of a numericInput.
Here is the "idea" of the ui part i'd like :
ui <- (
numericInput("n21","choose input1",min=0,max=100000,value=5107,step=1),
numericInput("n22","choose input2",min=0,max=2000,value=1480.3/40),
# here i'd like to define value and max with the result of inputs (n23)
numericInput(inputId="nb_rows","Number of rows to show",value=n23,min=1,max=n23)
tableOutput(outputId = "data")
)
And the server part :
server <- function(input,output,session){
....
RE <- reactive({
n21 <- input$n21
n22 <- input$n22
n23 <- n21%/%n22
return(head(data, n=input$nb_rows))
})
output$data <- renderTable({RE()})
}
Any suggestions?
You will need to use the observe function to change the numericinput that you want to change so we will do:
`server <- function(input,output,session){
....
RE <- reactive({
n21 <- input$n21
n22 <- input$n22
n23 <- n21%/%n22
return(n23)
})`
` observe({
x <- RE()
# Can use character(0) to remove all choices
if (is.null(x))
x <- character(0)
# Can also set the label and select items
updateNumericInput(session, "nb_rows",
label = "Number of rows to show",
value = x,
min = 1,
max = x
)
})`
And then you re-make the output table function
I hope it helps.
Related
I am wondering, why assign function is not working inside the reactiveValues? I need to apply a function that will define reactiveValues (zeros) to all elements in a vector. Those elements are not known in advance, because they are column names of all variables from initially opened csv file. So I cannot simply set values one by one. Any suggestion is highly appreciated.
ui <- shinyUI(fluidPage(
titlePanel("Wondering"),
sidebarLayout(
sidebarPanel(
actionButton(inputId = "add_one", label = "", icon = icon("plus"))
),
mainPanel(
tabsetPanel(
tabPanel("Simple example",textOutput("test1"))
)
)
)
)
)
##########
# SERVER #
##########
server <- shinyServer(function(input, output) {
col_names <- c("A", "B")
# Assign zeros to all elements from col_names
# Please, use the assign function to do that!
rv <- reactiveValues(
# 1 How can I assign the initial value of zero to all column names?
# This is easy:
A = 0, B = 0
# But, in reality, in my app I do not know the variable names in advance, I just extract them and save
# in the col_names vector. Now, I need to assign initial value of zero to all column names
# I thought this might work, but no luck: All arguments passed to reactiveValues() must be named.
#for (k in 1:length(col_names)){
#
# assign(col_names[k], 0)
#}
)
# Sure, I will later have to figure out how to define observeEvent(s) for the unknown number of column names, but I am not there yet...
observeEvent(input$add_one, {
rv$A <- rv$A + 1
})
observeEvent(input$add_one, {
rv$B <- rv$B + 1
})
# Output text
output$test1 <-renderText({
paste(rv$A, rv$B)
})
})
shinyApp(ui = ui, server = server)
You could do:
rv <- reactiveValues()
for(colname in col_names){
rv[[colname]] <- 0
}
I am trying to filter the data in a datatable based from the inputs from the slider range. When this is done I get an error subscript out of bounds. I see the slider range to be working fine. But the range doesnt seems to filter the data table.
Below is the code which I have used :
response_codes <- function(status_code){
status_df <- tibble::tribble(
~status_code, ~message,
200, "Success",
201, "Successfully created item",
204, "Item deleted successfully",
400, "Something was wrong with the format of your request",
401, "Unauthorized - your API key is invalid",
403, "Forbidden - you do not have access to operate on the requested item(s)",
404, "Item not found",
429, "Request was throttled - you are sending too many requests too fast."
)
out <- status_df[status_df$status_code == status_code, "message"]
out <- unlist(out, use.names = FALSE)
out
}
install.packages("devtools")
library(tidyr)
lego_get <- function(url, ..., api_key){
auth <- paste("key", api_key)
query = list(...)
# Call the apiå
api_call <- httr::GET(url, query = query,
httr::add_headers(Authorization = auth))
if(httr::status_code(api_call) > 204){
stop(response_codes(httr::status_code(api_call)))
} else {
message(response_codes(httr::status_code(api_call)))
}
# Collect data
out <- list()
api_data <- httr::content(api_call)
if(is.null(api_data$results)){
api_data <- null_to_na(api_data)
return(api_data)
}
if(length(api_data$results) == 0){
api_data$results <- NA
api_data <- null_to_na(api_data)
return(api_data)
}
out <- c(out, list(api_data$results))
# While loop to deal with pagination
while(!is.null(api_data$`next`)){
message(paste("Pagenating to:", api_data$`next`))
api_call <- httr::GET(api_data$`next`, httr::add_headers(Authorization = auth))
api_data <- httr::content(api_call)
out <- c(out, list(api_data$results))
}
# Flatten the list
out <- purrr::flatten(out)
# Set nulls to NA
out <- null_to_na(out)
# Return data
out
}
null_to_na <- function(mylist){
purrr::map(mylist, function(x){
if(is.list(x)){
null_to_na(x)
} else {
if(is.null(x)) NA else x
}
})
}
color_list_to_df <- function(lego_data){
out <- purrr::map_df(lego_data, function(color){
external_ids <- names(color$external_ids)
col_df <- purrr::map_df(external_ids, function(external_id){
ext_ids <- unlist(color$external_ids[[external_id]]$ext_ids)
df <- tibble::tibble(
external_id = external_id,
ext_ids = ext_ids
)
ext_descrs <- color$external_ids[[external_id]]$ext_descrs
ext_descrs <- purrr::map(ext_descrs, unlist)
df$ext_descrs <- ext_descrs
df <- tidyr::unnest(df, ext_descrs)
df
})
external <- tidyr::nest(col_df, .key = external_ids)
tibble::tibble(
id = color$id,
name = color$name,
rgb = color$rgb,
is_trans = color$is_trans,
external_ids = external$external_ids
)
})
out
}
parts_list_to_df <- function(lego_data){
out <- purrr::map_df(lego_data, function(parts_data){
if(length(parts_data$external_ids) != 0){
part_df <- tibble::tibble(
external_ids = names(parts_data$external_ids)
)
part_df$ids <- purrr::map(part_df$external_ids, function(ext_name){
unlist(parts_data$external_ids[[ext_name]])
})
part_df <- tidyr::unnest(part_df, ids)
external <- tidyr::nest(part_df, .key = external_ids)
} else {
external <- list()
external$external_ids <- NA
}
tibble::tibble(
part_num = parts_data$part_num,
name = parts_data$name,
part_cat_id = parts_data$part_cat_id,
part_url = parts_data$part_url,
part_img_url = parts_data$part_img_url,
external_ids = external$external_ids
)
})
out
}
###############################################################
url <- "https://rebrickable.com/api/v3/lego/sets/"
api_key <- "5baf593383d5f6a7fadd264480287ac9"
lego_data <- lego_get(url = url, api_key = api_key)
message("Converting to tibble")
out <- purrr::map_df(lego_data, tibble::as_tibble)
out
###############################################################
#devtools::install_github("rstudio/shiny")
#install.packages("devtools")
#install.packages("DT")
library(shiny)
library(devtools)
library(DT)
library(yaml)
# Define UI for slider demo app ----
ui <- fluidPage(
# App title ----
titlePanel("Sliders"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar to demonstrate various slider options ----
sidebarPanel(
# Input: Specification of range within an interval ----
sliderInput("range", "Range:",
min = min(out$year,na.rm=FALSE), max = max(out$year,na.rm=FALSE),
value = c(1990,1995))
),
mainPanel(
DT::dataTableOutput("mytable")
)
)
)
server <- function(input, output) {
# sorted columns are colored now because CSS are attached to them
# output$mytable <- DT::renderDataTable({
# DT::datatable(out, options = list(orderClasses = TRUE))
# })
minRowVal <- reactive({
which(grepl(input$range[[1]], out$year)) #Retrieve row number that matches selected range on sliderInput
})
maxRowVal <- reactive({
which(grepl(input$range[[2]], out$year)) #Retrieve row number that matches selected range on sliderInput
})
observeEvent(input$range, {
output$mytable <- DT::renderDataTable({
DT::datatable[minRowVal():maxRowVal(), ]
})
})
}
shinyApp(ui, server)
Update the code from where I fetch the data to run display it on the app.
There are two types of shiny slider bars and they can have either one or two values. The number of values in the slider bar will be determined by how it is defined in the ui.
Because you only defined a singular slider in the initiation of the ui, there is not a second input input$range[[2]] when you try to extract it later in the reactive. Therefore, you need to set a second value in your ui or you will only get a single slider instead of a range. For example:
sliderInput("range", "Range:",
min = min(out$year,na.rm=FALSE), max = max(out$year,na.rm=FALSE),
value = c(1990,1991))
For an example of the difference between the two (slider bar vs. slider range) look here
And note:
If value is a vector of two numbers, Shiny will place two sliders on the bar, which will let your user select the endpoints of a range. If value is a single number, Shiny will create a basic slider like the one shown above.
How to delete element from reactiveValues()
For example, when I run the code:
library(shiny)
runApp(list(
ui=tableOutput("table1"),
server=function(input, output, session) {
values <- reactiveValues(val1 = 1, val2 =2, val3 = 3)
values$val1 <- NULL
output$table1 <- renderPrint(reactiveValuesToList( values) )
}))
The output is:
$val1 NULL $val2 [1] 2 $val3 [1] 3
Instead of:
$val2 [1] 2 $val3 [1] 3
Thank you!
If you still want to use the assignment to NULL to remove values, you can assign the reactive value to be a list. See below for a simple modification to Zygmunt Zawadzki's answer. Then operate on the list in the usual R way to reflect the changes in your data.
library(shiny)
ui <- fluidPage(
mainPanel(
actionButton("delete", "delete"),
verbatimTextOutput("table1")
)
)
)
runApp(list(
ui=ui,
server=function(input, output, session) {
values <- reactiveValues(data=list(val1 = rnorm(1e7), val2 =2, val3 = 3))
observeEvent(input$delete,{
values$data$val1 <- NULL
})
output$table1 <- renderPrint({
res <- capture.output(gc())
cat(res, sep = "\n")
# No reactiveValuesToList needed
# x <- reactiveValuesToList(values)
length(values$data)
})
}))
I'll try to addres this:
I would like to delete elements from a reactiveValues object because I am using it to store user-defined list objects that can be quite large individually. My concern is that if the user creates too many such objects in a single session it will cause the app to crash due to insufficient memory.
When you assign NULL to the value R will remove the element from memory. See the app below - when you click delete button the memory is released:
library(shiny)
ui <- fluidPage(
mainPanel(
actionButton("delete", "delete"),
verbatimTextOutput("table1")
)
)
)
runApp(list(
ui=ui,
server=function(input, output, session) {
values <- reactiveValues(val1 = rnorm(1e7), val2 =2, val3 = 3)
observeEvent(input$delete,{
values$val1 <- NULL
})
output$table1 <- renderPrint({
res <- capture.output(gc())
cat(res, sep = "\n")
x <- reactiveValuesToList(values)
length(x)
})
}))
The two images below show you the state before clicking the delete, and after -> note that the value used by R has changed.
Those missing 80mb is the size of the val1 vector.
pryr::object_size(rnorm(1e7))
# 80 MB
I have successfully updated UI dynamically through renderUI(). I have a long list of inputs to choose from. The check boxes are used to dynamically add numeric inputs. So, to implement this, I used lapply. However, I have used values of selected check boxes in checkboxgroup itself to populate IDs of the dynamically added numerical input instead of using paste(input, i) in lapply.
ui code snippet :
checkboxGroupInput(inputId = "checkboxgrp", label = "Select types",
choices = list("ELECTAPP","NB W $","PUR","MANUAL LTR","REDEMPTION","NB W TRANSFER","NB WOUT $","OUTPUT")),
...
fluidRow(column(12, verbatimTextOutput("value")))
...
uiOutput("numerics")
server code snippet :
renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
lapply(1:numInputs, function(i){
x[i]=input$checkboxgrp[i]
list(numericInput(input$checkboxgrp[i], min = 0, label = input$checkboxgrp[i],
value= input[[x[i]]] ))
})
}
})
output$value <- renderPrint({
numInputs <- length(input$checkboxgrp)
lapply(1:numInputs, function(i){
print(input[[x[i]]]) ## ERROR
})
})
I have used input[[x[i]]] as to instantiate value to be retained after adding or removing a numeric input. But, I want to extract values from input$x[i] or input[[x[i]]] into a vector for further use which I'm unable to do.
*ERROR:Must use single string to index into reactivevalues
Any help is appreciated.
EDIT
using 3 different ways of extracting values from input generate 3 different errors:
Using print(input$x[i]) # ERROR
NULL
NULL
NULL
NULL
[[1]]
NULL
[[2]]
NULL
[[3]]
NULL
[[4]]
NULL
Using print(input[[x[i]]]) # ERROR
Must use single string to index into reactivevalues
Using print('$'(input, x[i])) # ERROR
invalid subscript type 'language'
If I understand you correctly, you want to access values of dynamically generated widgets and then just print them out.
In my example below, which should be easy to generalise, the choices are the levels of the variable Setosa from the iris dataset.
The IDs of the generated widgets are always given by the selected values in checkboxGroupInput. So, input$checkboxgrp says to shiny for which level of setosa there should be generated a widget. At the same time input$checkboxgrp gives IDs of generated widgets. That's why you don't need to store the IDs of "active" widgets in other variable x (which is probably a reactive value).
To print the values out you can do the following:
output$value <- renderPrint({
activeWidgets <- input$checkboxgrp
for (i in activeWidgets) {
print(paste0(i, " = ", input[[i]]))
}
})
This line print(input[[x[i]]]) ## ERROR yields an error because x[i] (whatever it is) is not a vector with a single value but with multiple values.
Full example:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("checkboxgrp", "levels", levels(iris$Species))
),
mainPanel(
fluidRow(
column(6, uiOutput("dynamic")),
column(6, verbatimTextOutput("value"))
)
)
)
)
server <- function(input, output) {
output$dynamic <- renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
lapply(1:numInputs, function(i){
x[i]=input$checkboxgrp[i]
list(numericInput(input$checkboxgrp[i], min = 0, label = input$checkboxgrp[i],
value= input[[x[i]]] ))
})
}
})
output$value <- renderPrint({
activeWidgets <- input$checkboxgrp
for (i in activeWidgets) {
print(paste0(i, " = ", input[[i]]))
}
})
}
shinyApp(ui = ui, server = server)
Edit:
You could tweak the lapply part a little bit (mind <<- operator :) )
else{
activeWidgets <- input$checkboxgrp
val <- 0
lapply(activeWidgets, function(i){
val <<- val + 1
list(numericInput(i, min = 0, label = i,
value = val ))
})
}
Edit 2 In response to a comment:
server <- function(input, output) {
output$dynamic <- renderUI({
numInputs <- length(input$checkboxgrp)
if(numInputs==0){
wellPanel("No transaction selected")
}
else{
activeWidgets <- input$checkboxgrp
val <- 0
lapply(activeWidgets, function(i){
val <<- val + 1
list(numericInput(i, min = 0, label = i,
value = val ))
})
}
})
allChoices <- reactive({
# Require that all input$checkboxgrp and
# the last generated numericInput are available.
# (If the last generated numericInput is available (is not NULL),
# then all previous are available too)
# "eval(parse(text = paste0("input$", input$checkboxgrp))))" yields
# a value of the last generated numericInput.
# In this way we avoid multiple re-evaulation of allChoices()
# and errors
req(input$checkboxgrp, eval(parse(text = paste0("input$", input$checkboxgrp))))
activeWidgets <- input$checkboxgrp
res <- numeric(length(activeWidgets))
names(res) <- activeWidgets
for (i in activeWidgets) {
res[i] <- input[[i]]
}
res
})
output$value <- renderPrint({
print(allChoices())
})
}
i have the code as below and trying to plot gvisBarChart using the data selected from the drop down. the Server.r and ui.r code is given below
#server.r
shinyServer(function(input, output, session) {
output$ShowdataColDropDown <- renderUI({
df <-filedata()
if (is.null(df)) return(NULL)
#Let's only show numeric columns
nums <- sapply(df, is.numeric)
numitems=names(nums[nums])
selectizeInput("VarData", "Select Data:",c("", numitems()), multiple=TRUE, options = list(maxItems = 2,placeholder = 'select x and y parameters'))
})
output$ShowdataCatDropDown <- renderUI({
df <-filedata()
#Let's only show numeric columns
nums <- sapply(df, is.numeric)
numitems=names(nums[nums])
names(numitems)=numitems
selectInput("charData", "Select Data:",c("", numitems), selected=numitems[1])
})
output$myplot<-renderGvis({
#data
filedata <- data.frame(product=c("A","A","A","B","B"),Sales= c(10,3,4,2,20))
dfall<-data.frame(cbind(filedata[input$VarData],filedata[input$charData]))
#input$VarData is the input selected by the user for say 'sales'
#input$charDatais the input selected by the user for say 'product'
#The barchart code below is not working; Getting the error as: arguments must have same length
gvisBarChart(aggregate(dfall, list(dfall[input$charData]),mean))
})
}
#UI.r
shinyUI(
fluidPage(
uiOutput("ShowdataColDropDown"),
uiOutput("ShowdataCatDropDown"),
htmloutput("myplot")
)
please help me to dusplay the chart using mean(sales) by product.