I am trying to get access to colnames(input$file1) for a selectInput drop down menu in a UI. In addition, I would like the default column that is selected to be the first numeric column. I'm not exactly how to accomplish this. It is beyond my shiny skill set. If anyone has any suggestions I'd really appreciate it.
Thanks,
gwynn
runApp(
list(
ui = fluidPage(
titlePanel("Use readxl"),
tabsetPanel(
tabPanel("Upload Data",
sidebarPanel(
helpText("Input an excel file here. We assume the data are in the
first sheet with the first row being headers."),
br(),
fileInput("file1", "Choose Excel File",
accept = c(
"xls",
"xlsx")
),
br()
)),
## This is where I get completely lost.
tabPanel("General Inputs",
selectInput("select", label = h3("Select column"),
choices = colnames(M()[[1]]), selected = M()[[2]][1])
)
),
server = function(input, output){
M = reactive({
M = taglist()
inFile <- input$file1
if(is.null(inFile))
return(NULL)
file.rename(inFile$datapath,
paste(inFile$datapath, ".xlsx", sep=""))
D = read_excel(paste(inFile$datapath, ".xlsx", sep=""), 1)
D = as.data.frame(D)
## Upating file names
colnames(D) <- labs <- gsub("\r\n"," ", colnames(D))
nums = labs[which(sapply(D, is.numeric) == TRUE)]
M[[1]] = D
M[[2]] = nums
})
}
)
)
)
I asked this a few weeks ago and noone answered, in the meantime I fixed it:
runApp(
list(
ui = fluidPage(
titlePanel("Use readxl"),
tabsetPanel(
tabPanel("Upload Data",
sidebarPanel(
helpText("Input an excel file here. We assume the data are in the
first sheet with the first row being headers."),
br(),
fileInput("file1", "Choose Excel File",
accept = c(
"xls",
"xlsx")
),
br(),
actionButton("UI", "Add my data")
)),
tabPanel("General Inputs",
uiOutput("VarsInput")
)
)),
server = function(input, output){
M = reactive({
inFile <- input$file1
M = tagList()
if(is.null(inFile))
return(NULL)
file.rename(inFile$datapath,
paste(inFile$datapath, ".xlsx", sep=""))
D = read_excel(paste(inFile$datapath, ".xlsx", sep=""), 1)
D = as.data.frame(D)
## Upating file names
colnames(D) <- labs <- gsub("\r\n"," ", colnames(D))
nums = labs[which(sapply(D, is.numeric) == TRUE)]
M[[1]] = D
M[[2]] = nums
M
})
output$VarsInput <- renderUI({
selectInput("Choose a variable", "Variable to randomize:",
choices = colnames(M()[[1]]), selected = M()[[2]][1])
})
}
)
)
Basically, I forgot to tell the reactive what to spit out, then I got lost b/c computers are stupid.
Related
I was wondering if it is possible to save DT table content together with some additional information which is not part of the data frame/table like app version number, date of execution, sliderInput value etc.
Thank you!
Reprex below:
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1)
),
mainPanel(
DT::dataTableOutput("table")
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
}
shinyApp(ui = ui, server = server)
You could save the contents of the data frame and the other information in a list and then save the list.
Or, any R object can have attributes which are completely arbitrary and under your control. You could set attributes of the data frame to record the information you want.
Personally, I'd use the list approach, purely because I don't like attributes.
Here's a suggestion in response to OP's request below.
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1),
actionButton("saveRds", "Save to Rds"),
actionButton("loadRds", "Load from Rds")
),
mainPanel(
DT::dataTableOutput("table"),
wellPanel(h4("Current data"), verbatimTextOutput("text")),
wellPanel(h4("File data"), verbatimTextOutput("loadedData"))
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
listInfo <- reactive({
list("data"=dfr, "version"="WebApp Version 1.0", "runDate"=date(), "sliderValue"=input$range)
})
output$text <- renderPrint({
listInfo()
})
observeEvent(input$saveRds, {
saveRDS(listInfo(), "data.Rds")
})
fileData <- reactive({
req(input$loadRds)
readRDS("data.Rds")
})
output$loadedData <- renderPrint({
fileData()
})
}
shinyApp(ui = ui, server = server)
The way you implement "save to file" will depend on the file format: Excel files will clearly have different requirements to PDF files, for example. As a minimum effort demonstation, I've created "Save to Rds" and "Load from RDS" buttons in the sidebar and added a verbatimTextOutput to display the contents of the file when it's loaded. [I'm not sufficiently familiar with DT to know how to add the buttons in the table toolbar.]
OP's effort was pretty close: it's just that writing a list to CSV file takes a little more effort than just calling write.csv...
I have a simple Shiny app. The user enters a code eg: a1, b1, c1 etc in the textInput.
When only one code is listed it works great, but if the user writes two or more codes separated by a comma it doesn't.
How can the user input as many codes as they like?
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
textInput(inputId = "textBox",
label = "Code Search",
placeholder = "Enter codes here seperated by a comma"),
actionButton("textSearchButton", "Generate the Table")
),
fluidRow(
tableOutput("dtOut")
)
)
)
server <- function(input, output) {
df <- data.frame(Code = paste0(letters, 1),
Description = "Something here",
Value = "Some value")
outputFunc <- function(code, df){
# # Dummy data
# code <- c('a1', 'b1', 'c1')
outTbl <- df[df$Code %in% code,]
return(list(outTbl))
}
textSearch <- eventReactive(input$textSearchButton, {
outputFunc(input$textBox, df)
})
output$dtOut <- renderTable({
textSearch()[[1]]
})
}
shinyApp(ui, server)
I simplified your code a bit:
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
textInput(inputId = "textBox",
label = "Code Search",
placeholder = "Enter codes here seperated by a comma"),
actionButton("textSearchButton", "Generate the Table")
),
fluidRow(
tableOutput("dtOut")
)
)
)
server <- function(input, output) {
df <- eventReactive(input$textSearchButton, {
# outputFunc(input$textBox, df)
req(input$textBox)
codes <- unlist(strsplit(input$textBox, ", "))
return(data.frame(Code = codes,
Description = "Something here",
Value = "Some value"))
})
output$dtOut <- renderTable({
df()
})
}
shinyApp(ui, server)
Does it respond to your need ?
I have tried this in different ways and achieved one task, either add or delete., but i couldn't get complete solution in one, i might be missing some small concept somewhere.. I am adding the code , please help me complete my basic app.
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
),
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = "")
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus")),
),
mainPanel(
dataTableOutput('table')
)
)
)
),
Server side code
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
newEntry <- observe({
cat("newEntry\n")
if(input$add.button > 0) {
newRow <- data.frame(input$v1, input$v2)
isolate(values$df <- rbind(values$df,newRow))
}
})
deleteEntry <- observe({
cat("deleteEntry\n")
if(input$delete.button > 0) {
if(is.na(isolate(input$row.selection))){
values$df <- isolate(values$df[-nrow(values$df), ])
} else {
values$df <- isolate(values$df[-input$row.selection, ])
}
}
})
output$table = renderDataTable({
values$df
})
}
Try to use observeEvent rather than obser with actionbutton
and also, you have uppercase and lowercase issue with input$v2 (should be input$V2)
Try this modified code:
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
)
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = ""),
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus"))
),
mainPanel(
dataTableOutput('table')
)
)
)
)
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
observeEvent(input$add.button,{
cat("addEntry\n")
print(input$v1)
print(input$V2)
newRow <- data.frame(input$v1, input$V2)
colnames(newRow)<-colnames(values$df)
values$df <- rbind(values$df,newRow)
print(nrow(values$df))
})
observeEvent(input$delete.button,{
cat("deleteEntry\n")
if(is.na(input$row.selection)){
values$df <- values$df[-nrow(values$df), ]
} else {
values$df <- values$df[-input$row.selection, ]
}
})
output$table = renderDataTable({
values$df
})
}
shinyApp(ui,server)
Just run all the code above, and it should work properly.
EDITE :
I added one more example that is same as my problem. I want to update the checkboxGroupInput as dataset changes. And also want to render the table with checked column in the checkboxGroupInput options.
SERVER
shinyServer( function(input, output, session) {
dataset_list <- list( "rock" = rock,
"pressure" = pressure,
"cars" = cars
)
observeEvent( input$n_select_input, {
selected_dataset <- reactive({
selected_list <- list()
for( i in 1:input$n_select_input ){
selected_list[[i]] <- dataset_list[[i]]
}
names(selected_list) <- names( dataset_list )[1:input$n_select_input]
selected_list
})
colname_indata_list <- reactive({
colname.indata.list <- list()
for( set in names( selected_dataset() ) ){
colname.indata.list[[set]] <- colnames( selected_dataset()[[set]] )
}
colname.indata.list
})
choice_cand <- reactive({ names(selected_dataset()) })
updateSelectInput( session,
"dataset",
choices = as.character( choice_cand() )
)
choices_cand <- reactive({ colname_indata_list()[[input$dataset]] })
updateCheckboxGroupInput( session,
"column",
choices = as.character( choices_cand() )
)
})
# observeEvent( input$dataset, {
#
# choices_cand <- reactive({ colname_indata_list()[[input$dataset]] })
# updateCheckboxGroupInput( session, "column",
# choices = as.character( choices_cand() ) )
#
# })
datasetInput <- reactive({
switch(input$dataset,
"rock" = rock,
"pressure" = pressure,
"cars" = cars)
})
output$table <- renderTable({
datasetInput()
})
} )
I tried the code above in the ## , it didn't work.
UI
shinyUI(
fluidPage( titlePanel('Downloading Data'),
sidebarLayout(
sidebarPanel( numericInput( "n_select_input", "n select inpur", 1,
min=1, max=3 ),
selectInput("dataset", "Choose a dataset:",
choices = "" ),
checkboxGroupInput( "column", "select column",
choices = "")
),
mainPanel(
tableOutput('table')
)
)
)
)
FIRST WRITE :
I simplified the code below. I want to use updated select input as a output for the updatedCheckboxGroupInput 's choices. But the updated select input, input$select_group is null. I tried varies solutions.. but couldn't solve it.
If you just run this code right away, it doesn't work..
fund_group <- reactive({ # this is the list of fund group including fund name
# for example,
"domestic" = c("a","b", "c"),
"global" = c( "aa", "bb", "cc")
# list name and fund name in the list are changable
})
I want to update selectInput choices as names(fund_group) changes.
So I used code below,
observe({
group_name <- reactive({ names(fund_group()) })
updateSelectInput( session,
"select_group",
choices = group_name() )
fund_list <- reactive({ fund_group()[[input$select_group]] })
updateCheckboxGroupInput( session,
"fund_in_group",
choices = fund_list(),
selected = fund_list() )
})
For the UI,
narvarPage( "narvarTitle",
tabPanel( "tab panel",
fluidRow( column( 3, wellPanel( textOutput( "fixed_anal_date" ),
br(),
br(),
selectInput( "select_group",
label = "Select group",
choices = "" ),
br(),
checkboxGroupInput( "fund_in_group",
label = "Select funds :",
choices = "" ),
br()
) )
) )
Thank you for reading the messy code...
I have edited the code an its working now. You should put the two input in two different observe.
Here is the server. R:
server <- function(input, output, session){
fund_group <- reactive({ # this is the list of fund group including fund name
# for example,
list("domestic" = c("a","b", "c"), "global" = c( "aa", "bb", "cc"))
# list name and fund name in the list are changable
})
observe({
group_name <- reactive({ names(fund_group()) })
updateSelectInput( session,
"select_group",
choices = group_name() )
})
observe({
fund_list <- reactive({ fund_group()[[input$select_group]] })
updateCheckboxGroupInput( session,
"fund_in_group",
choices = fund_list(),
selected = fund_list())
})
}
Here is the ui.R:
ui <- navbarPage( "narvarTitle",
tabPanel( "tab panel",
fluidRow( column( 3, wellPanel( textOutput( "fixed_anual_date" ),
br(),
br(),
selectInput( "select_group",
label = "Select group",
choices = "" ),
br(),
checkboxGroupInput( "fund_in_group",
label = "Select funds :",
choices = "" ),
br()
) )
) )
)
[EDIT]:
As per your latest update I have modified the server code so that checkboxGrouptInput is updated as dataset changes and also the table is rendered for the checked columns.
shinyServer( function(input, output, session) {
dataset_list <- list( "rock" = rock,
"pressure" = pressure,
"cars" = cars
)
observeEvent( input$n_select_input, {
selected_dataset <- reactive({
selected_list <- list()
for( i in 1:input$n_select_input ){
selected_list[[i]] <- dataset_list[[i]]
}
names(selected_list) <- names( dataset_list )[1:input$n_select_input]
selected_list
})
colname_indata_list <- reactive({
colname.indata.list <- list()
for( set in names( selected_dataset() ) ){
colname.indata.list[[set]] <- colnames( selected_dataset()[[set]] )
}
colname.indata.list
})
choice_cand <- reactive({
names(selected_dataset()) })
updateSelectInput( session,
"dataset",
choices = as.character( choice_cand() )
)
######################################Start: Modified#############################
observe({
input$dataset ##Added so that this observe is called when the input$dataset changes
choices_cand <- reactive({
colname_indata_list()[[input$dataset]] })
updateCheckboxGroupInput( session,
"column",
choices = as.character( choices_cand()) ,
selected = as.character( choices_cand())
)
})
})
######################################End: Modified#############################
datasetInput <- reactive({
switch(input$dataset,
"rock" = rock,
"pressure" = pressure,
"cars" = cars)
})
output$table <- renderTable({
datasetInput()[,input$column]##only selected columns are displayed
})
} )
Hope this helps!
This app is creating a vector of standardised names which I create given some user input (number of channels and replicates). An example of the standard names given the number of channels = 4 and and replicates = 1 is as follows:
c("rep1_C0","rep1_C1","rep1_C2","rep1_C3")
I would like to allow the user to replace the value of the selection with their own custom value. For example to change the input "rep1_C0" to "Control_rep1". And then for it to then update the reactive vector in question. Here is my code:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
),
uiOutput("selectnames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$selectnames <- renderUI({
selectizeInput("selectnames", "Change Names", choices = standardNames(),
options = list(maxOptions = input$reps * input$chans))
})
## output
output$testcols <- renderTable({
standardNames()
})
})
shinyApp(ui = ui, server = server)
Is there some kind of option I can pass in the options sections that will allow this?
With selectizeInput you can set options = list(create = TRUE) to allow the user to add levels to the selection list, but I don't think that is what you want.
Instead, here is code that generates a text input box for each of the standard names, and allows the user to enter a label for them. It uses lapply and sapply to loop over each value and generate/read the inputs.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
),
uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$setNames <- renderUI({
lapply(standardNames(), function(thisName){
textInput(paste0("stdName_", thisName)
, thisName
, thisName)
})
})
labelNames <- reactive({
sapply(standardNames()
, function(thisName){
input[[paste0("stdName_", thisName)]]
})
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = labelNames()
)
})
})
shinyApp(ui = ui, server = server)
If you want to hide the list unless the user wants to add labels, you can use a simple checkbox, like this, which hides the label making list until the use checks the box to show it.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
)
, checkboxInput("customNames", "Customize names?")
, uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$setNames <- renderUI({
if(!input$customNames){
return(NULL)
}
lapply(standardNames(), function(thisName){
textInput(paste0("stdName_", thisName)
, thisName
, thisName)
})
})
labelNames <- reactive({
if(!input$customNames){
return(standardNames())
}
sapply(standardNames()
, function(thisName){
input[[paste0("stdName_", thisName)]]
})
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = labelNames()
)
})
})
shinyApp(ui = ui, server = server)
Alternatively, if you think the user may want to only change one or a small number of labels, here is a way to allow them to choose which standard name they are applying a label to:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
)
, uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
vals <- reactiveValues(
labelNames = character()
)
standardNames <- reactive({
out <- paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
vals$labelNames = setNames(out, out)
return(out)
})
output$setNames <- renderUI({
list(
h4("Add labels")
, selectInput("nameToChange", "Standard name to label"
, names(vals$labelNames))
, textInput("labelToAdd", "Label to apply")
, actionButton("makeLabel", "Set label")
)
})
observeEvent(input$makeLabel, {
vals$labelNames[input$nameToChange] <- input$labelToAdd
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = vals$labelNames
)
})
})
shinyApp(ui = ui, server = server)