How to put 2 possibles eventReactive in only one variable - r

I am building a Shiny app which generate a dataframe from a database through the specific function my_function.
I want to use an eventReactive() to attribute the result of my_function depending on different inputs. My problem is that there are 2 ways to select these inputs which are structured in 2 different panels (I need this structure), so I have 2 actionButton that allow me to run my_function, and 1 variable for each eventReactive. Is there a way to put them in only 1 variable ?
df_all is a dataframe with several columns like "VAR1", "YEAR", "TYPE", "AGE" ... I need to filter depending on the inputs.
For the moment I have tried :
library(shiny)
library(shinydashboard)
library(DT)
library(dplyr)
df_all <- data.frame(
VAR1 = c(rep("A", 2), "B", "C")
YEAR = (rep(2001, 3), 2002)
TYPE = c("t1", "t2", "t2", "t1")
)
my_function <- function(arg1, arg2, arg3)
{
df = data.frame(
v1 = paste(arg1, arg2)
v2 = arg3
)
return(df)
}
shinyUI(dashboardPage(
dashboardHeader("title"),
dashboardSidebar(
sidebarMenu(id = "menu",
menuItem("Item1", tabName = "item1")
)),
dashboardBody(
tabItems(
tabItem(tabName = "item1",
selectInput(inputId = "var1", label = NULL, choices = c("A", "B", "C")),
tabsetPanel(
tabPanel("Item1-Panel1",
uiOutput("ui_year1"),
uiOutput("ui_type1"),
div(actionButton(inputId = "extra1", label = "Run", icon = icon("play")))),
tabPanel("Item1-Panel2",
uiOutput("ui_year2"),
uiOutput("ui_type2"),
div(actionButton(inputId = "extra2", label = "Run", icon = icon("play")))),
tabPanel("Item1-Panel3",
DT::dataTableOutput("tableau_ext1"),
DT::dataTableOutput("tableau_ext2"),
downloadButton("downloadCSV", "Save (CSV)"))
))))))
shinyServer(function(input, output) {
output$ui_year1 <- renderUI({
checkboxGroupInput(inputId = "year1", label = NULL, choices = df_all %>% filter(CULTURE == input$var1) %>% select(YEAR) %>% distinct() %>% pull()
})
output$ui_type1 <- renderUI({
checkboxGroupInput(inputId = "type1", label = NULL, choices = sort(df_all %>% filter(VAR1 == input$cult, YEAR %in% input$year1) %>% select(TYPE) %>% distinct() %>% pull())
})
output$ui_year2 <- renderUI({
checkboxGroupInput(inputId = "year2", label = NULL, choices = df_all %>% filter(VAR1 == input$var1) %>% select(YEAR) %>% distinct() %>% pull()
})
output$ui_type2 <- renderUI({
checkboxGroupInput(inputId = "type2", label = NULL, choices = sort(df_all %>% filter(VAR1 == input$cult, YEAR %in% input$year2) %>% select(TYPE) %>% distinct() %>% pull())
})
df1 <- eventReactive(input$extra1, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year1),
arg3 = as.character(input$type1))
})
df2 <- eventReactive(input$extra2, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year2),
arg3 = as.character(input$type2))
})
})
I tried to attribute the 2 eventReactive in 1 variable df, because I want to see and save the dataframe generated by my_function with :
shinyServer([...]
df <- eventReactive(input$extra1, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year1),
arg3 = as.character(input$type1))
})
df <- eventReactive(input$extra2, {
my_function(arg1 = input$cult,
arg2 = as.numeric(input$year2),
arg3 = as.character(input$type2))
})
output$tableau_ext1 <- DT::renderDataTable({
df()
})
output$downloadCSV <- downloadHandler(
filename = function() {
paste0(input$year1, "_", input$type1, ".csv")
},
content = function(file) {
write.csv2(df(), file, row.names = FALSE)
}
)
)
But it didn't worked... If someone knows how to solve my problem, I will be grateful for his help :)

Building off of this thread the following seems to achieve the desired behavior (if I understand everything correctly):
library(shiny)
my_fun <- function() {
x <- sample(x=nrow(iris), size = 6)
x
}
ui <- fluidPage(
tabsetPanel(
tabPanel(title = "panel1",
actionButton("go1", "go 1")),
tabPanel(title = "panel2",
actionButton("go2", "go 2"))
),
mainPanel(dataTableOutput("tab"))
)
server <- function(input, output) {
df <- eventReactive(c(input$go1, input$go2), {
iris[my_fun(),]
}, ignoreNULL = FALSE, ignoreInit = TRUE)
output$tab <- renderDataTable({
df()
})
}
shinyApp(ui, server)
See also ?eventReactive for the ignoreNULL and ignoreInit options.
Edit: Two functions, one eventReactive, and keep track of tabs to know what to render.
library(shiny)
library(dplyr)
go1_fun <- function() {
x <- filter(iris, Species == "setosa") %>% head
x
}
go2_fun <- function() {
x <- filter(iris, Species == "virginica") %>% head
x
}
ui <- fluidPage(
tabsetPanel(id = "tabs",
tabPanel(title = "panel1",
actionButton("go1", "go 1")),
tabPanel(title = "panel2",
actionButton("go2", "go 2"))
),
mainPanel(dataTableOutput("tab"))
)
server <- function(input, output, session) {
df1 <- reactive({
if (req(input$go1)) {
x <- go1_fun()
}
return(x)
})
df2 <- reactive({
if (req(input$go2)) {
x <- go2_fun()
}
return(x)
})
tab_to_render <- eventReactive(c(input$go1, input$go2), {
if (input$tabs == "panel1") x <- df1()
if (input$tabs == "panel2") x <- df2()
return(x)
}, ignoreNULL = FALSE, ignoreInit = TRUE)
output$tab <- renderDataTable({
tab_to_render()
})
}
shinyApp(ui, server)

Related

isolate reactive function for displaying selections and filters after action button

I am trying to create a reactive function with the isolate command from the following code in the ui.R file into the server.R file where the data table only populates after the user has inputed their selections and filters only.
Right now the data table just populates on its own after running the filters and selections without having to click on the Run Query button.
Any help would be appreciated!
actionButton("runit", "RUN QUERY")
Thank you so much!
Code below:
ui.R
library(DT)
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "CL Pivot"),
dashboardSidebar(
actionButton("runit", "RUN QUERY"),
h4(HTML("&nbsp"), "Select Table Rows"),
uiOutput("rowSelect"),
hr(),
h4(HTML("&nbsp"), "Select Table Columns"),
uiOutput("colSelect"),
hr(),
h4(HTML("&nbsp"), "Select Table Cell Fill"),
selectizeInput(
inputId = "funChoices",
label = NULL,
multiple = FALSE,
choices = c("Count", "Average", "Median", "Sum", "Maximum", "Minimum"),
selected = c()
),
hr(),
h4(HTML("&nbsp"), "Filter Data Set"),
uiOutput("hairColorFilter"),
uiOutput("skinColorFilter")
),
dashboardBody(dataTableOutput("data"))
)
}
server.R
library(DT)
library(shiny)
library(shinydashboard)
library(dplyr)
library(dbplyr)
library(tidyverse)
library(DBI)
data <- starwars
# Convenience Function to Make Upcoming Chain Less Messy
fun_across <- function(cols, fun, fun_name) {
fun_list <- list(fun)
names(fun_list) <- fun_name
across(all_of(cols), fun_list, .names = "{fn}_{col}")
}
shinyServer(function(input, output, session) {
# Identify Measures and Dimensions -------------
dimensions <- colnames(data)[!sapply(data, is.numeric)]
measures <- colnames(data)[sapply(data, is.numeric)]
# Identify Filter Choices -----------------------------------------------
hairColorChoices <- sort(unique(data$hair_color))
skinColorChoices <- sort(unique(data$skin_color))
# Define User Inputs ----------------------------------------------------
output$rowSelect <- renderUI({
selectizeInput(
inputId = "rowChoices",
label = NULL,
multiple = TRUE,
choices = dimensions,
selected = c()
)
})
output$colSelect <- renderUI({
selectizeInput(
inputId = "colChoices",
label = NULL,
multiple = TRUE,
choices = measures,
selected = c()
)
})
output$hairColorFilter <- renderUI({
sidebarMenu(
menuItem(
text = "Hair Color",
icon = icon("briefcase"),
checkboxGroupInput(
inputId = "hairColorChoices",
label = NULL,
choices = hairColorChoices,
selected = hairColorChoices
)
)
)
})
output$skinColorFilter <- renderUI({
sidebarMenu(
menuItem(
text = "Skin Color",
icon = icon("thermometer-half"),
checkboxGroupInput(
inputId = "skinColorChoices",
label = NULL,
choices = skinColorChoices,
selected = skinColorChoices
)
)
)
})
# Define Reactive Functions ---------------------------------------------
pairColFuns <- reactive({
colChoices <- input$colChoices
names(colChoices) <- input$funChoices
return(colChoices)
})
# Construct DataFrame Based on User Inputs
output$data <- renderDataTable({
colChoices <- pairColFuns()
rowChoices <- input$rowChoices
countCols <- unname(colChoices[names(colChoices) == "Count"])
averageCols <- unname(colChoices[names(colChoices) == "Average"])
medianCols <- unname(colChoices[names(colChoices) == "Median"])
sumCols <- unname(colChoices[names(colChoices) == "Sum"])
maxCols <- unname(colChoices[names(colChoices) == "Maximum"])
minCols <- unname(colChoices[names(colChoices) == "Minimum"])
displayTable <- as_tibble(data) %>%
filter(
hair_color %in% input$hairColorChoices,
skin_color %in% input$skinColorChoices
) %>%
group_by(across(all_of(rowChoices))) %>%
summarize(
# Once again we've sacrificed a bit of elegance for clarity. This chunk will
# apply the specified function to whichever columns are included in the
# specified variable. If the variable is empty, no operation is performed.
fun_across({{countCols}}, length, "count"),
fun_across({{averageCols}}, ~mean(.x, na.rm = TRUE), "average"),
fun_across({{medianCols}}, ~median(.x, na.rm = TRUE), "median"),
fun_across({{sumCols}}, ~sum(.x, na.rm = TRUE), "total"),
fun_across({{maxCols}}, ~max(.x, na.rm = TRUE), "max"),
fun_across({{minCols}}, ~min(.x, na.rm = TRUE), "min"),
.groups = "drop"
)
return(displayTable)
})
})
I would split the table rendering and data processing, then you can use the eventReactive approach. This saves you to wrap every input into isolate.
First make an eventReactive that calculates your data. It only updates if the first reactive/input changes. Then you can use this to render your table:
table_data <- eventReactive(input$runit, {
colChoices <- pairColFuns()
rowChoices <- input$rowChoices
countCols <- unname(colChoices[names(colChoices) == "Count"])
averageCols <- unname(colChoices[names(colChoices) == "Average"])
medianCols <- unname(colChoices[names(colChoices) == "Median"])
sumCols <- unname(colChoices[names(colChoices) == "Sum"])
maxCols <- unname(colChoices[names(colChoices) == "Maximum"])
minCols <- unname(colChoices[names(colChoices) == "Minimum"])
displayTable <- as_tibble(data) %>%
filter(
hair_color %in% input$hairColorChoices,
skin_color %in% input$skinColorChoices
) %>%
group_by(across(all_of(rowChoices))) %>%
summarize(
# Once again we've sacrificed a bit of elegance for clarity. This chunk will
# apply the specified function to whichever columns are included in the
# specified variable. If the variable is empty, no operation is performed.
fun_across({{countCols}}, length, "count"),
fun_across({{averageCols}}, ~mean(.x, na.rm = TRUE), "average"),
fun_across({{medianCols}}, ~median(.x, na.rm = TRUE), "median"),
fun_across({{sumCols}}, ~sum(.x, na.rm = TRUE), "total"),
fun_across({{maxCols}}, ~max(.x, na.rm = TRUE), "max"),
fun_across({{minCols}}, ~min(.x, na.rm = TRUE), "min"),
.groups = "drop"
)
displayTable
})
output$data <- renderDataTable({
table_data()
})
You need to isolate() all inputs that shouldn't trigger the event, and you could use req() to enable the submit button:
pairColFuns <- reactive({
colChoices <- isolate(input$colChoices) #isolated
names(colChoices) <- isolate(input$funChoices) #isolated
return(colChoices)
})
# Construct DataFrame Based on User Inputs
output$data <- renderDataTable({
req(input$runit) # submit button should trigger
colChoices <- pairColFuns()
rowChoices <- isolate(input$rowChoices) #isolated
countCols <- unname(colChoices[names(colChoices) == "Count"])
averageCols <- unname(colChoices[names(colChoices) == "Average"])
medianCols <- unname(colChoices[names(colChoices) == "Median"])
sumCols <- unname(colChoices[names(colChoices) == "Sum"])
maxCols <- unname(colChoices[names(colChoices) == "Maximum"])
minCols <- unname(colChoices[names(colChoices) == "Minimum"])
displayTable <- as_tibble(data) %>%
filter(
hair_color %in% isolate(input$hairColorChoices), #isolated
skin_color %in% isolate(input$skinColorChoices) #isolated
...

Restyling traces using plotlyProxy in a scatterplot is unstable when points are colored according to category

I have a Shiny app that builds a scatterplot and highlights the clicked points by restyling the marker outline via plotlyProxy.
The app also subsets the data and moves the entries corresponding to the clicked points from the original "Data table" to an "Outlier table".
This seems to work fine when the markers are all the same color, or when they are colored by a continuous variable. But when I color the points by a categorical variable (like "Species"), it has a weird behavior, restyling a marker from each category instead of the clicked one. The data subsets correctly.
I think the restyle function should update all traces unless specified otherwise, so I am not sure where exactly lies the problem.
Here is my code:
library(plotly)
library(DT)
ui <- fluidPage(
mainPanel(
fluidRow(
div(
column(
width = 2,
uiOutput('chartOptions')),
column(width = 5,
h3("Scatter plot"),
plotlyOutput("scatterplot"),
verbatimTextOutput("click")
)
)
),
hr(),
div(
column(width = 6,
h2("Data Table"),
div(
DT::dataTableOutput(outputId = "table_keep"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;")),
column(width = 6,
h2("Outlier Data"),
div(
DT::dataTableOutput(outputId = "table_outliers"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;"))
)
))
server <- function(input, output, session){
datasetInput <- reactive({
df <- iris
return(df)
})
output$chartOptions <- renderUI({#choose variables to plot
if(is.null(datasetInput())){}
else {
list(
selectizeInput("xAxisSelector", "X Axis Variable",
colnames(datasetInput())),
selectizeInput("yAxisSelector", "Y Axis Variable",
colnames(datasetInput())),
selectizeInput("colorBySelector", "Color By:",
c(c("Do not color",colnames(datasetInput()))))
)
}
})
vals <- reactiveValues(#define reactive values for:
data = NULL,
data_keep = NULL,
data_exclude = NULL)
observe({
vals$data <- datasetInput()
vals$data_keep <- datasetInput()
})
## Datatable
output$table_keep <- renderDT({
vals$data_keep
},options = list(pageLength = 5))
output$table_outliers <- renderDT({
vals$data_exclude
},options = list(pageLength = 5))
# mechanism for managing selected points
keys <- reactiveVal()
observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
req(vals$data)
is_outlier <- NULL
key_new <- event_data("plotly_click", source = "outliers")$key
key_old <- keys()
if (key_new %in% key_old){
keys(setdiff(key_old, key_new))
} else {
keys(c(key_new, key_old))
}
is_outlier <- rownames(vals$data) %in% keys()
vals$data_keep <- vals$data[!is_outlier, ]
vals$data_exclude <- vals$data[is_outlier, ]
plotlyProxy("scatterplot", session) %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier,'black','grey')),
width = 2
))
)
})
observeEvent(event_data("plotly_doubleclick", source = "outliers"), {
req(vals$data)
keys(NULL)
vals$data_keep <- vals$data
vals$data_exclude <- NULL
plotlyProxy("scatterplot", session) %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = 'grey',
width = 2
)
))
})
output$scatterplot <- renderPlotly({
req(vals$data,input$xAxisSelector,input$yAxisSelector)
dat <- vals$data
key <- rownames(vals$data)
x <- input$xAxisSelector
y <- input$yAxisSelector
if(input$colorBySelector != "Do not color"){
color <- dat[, input$colorBySelector]
}else{
color <- "orange"
}
scatterplot <- dat %>%
plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
add_markers(key = key,color = color,
marker = list(size = 10, line = list(
color = 'grey',
width = 2
))) %>%
layout(showlegend = FALSE)
return(scatterplot)
})
output$click <- renderPrint({#click event data
d <- event_data("plotly_click", source = "outliers")
if (is.null(d)) "click events appear here (double-click to clear)" else d
})
}
shinyApp(ui, server)
The problem with your above code is that no traceIndices argument is provided for restyle. Please see this.
In your example, once you switch coloring to the factor Species plotly no longer creates one trace, but three. This happens in JS so counting is done from 0 to 2.
To restyle those traces you can address them via curveNumber (in this case 0:2) and pointNumber (50 data points in each trace 0:49)
With a single trace your example works as your key and your trace have the same length (150).
As your provided code is pretty long I just focused on the "Species" problem. It won't work in all other cases, but you should be able to deduce a more general approach from it:
library(shiny)
library(plotly)
library(DT)
ui <- fluidPage(
mainPanel(
fluidRow(
div(
column(
width = 2,
uiOutput('chartOptions')),
column(width = 5,
h3("Scatter plot"),
plotlyOutput("scatterplot"),
verbatimTextOutput("click")
)
)
),
hr(),
div(
column(width = 6,
h2("Data Table"),
div(
DT::dataTableOutput(outputId = "table_keep"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;")),
column(width = 6,
h2("Outlier Data"),
div(
DT::dataTableOutput(outputId = "table_outliers"),
style = "height:auto; overflow-y: scroll;overflow-x: scroll;"))
)
))
server <- function(input, output, session){
datasetInput <- reactive({
df <- iris
df$is_outlier <- FALSE
return(df)
})
output$chartOptions <- renderUI({#choose variables to plot
if(is.null(datasetInput())){}
else {
list(
selectizeInput("xAxisSelector", "X Axis Variable",
colnames(datasetInput())),
selectizeInput("yAxisSelector", "Y Axis Variable",
colnames(datasetInput())),
selectizeInput("colorBySelector", "Color By:",
c(c("Do not color",colnames(datasetInput()))))
)
}
})
vals <- reactiveValues(#define reactive values for:
data = NULL,
data_keep = NULL,
data_exclude = NULL)
observe({
vals$data <- datasetInput()
vals$data_keep <- datasetInput()
})
## Datatable
output$table_keep <- renderDT({
vals$data_keep
},options = list(pageLength = 5))
output$table_outliers <- renderDT({
vals$data_exclude
},options = list(pageLength = 5))
# mechanism for managing selected points
keys <- reactiveVal()
myPlotlyProxy <- plotlyProxy("scatterplot", session)
observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
req(vals$data)
is_outlier <- NULL
plotlyEventData <- event_data("plotly_click", source = "outliers")
key_new <- plotlyEventData$key
key_old <- keys()
if (key_new %in% key_old){
keys(setdiff(key_old, key_new))
} else {
keys(c(key_new, key_old))
}
vals$data[keys(),]$is_outlier <- TRUE
is_outlier <- vals$data$is_outlier
vals$data_keep <- vals$data[!is_outlier, ]
vals$data_exclude <- vals$data[is_outlier, ]
print(paste("pointNumber:", plotlyEventData$pointNumber))
print(paste("curveNumber:", plotlyEventData$curveNumber))
plotlyProxyInvoke(
myPlotlyProxy,
"restyle",
list(marker.line = list(
color = as.vector(ifelse(vals$data[vals$data$Species %in% vals$data[plotlyEventData$key, ]$Species, ]$is_outlier,'black','grey')),
width = 2
)), plotlyEventData$curveNumber
)
})
observeEvent(event_data("plotly_doubleclick", source = "outliers"), {
req(vals$data)
keys(NULL)
vals$data_keep <- vals$data
vals$data_exclude <- NULL
plotlyProxyInvoke(
myPlotlyProxy,
"restyle",
list(marker.line = list(
color = 'grey',
width = 2
)
))
})
output$scatterplot <- renderPlotly({
req(datasetInput(),input$xAxisSelector,input$yAxisSelector)
dat <- datasetInput()
key <- rownames(dat)
x <- input$xAxisSelector
y <- input$yAxisSelector
if(input$colorBySelector != "Do not color"){
color <- dat[, input$colorBySelector]
}else{
color <- "orange"
}
scatterplot <- dat %>%
plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
add_markers(key = key,color = color,
marker = list(size = 10, line = list(
color = 'grey',
width = 2
))) %>%
layout(showlegend = FALSE)
return(scatterplot)
})
output$click <- renderPrint({#click event data
d <- event_data("plotly_click", source = "outliers")
if (is.null(d)) "click events appear here (double-click to clear)" else d
})
}
shinyApp(ui, server)
As a quick workaround, to avoid creating 3 traces, I simply converted the categorical variable assigned to color to numeric, and I hid the colorbar, so the output looks like this:
output$scatterplot <- renderPlotly({
req(vals$data,input$xAxisSelector,input$yAxisSelector)
dat <- vals$data
key <- rownames(vals$data)
x <- input$xAxisSelector
y <- input$yAxisSelector
if(input$colorBySelector != "Do not color"){
color <- as.numeric(dat[, input$colorBySelector])
}else{
color <- "orange"
}
scatterplot <- dat %>%
plot_ly(x = dat[,x], y = dat[,y], source = "outliers") %>%
add_markers(key = key,color = color,
marker = list(size = 10, line = list(
color = 'grey',
width = 2
))) %>%
layout(showlegend = FALSE) %>%
hide_colorbar()%>%
event_register("plotly_click")
return(scatterplot)
})
Update:
Another solution that I found is to make a loop of plotly proxies for each trace / category in the click event.
So the click event looks like this:
observeEvent(event_data("plotly_click", source = "outliers", priority = "event"), {
req(vals$data)
is_outlier <- NULL
key_new <- event_data("plotly_click", source = "outliers")$key
key_old <- keys()
#keys(c(key_new, key_old))
if (key_new %in% key_old){
keys(setdiff(key_old, key_new))
} else {
keys(c(key_new, key_old))
}
is_outlier <- rownames(vals$data) %in% keys()
vals$data_keep <- vals$data[!is_outlier, ]
vals$data_exclude <- vals$data[is_outlier, ]
indices <- list()
p <- plotlyProxy("scatterplot", session)
if(input$colorBySelector != "Do not color"){
if(is.factor(vals$data[,input$colorBySelector])){
for (i in 1:length(levels(vals$data[,input$colorBySelector]))){
indices[[i]] <- rownames(vals$data[which(vals$data[,input$colorBySelector] == levels(vals$data[,input$colorBySelector])[i]), ]) #retrieve indices for each category
plotlyProxyInvoke(p,
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier[as.numeric(indices[[i]])],'black','grey')),
width = 2
)), c(i-1) #specify the trace (traces are indexed from 0)
)
}
}else{
p %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier,'black','grey')),
width = 2
))
)
}
}else{
p %>%
plotlyProxyInvoke(
"restyle",
list(marker.line = list(
color = as.vector(ifelse(is_outlier,'black','grey')),
width = 2
))
)
}
})

Using reactive conditions inside an eventReactive

I am building a Shiny app which generates a dataframe through a specific function. I want to use an eventReactive() to attribute the result of this function depending on a reactive input.
I tried to follow this answer : Working with a reactive() dataframe inside eventReactive()? but when I want to use an observeEvent, it always generate an error Warning: Error in $.shinyoutput: Reading objects from shinyoutput object not allowed.
My first try was as follows with an example :
DATA and LIBRAIRIES
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
df <- data.frame(c1 = c(rep("A", 3), rep("B", 4), "on"),
c2 = 1:8,
c3 = c(2002,2003,2002,2004,2002,2003,2005, 2005))
my_function <- function(arg1, arg2)
{
df = data.frame(
v1 = mean(df %>% filter(c1 == arg1) %>% select(c2) %>% pull()),
v2 = arg2
)
return(df)
}
UI
ui <- fluidPage(
selectInput(inputId = "input1", label = NULL,
choices = c("A", "B"),
selected = "A"),
selectInput(inputId = "input2", label = NULL,
choices = c("on", "off"),
selected = "on"),
uiOutput("ui_year"),
uiOutput("fct_extract"),
actionButton(inputId = "extraction", label = "Go", icon = icon("play")),
uiOutput("col_visu")
)
SERVER
server <- function(input, output) {
output$ui_year <- renderUI({
checkboxGroupInput(inputId = "year1", label = NULL, choices = df %>% filter(c1 == "A") %>% select(c3) %>% pull())
})
output$fct_extract <- renderUI({
shinyWidgets::radioGroupButtons(
inputId = "fct_extract",
label = NULL,
selected = "B1",
choices = c("B0", "B1"),
status = "warning")
})
fct_extr <- reactive(output$fct_extract)
df2 <- eventReactive(input$extraction, {
if (fct_extr() == "B0")
{
my_function(arg1 = input$input1,
arg2 = input$input1)
} else if (fct_extr() == "B1")
{
my_function(arg1 = input$input2,
arg2 = input$input1)
}
})
columns <- reactive(colnames(df2()))
output$col_visu <- renderUI({
shinyWidgets::multiInput(
inputId = "col_visu", width = "400px",
label = h2("Selection :"),
choices = columns())
})
}
When I put the actionButton, it generates the message : Reading objects from shinyoutput object not allowed. and nothing else happened
So I tried in the SERVER :
fct_extr <- reactive(output$fct_extract)
df2 <- observeEvent(input$extraction, {
if (fct_extr() == "B0")
{
my_function(arg1 = input$input1,
arg2 = input$input1)
} else if (fct_extr() == "B1")
{
my_function(arg1 = input$input2,
arg2 = input$input1)
}
})
}
Here I got the message : argument "x" is missing, with no default instead of the result of col_visu and when I put the actionButton, the app closed
In addition, when I don't try to add the choice with fct_extra, it works :
df2 <- eventReactive(input$extraction, {
my_function(arg1 = input$input1,
arg2 = input$input1)
})
columns <- reactive(colnames(df2()))
output$col_visu <- renderUI({
shinyWidgets::multiInput(
inputId = "col_visu", width = "400px",
label = h2("Selection :"),
choices = columns())
})
Thank you to the one of you who will explain how to include a reactive inside an eventReactive :)
You define the following dynamic radioGroupButton:
output$fct_extract <- renderUI({
shinyWidgets::radioGroupButtons(
inputId = "fct_extract",
label = NULL,
selected = "B1",
choices = c("B0", "B1"),
status = "warning")
})
This defines a UI element whose value is accessible in input with the key set to the element's inputId. So, in this case, the value is under input$fct_extract
Note that this is independent of the name of your UI object in the output, which just happens to also be fct_extract. This naming is confusing and probably caused your error: trying to access the value of the widget in output$fct_extract when it is actually in input$fct_extract.
To fix your code, replace the illegal line (fct_extr <- reactive(output$fct_extract)) with the correct:
fct_extr <- reactive(input$fct_extract)
In fact, this reactive is redundant since input$fct_extract is already a reactive value. So just ditch your reactive entirely and use input$fct_extract (without brackets) where you would have used fct_extr()
I made a few edits to your code to get it working. Here are the actual code changes though for your question:
mean(df... instead of mean(a...
my_function <- function(arg1, arg2)
{
df = data.frame(
v1 = mean(df %>% filter(c1 == arg1) %>% select(c2) %>% pull()),
v2 = arg2
)
return(df)
}
and then removing the line fct_extr <- reactive(output$fct_extract). I think you meant to use reactiveVal but it's unnecessary here. I just replaced:
if (fct_extr() == "B0")... else if (fct_extr() == "B1") with
if (input$fct_extr == "B0")... else if (input$fct_extr == "B1")
Full code below.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
df <- data.frame(c1 = c(rep("A", 3), rep("B", 4), "on"),
c2 = 1:8,
c3 = c(2002,2003,2002,2004,2002,2003,2005, 2005))
my_function <- function(arg1, arg2)
{
df = data.frame(
v1 = mean(df %>% filter(c1 == arg1) %>% select(c2) %>% pull()),
v2 = arg2
)
return(df)
}
ui <- fluidPage(
selectInput(inputId = "input1", label = NULL,
choices = c("A", "B"),
selected = "A"),
selectInput(inputId = "input2", label = NULL,
choices = c("on", "off"),
selected = "on"),
uiOutput("ui_year"),
uiOutput("fct_extract"),
actionButton(inputId = "extraction", label = "Go", icon = icon("play")),
uiOutput("col_visu")
)
server <- function(input, output) {
output$ui_year <- renderUI({
checkboxGroupInput(inputId = "year1", label = NULL, choices = df %>% filter(c1 == "A") %>% select(c3) %>% pull())
})
output$fct_extract <- renderUI({
shinyWidgets::radioGroupButtons(
inputId = "fct_extract",
label = NULL,
selected = "B1",
choices = c("B0", "B1"),
status = "warning")
})
# fct_extr <- reactiveVal(input$fct_extract)
df2 <- eventReactive(input$extraction, {
if (input$fct_extract == "B0")
{
my_function(arg1 = input$input1,
arg2 = input$input1)
} else if (input$fct_extract == "B1")
{
my_function(arg1 = input$input2,
arg2 = input$input1)
}
})
columns <- reactive(colnames(df2()))
output$col_visu <- renderUI({
shinyWidgets::multiInput(
inputId = "col_visu", width = "400px",
label = h2("Selection :"),
choices = columns())
})
}
shinyApp(ui, server)

R - Turn character variable in numeric with DT and shiny

It's been 2 days that I'm trying to convert dynamically character variables in numerics and vice-versa in a shiny datatable.
Here I send you a reproductible exemple:
library(DT)
library(shiny)
library(tidyverse)
server = shinyServer(function(input, output) {
mydata <- reactive({
df <- mtcars %>% rownames_to_column("model")
df[,2] <- ifelse(input[[paste0("col", 2)]]=="num",unlist(df[,2]) %>%
as.numeric, unlist(df[,2]) %>% as.character)
df
})
output$tableau <- DT::renderDT({
#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, sep=" ")
DT::datatable(
df,
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({
#To check if it works
mydata()[,2]
})
})
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))
Issue:
When I'm trying to change the selectinput for the 2 column. In the renderPrint, we see that the type of format doesn't change.
Some one could help me please?

Error: "Invalid JSON response" when I try to update data with DT::replaceData() [shiny]

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))

Resources