I'm trying to manipulate a dataframe based on the input. Here's my code:
library(shiny)
library(quantmod)
ui <- fluidPage(
plotOutput("chart", click = "SD1"),
radioButtons(
"term",
"Term",
choices = c("Daily", "Weekly", "Monthly"),
))
server <- function(input, output){
df1 <- reactive(getSymbols("JPM", src = "google", auto.assign = F))
output$chart <- renderPlot(
if (input$term == "Weekly") {
df <- to.weekly(df1())
}
else if (input$term == "Monthly") {
df <- to.monthly(df1())
}
else {
df <- df1()
}
chartSeries(
df()
)
)
}
shinyApp(ui, server)
So why my if condition doesn't work? Thank you very much!
I think you got your brackets mixed up, this should do the job. If you want to use your subset data and still keep access to original you can create two reactives: one you can access with df1() and the other is df()
library(shiny)
library(quantmod)
ui <- fluidPage(
plotOutput("chart", click = "SD1"),
radioButtons(
"term",
"Term",
choices = c("Daily", "Weekly", "Monthly"),
))
server <- function(input, output){
df1 <- reactive({getSymbols("JPM", src = "google", auto.assign = F)})
df <-reactive({
if (input$term == "Weekly") {
df <- to.weekly(df1())
}
else if (input$term == "Monthly") {
df <- to.monthly(df1())
}
else {
df <- df1()
}
return(df)
})
output$chart <- renderPlot({
chartSeries(df())
})
}
shinyApp(ui, server)
Related
I'm trying to update a table by changing the class of each variable (string or character). I have tried several methods but most of them just don't render something. With the method used in the code bellow, I can just change one time the type of the variable and then, the table is not reactive anymore.
Do you have an idea of what should I do?
library(DT)
library(shiny)
library(tidyverse)
server = shinyServer(function(input, output, session) {
current_stage <- reactiveValues(data=NULL)
mydata <- reactive({
df <- mtcars %>% rownames_to_column("model")
current_stage$data <- df
df
})
updateData = reactive({
df = mydata()
map(1:ncol(df), function(i){
if(length(input[[paste0("col", i)]])>0){
if (input[[paste0("col", i)]]=="num"){
df[,i] <<- unlist(df[,i]) %>% as.numeric
} else if (input[[paste0("col", i)]]=="cat"){
df[,i] <<- unlist(df[,i]) %>% as.character
}
}
})
#current_stage$data <- df
df
})
output$tableau <- DT::renderDataTable({
df <- current_stage$data
class <- map_df(df, typeof)
class <- gsub("double", "numeric", class)
class <- gsub("integer", "numeric", class)
tableSelectInput <- map(1:ncol(df),
function(i) {
if (class[i] =="numeric"){
opt1 <- "num"
opt2 <- "cat"
}else{
opt1 <- "cat"
opt2 <- "num"
}
selectInput(
inputId = paste0("col", i),
label = NULL, selected = opt1,
choices = c(opt1, opt2))
}
)
# I didn't find a more elegant way to turn '[[ ]]' in '[ ]'
l <- length(tableSelectInput)
selectin <- 1:l
type_cat <- 1:l
for (i in 1:l) {
selectin[i] = as.character(tableSelectInput[[i]])
pos=gregexpr("selected>",selectin[i])[[1]][1]
type_cat[i] = substr(selectin[i],(pos+9),(pos+11))
}
col_names = paste0(colnames(df), " <br/><em>(",type_cat,")</em><br/>", selectin)
isolate(DT::datatable(
current_stage$data,
options = list(
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
),
colnames =col_names,
editable = TRUE,
escape=FALSE,
selection = list(target = 'column')))
}, server=FALSE)
output$log <- renderPrint({
updateData()
})
output$log2 <- renderPrint({
map_df(updateData(),class)
})
})
ui = shinyUI(
fluidPage(
titlePanel("My Awesome Shiny App"),
# Show a plot of the generated distribution
mainPanel(
DT::DTOutput("tableau"),
# Show log
verbatimTextOutput("log"),
verbatimTextOutput("log2")
)
)
)
runApp(list(ui = ui, server = server))
I think there is something wrong with the input button call "col1", "col2", etc..
I should maybe create them in a different way but I don't I am just stuck for the moment. Someone could give me an advice?
Kevin
Update:
I have tried this code but it looks to have some trouble with Ajax:
DataTables warning: table id=DataTables_Table_0 - Invalid JSON response. For more information about this error, please see http://datatables.net/tn/1"
library(DT)
library(shiny)
library(tidyverse)
server = shinyServer(function(input, output, session) {
current_stage <- reactiveValues(data=NULL, init=NULL,n=0)
mydata <- reactive({
df <- mtcars %>% rownames_to_column("model")
current_stage$data <- df
current_stage$init <- df
df
})
updateData = reactive({
# input$refresh
# df$ID <<- c(df$ID[n], df$ID[-n])
df = mydata()
if( !is.null(current_stage$data)){
df <- current_stage$data
map(1:ncol(df), function(i){
if(length(input[[paste0("col", i)]])>0){
if (input[[paste0("col", i)]]=="num"){
df[,i] <<- unlist(current_stage$init [,i]) %>% as.numeric
} else if (input[[paste0("col", i)]]=="cat"){
df[,i] <<- unlist(current_stage$init [,i]) %>% as.character
}
}
})}
# if(length(input[[paste0("col", 1)]])>0){
# if (input[[paste0("col", 1)]]=="num"){
# # message(proxy)
# df[,1] <- unlist(df[,1]) %>% as.numeric
# # # mydata()[,1] <- paste(proxy[,1],"ok")
# } else if (input[[paste0("col", 1)]]=="cat"){
# # # message(proxy)
# df[,1] <- unlist(df[,1]) %>% as.character
# }}
current_stage$data <- df
df
})
output$tableau <- DT::renderDataTable({
#df <- mtcars %>% rownames_to_column("model")
df <- mydata()
class <- map_df(df, typeof)
class <- gsub("double", "numeric", class)
class <- gsub("integer", "numeric", class)
tableSelectInput <- map(1:ncol(df),
function(i) {
if (class[i] =="numeric"){
opt1 <- "num"
opt2 <- "cat"
}else{
opt1 <- "cat"
opt2 <- "num"
}
selectInput(
inputId = paste0("col", i),
label = NULL, selected = opt1,
choices = c(opt1, opt2))
}
)
# I didn't find a more elegant way to turn '[[ ]]' in '[ ]'
l <- length(tableSelectInput)
selectin <- 1:l
type_cat <- 1:l
for (i in 1:l) {
selectin[i] = as.character(tableSelectInput[[i]])
pos=gregexpr("selected>",selectin[i])[[1]][1]
type_cat[i] = substr(selectin[i],(pos+9),(pos+11))
}
col_names = paste0( colnames(df), " <br/><em>(",type_cat,")</em><br/>", selectin)
DT::datatable(isolate(
updateData()),
options = list(
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
),
colnames =col_names,
editable = TRUE,
escape=FALSE,
selection = list(target = 'column'))
}, server=FALSE)
proxy <- dataTableProxy('tableau')
observe({
replaceData(proxy, updateData(), resetPaging = TRUE )
})
output$log <- renderPrint({
updateData()
})
})
ui = shinyUI(
fluidPage(
titlePanel("My Awesome Shiny App"),
# Show a plot of the generated distribution
mainPanel(
DT::DTOutput("tableau"),
# Show log
verbatimTextOutput("log")
)
)
)
runApp(list(ui = ui, server = server))
I am trying to get input choices dependent on previous input.
require(shiny)
require(dplyr)
dat <- data.frame(id1 = c(rep("A",5),rep("B",5)),
id2 = c(rep("C",3),rep("D",3),rep("E",4)),
id3 = c(rep("F",2),rep("G",3),rep("H",5)), stringsAsFactors=FALSE)
ui <- shinyUI(fluidPage(
sidebarPanel(
selectInput('id1', 'ID1', choices = unique(dat$id1)),
selectInput("id2", "ID2", choices = unique(dat$id2)),
selectInput("id3", "ID3", choices = unique(dat$id3))
)
)
)
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
}
shinyApp(ui = ui, server = server)
This works for Input 1 and 2, however if i add another Input to observeEvent, the app chrashes. E.g:
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
},{
input$id3
temp <- dat %>% filter(id1%in%input$id1 & id2%in%input$id2)
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
How can I pass further Inputs to observeEvent ?
Update: I found a solution for the problem. I wrapped the Inputs in a reactive function, split the Output and passed it to the corresponding observeEvent functions.
server <- function(input, output,session) {
change <- reactive({
unlist(strsplit(paste(c(input$id1,input$id2,input$id3),collapse="|"),"|",fixed=TRUE))
})
observeEvent(input$id1,{
temp <- dat %>% filter(id1 %in% change()[1])
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
observeEvent(input$id2,{
temp <- dat %>% filter(id1 %in% change()[1] & id2 %in% change()[2])
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
Below a simplified version of my shiny app. I looked through some of the examples in the shinyjs package and I did not find anything that could help me.
I want to disable the Submit button if one of the data frame uploaded (in my real example) or selected has a specific column name (Col 3 in the example below).
Can this be done with shinyjs?
library(rhandsontable)
library(shiny)
library(shinyjs)
df1 <- data.frame(col1 = rnorm(20),
col2 = rep(T, 20))
df2 <- data.frame(col1 = rnorm(20),
col2 = rep(F, 20),
col3 = rnorm(20))
server <- function(input, output) {
values = reactiveValues()
values[["df1"]] <- df1
values[["df2"]] <- df2
df <- reactive({
if (input$df == "df1") {
df <- values[["df1"]]
} else {
df <- values[["df2"]]
}
df
})
observeEvent(input$Submit, {
shinyjs::alert("Thank you!")
})
#observe({
# if (is.null(input$df) || input$df == "df1") {
# shinyjs::disable("submit")
#} else {
# shinyjs::enable("submit")
#}
#})
output$out <- renderRHandsontable({
hot <- rhandsontable(df())
hot
})
}
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarLayout(sidebarPanel(
selectInput(
'df', 'Select data.frame:',
choices = c('df1', 'df2'),
selected = 'df1'
),
actionButton("Submit", label = "Submit")
),
mainPanel(rHandsontableOutput("out"))))
shinyApp(ui = ui, server = server)
First, there is a small typo: Notice the capital "S".
shinyjs::disable("Submit")
Edit: To check for "col3" take the following code:
observe({
if (is.null(input$df) || sum(colnames(df()) == "col3")) {
shinyjs::disable("Submit")
}else{
shinyjs::enable("Submit")
}
})
Same for enable of course.
I am trying to build an app in shiny that will be able to load a dataset in the server function and then based on the user choose and then if there is a factor variable to open check box using conditionalPanel. is there a way to output variable from the server as the condition of the condtionalPanel?
Here is what I tried:
library(shiny)
library(caret)
ui <- fluidPage(
selectInput('dataset', 'Select Dataset',
list(GermanCredit = "GermanCredit",
cars = "cars")),
conditionalPanel(
condition = "output.factorflag == true",
checkboxInput("UseFactor", "Add Factor Variable")
)
)
server <- function(input, output) {
# Loading the dataset
df <- reactive({
if(input$dataset == "GermanCredit"){
data("GermanCredit")
df <- GermanCredit
}else if(input$dataset == "cars"){
data(cars)
df <- cars
}
return(df)
})
# Loading the variables list
col_type <- reactive({
col_type <- rep(NA,ncol(df()))
for(i in 1:ncol(df())){
col_type[i] <- class(df()[,i])
}
return(col_type)
})
outputOptions(output, "factorflag", suspendWhenHidden = FALSE)
output$factorflag <- reactive({
if("factor" %in% col_type()){
factor.flag <- TRUE
} else {factor.flag <- FALSE}
}
)
}
shinyApp(ui = ui, server = server)
Thank you in advance!
You were almost there, you need to put the outputOptions after the declaration of factorflag. Just reengineered a bit your code:
library(shiny)
library(caret)
ui <- fluidPage(
selectInput('dataset', 'Select Dataset',
list(GermanCredit = "GermanCredit",
cars = "cars")),
conditionalPanel(
condition = "output.factorflag == true",
checkboxInput("UseFactor", "Add Factor Variable")
)
)
server <- function(input, output) {
# Loading the dataset
df <- reactive({
if(input$dataset == "GermanCredit"){
data("GermanCredit")
GermanCredit
}else {
data("cars")
cars
}
})
output$factorflag <- reactive("factor" %in% sapply(df(),class))
outputOptions(output, "factorflag", suspendWhenHidden = FALSE)
}
shinyApp(ui = ui, server = server)
I can create a data table in shiny that shows data for any individual buffalo but I can't figure out how to display all buffalo data at the same time. Any help is appreciated.
Sample Data:
cleanbuffalo <- data.frame(name = c("queen","toni","pepper"),
longitude = c(31.8,32,33),
latitude = c(-24,-25,-26))
Shiny UI:
shinyUI(navbarPage("Buffalo Migration", id ="nav",
tabPanel("Data",
fluidRow(
column(3,
selectInput("allnamesbuffalo", "Buffalo", c("All Buffalo" = "all buffalo", vars))
)
),
hr(),
DT::dataTableOutput("buffalotable")
)
)
)
Shiny Server:
shinyServer(function(input, output, session) {
observe({
allnamesbuffalo <- if (is.null(input$allnamesbuffalo)) character(0) else {
filter(cleanbuffalo, name %in% input$allnamesbuffalo) %>%
`$`('name') %>%
unique() %>%
sort()
}
})
output$buffalotable <- DT::renderDataTable({
df <- cleanbuffalo %>%
filter(
cleanbuffalo$name == input$allnamesbuffalo,
is.null(input$allnamesbuffalo) | name %in% cleanbuffalo$name
)
action <- DT::dataTableAjax(session,df)
DT::datatable(df, options = list(ajax = list(url = action)),
escape = FALSE)
})
})
Here is a working example. Note that I added stringsAsFactors=F in your data frame, otherwise you need to use levels(cleanbuffalo$name) to get the names.
library(shiny)
library(dplyr)
cleanbuffalo <- data.frame(name = c("queen","toni","pepper"),
longitude = c(31.8,32,33),
latitude = c(-24,-25,-26), stringsAsFactors = F)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("allnamesbuffalo", "Buffalo", c("all", cleanbuffalo$name))
),
mainPanel(
dataTableOutput("buffalotable")
)
)
))
server <- shinyServer(function(input, output, session) {
output$buffalotable <- renderDataTable({
names <- NULL
if (input$allnamesbuffalo == "all") {
names <- cleanbuffalo$name
} else {
names <- input$allnamesbuffalo
}
filter(cleanbuffalo, name %in% names)
})
})
shinyApp(ui = ui, server = server)