Change dataframe in Shiny App based on Reactable checkboxes - r

This demo R script has two data frames, that are displayed by two Reactable tables.
When the number of checkboxes in the Iris table exceeds 2, the warning message in the msg table should change.
Here is my non-working attempt
library("reactable")
library("shiny")
library("tidyverse")
max_num_boxes_checked <- 2
warn_last_update_df <- tibble(
warn_msg = "Not too many selected",
last_updated_msg = "Last updated: Sept 23, 2020"
)
ui <- fluidPage(
reactableOutput("msg"),
reactableOutput("table")
)
server <- function(input, output, session){
output$msg <- renderReactable({
reactable(warn_last_update_df,
columns = list(
"last_updated_msg" = colDef(
align = "right",
name = ""
),
"warn_msg" = colDef(
name = ""
)
))
})
output$table <- renderReactable({
reactable(iris,
onClick = "select",
selection = "multiple")
})
observeEvent(input$table,
{
state <- req(getReactableState("table"))
# Get vector of which boxes are checked (their number)
boxes_checked <- state[[4]]
# Number of boxes checked
num_boxes_checked <- (length(boxes_checked))
# Change warning msg based on num checkboxes > 2
if (num_boxes_checked > max_num_boxes_checked) {
warn_last_update_df$warn_msg <- paste("Wow! More than ", max_num_boxes_checked, "checked")
updateReactable("msg")
}
}
)
}
shinyApp(ui, server)

It appears that updateReactable("msg") is not working. A workaround would be to use reactiveValues for the tibble warn_last_update_df. Here is a working code.
max_num_boxes_checked <- 2
warn_last_update_df <- tibble(
warn_msg = "Not too many selected",
last_updated_msg = "Last updated: Sept 26, 2020"
)
ui <- fluidPage(
reactableOutput("msg"),
reactableOutput("table")
)
server <- function(input, output, session){
selected <- reactiveValues(vec=NULL)
DF1 <- reactiveValues(data=NULL)
observe({
selected$vec <- getReactableState("table", "selected")
DF1$data <- warn_last_update_df
})
output$msg <- renderReactable({
reactable(DF1$data, #warn_last_update_df,
columns = list(
"last_updated_msg" = colDef(
align = "right",
name = ""
),
"warn_msg" = colDef(
name = ""
)
))
})
output$table <- renderReactable({
reactable(iris,
onClick = "select",
selection = "multiple")
})
observeEvent(selected$vec,{
# Change warning msg based on num checkboxes > 2
if (length(selected$vec) > max_num_boxes_checked) {
#warn_last_update_df$warn_msg <- paste0("Wow! More than 2 rows checked")
#updateReactable("msg",selected = NA) ## this is not working
DF1$data[1,1] <- paste0("Wow! More than ", max_num_boxes_checked, " rows checked")
}
})
}
shinyApp(ui, server)

Related

How can I put the conditional while rendering the datatable in rshiny

I am trying to achieve following steps while working on the rshiny :
1: creating dynamic tabs on click of the cell : DONE
2: creating dynamic subtabs on click of the parent tab : DONE
3: need to render the datatable based on the following condition :
if ( are matching or == ) then display the data accordingly.
please find the below code for your reference :
library(shiny)
library(DT)
library(shinyWidgets)
shinyApp(
ui <- fluidPage(
headerPanel("Product Details"),
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(type = "tabs", id="myTabs",
tabPanel("Company Details", DT::dataTableOutput("data")),
)
)
),
server <- function(input, output, session) {
readXLSXFile <- readxl::read_excel(paste("sample_data.xlsx"),1)
data <- head(readXLSXFile)
tabIndex <- reactiveVal(0)
myValue <- reactiveValues(companyDetails = '')
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
df <- reactiveValues(data = data.frame(
DealID = data[1],
Details = shinyInput(actionButton, length(data)+1,
'button_', label = "Edit",
onclick = 'Shiny.onInputChange(\"select_button\", this.id)',
style = "color: black;
background-color: white",
class="btn-success",
#icon = icon("edit")
),
Tickers = data[3],
stringsAsFactors = FALSE
# row.names = 1:length(data)
))
output$data <- DT::renderDataTable(
df$data, server = FALSE, escape = FALSE, selection = 'none'
)
observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
myValue$companyDetails <<- paste('click on ',df$data[selectedRow,1])
stringVal <- c(unlist(strsplit(df$data[selectedRow,3],",")))
topTabValue <- c(df$data[selectedRow,1])
subTabData <- c()
datafromsecondRow <- c(data[2][1])
subTabDataOutput <- c()
data_frame_mod <- c()
appendTab("myTabs",
tabPanel(topTabValue,br(),
actionButton("removeTab", "Remove this Tab", icon = icon("remove")),br(),br(),
tabsetPanel(type="tabs", id=c(topTabValue)
),
),
# select=TRUE
)
lapply(1:length(stringVal), function(i) {
subTabData = stringVal[i]
readXLSXFileSheetTwo <- readxl::read_excel(paste("sample_data.xlsx"),2)
dataFileTwo <- head(readXLSXFileSheetTwo)
# print(c(dataFileTwo$Ticker) %in% c(subTabData))
# print("+++++++++++++++++++")
# print(subTabData)
appendTab(c(topTabValue),
tabPanel(subTabData, br(),
tags$h5(paste("You are at -> ",subTabData)),
output$subTabData <- DT::renderDataTable({
dataFileTwo[c(dataFileTwo$Ticker) %in% c(subTabData),TRUE]
datatable(dataFileTwo, options = list(dom = 'ft'),escape=FALSE)
})
),
# print(c(subTabData))
)
observeEvent(input$subTabData, {
appendTab(subTabData,
tabPanel(topTabValue,br(),
actionButton("removeTab", "Remove this Tab", icon = icon("remove")),br(),br(),
tabsetPanel(type="tabs", id=c(topTabValue)
),
),
)
})
})
})
observeEvent(input$removeTab, {
removeTab("myTabs", target=input$myTabs)
})
output$myText <- renderText({
myValue$companyDetails
})
}
)
Please help me to solve this point.
output$subTabData <- DT::renderDataTable({
**dataFileTwo[c(dataFileTwo$Ticker) %in% c(subTabData),TRUE]**
datatable(dataFileTwo, options = list(dom = 'ft'),escape=FALSE)
})
It is still rendering the whole dataset.. I stuck on conditional render the data on click of subtab.

How to get reactive values from a click on shiny?

Hello and thanks for reading me. I am working on a small app that shows a table in shiny with the "reactable" library, but I would like to obtain a reactive value when I click on a certain cell, with which I can get a text output type "paste0("you chose" , value0)", but so far I haven't found a correct way to do it. Does anyone have any idea how to do that
The actual code im using is:
shinyApp(
ui = fluidPage(
reactableOutput("tabla")
),
server = function(input, output){
output$tabla <- renderReactable({
iris |>
reactable(
columns = list(
Species = colDef(cell = function(value) {
htmltools::tags$a(href = value, target = "_blank", value)
})
)
)
})
}
)
library(shiny)
library(reactable)
shinyApp(
ui = fluidPage(
reactableOutput("tabla"),
verbatimTextOutput("selected")
),
server = function(input, output){
output$tabla <- renderReactable({
iris |>
reactable(
columns = list(
Species = colDef(cell = function(value) {
htmltools::tags$a(href = value, target = "_blank", value)
})
),
selection = "single", onClick = "select"
)
})
value0 <- reactive({
getReactableState("tabla", "selected")
})
output$selected <- renderPrint({
req(value0())
print(paste("you chose" , value0()))
})
}
)
Read more here

How to select the particular value in the data table

1.In my app i just want to show the data of the each row separately for Ex if i click any value in the first column the data should show the whole row
like if i click on Mazda RX4 it should show the whole row of the data
2.with the help of extensions = 'ColReorder' i can drag the column inside the table if i drag the first column to others position that clickable should work
for eg if i move the 1st(new_name) column into 4th that clickeable is not working
Any answers would be appreciated
library(shiny)
library(DT)
data("mtcars")
ui <- shinyUI(fluidRow(
DT::dataTableOutput("myDatatable"),
verbatimTextOutput("selectedCells")
))
df <- cbind(new_name =rownames(mtcars), data.frame(mtcars, row.names= NULL))
server <- shinyServer(function(input, output, session) {
output$myDatatable <- DT::renderDataTable(
df, extensions = 'ColReorder', options = list(colReorder = TRUE),selection = list(mode = "single", target ="cell"),
server = FALSE,
rownames = T
)
output$selectedCells <- renderPrint({
s = input$myDatatable_cells_selected
if (!is.null(s) && ncol(s) != 0) {
mtcars[,1]
} else {
NULL
}
})
})
shinyApp(ui, server)
Tested:
library(shiny)
library(DT)
data("mtcars")
ui <- shinyUI(fluidRow(
DT::dataTableOutput("myDatatable"),
verbatimTextOutput("selectedCells")
))
df <- cbind(new_name =rownames(mtcars), data.frame(mtcars, row.names= NULL))
server <- shinyServer(function(input, output, session) {
output$myDatatable <- DT::renderDataTable(
df, extensions = 'ColReorder', options = list(colReorder = TRUE),selection = list(mode = "single", target ="cell"),
server = FALSE,
rownames = T
)
output$selectedCells <- renderPrint({
s_val = input$myDatatable_cell_clicked$value
s = input$myDatatable_cells_selected
if (!is.null(s) && ncol(s) != 0) {
df[df$new_name==s_val,]
} else {
NULL
}
})
})
shinyApp(ui, server)
You can have the value of selected cell with:
s_val = input$myDatatable_cell_clicked$value
After that, you can search this value in your data and print the entire row:
df[df$new_name==s_val,]

Subset a dataframe based on columns of another dataframe in a shiny app

I have the dataframe below:
DF2 = data.frame(agency_postcode = factor(rep(c(12345,45678,24124,32525,32325),2)),
car_group=factor(rep(c("Microcar","City car","Supermini","Compact","SUV"),2)),
transmission=factor(rep(c("automatic","manual"),5)))
which I use and display as rhandsontable in order to create a second table. First you are supposed to select one or more options from filter by input and then a level from the selected filter(s). Then you press search. What I basically want to do is subset the second table based on the first row of every selected column of the first table. The issue is in line 30 of server.r in which I should give the input$sel
#ui.r
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width=2,
selectInput("sel","Filter by:",
choices = c("agency_postcode","date_start","days","car_group","transmission","driver_age"),
multiple=T,selected = "agency_postcode"),
actionButton("sr","Search")
),
mainPanel(
fluidRow(
column(4,offset = 0, style='padding:0px;',rHandsontableOutput("hot")),
column(8,offset = 0, style='padding:0px;',rHandsontableOutput("hot2"))
)
)
)
)
#server.r
#server.r
library(shiny)
library(rhandsontable)
library(jsonlite)
server <- function(input, output) {
#Create rhandsontable as a reactive expression
DFR2<-reactive({
rhandsontable(DF2[1,1:2], rowHeaders = NULL,height = 200)%>%
hot_col(colnames(DF2)[1:2])
})
#Display the rhandsontable
output$hot <- renderRHandsontable({
DFR2()
})
#Convert the rhandsontable to a daraframe
DFR3<-reactive({
req(input$hot)
hot_to_r(input$hot)
})
#Subset the initial dataframe by value of the 1st row-1st column cell of DF3
DFR4 <- reactive({
req(DFR3())
D<-DF2[ which(DF2[,1] %in% DFR3()[1, 1]), ] #input$sel is supposed to be used here instead of 1
for(i in 1:ncol(D)){
D[,i] <- factor(D[,i])
}
D
})
#Display the new rhandsontable
output$hot2 <- renderRHandsontable({
input$sr
isolate(rhandsontable(DFR4()[1,], rowHeaders = NULL,height = 200)%>%
hot_col(colnames(DFR4())) )
})
}
OK. Here is an app that uses a small table to filter a larger one using inner_join. I am not sure this will match the design you had in mind. It is still unclear to me where the filter levels are coming from, or what the hands on tables are for. But you should be able to adapt this approach to your design. Note also that I am not using hands on tables. A direct replacement of the calls to renderTable with renderRHandsontable should work too.
library(shiny)
library(dplyr)
library(purrr)
sub_cars <- mtcars[, c("cyl", "gear", "am")]
ui <- fluidPage(
column(width=3,
selectInput(
inputId = "sel_col",
label = "Select variables",
multiple = TRUE,
choices = c("cyl", "gear", "am"),
selectize = TRUE),
uiOutput("cyl"),
uiOutput("gear"),
uiOutput("am")
),
column(width = 3,
tableOutput("filter_table")),
column(width = 6,
tableOutput("large_table"))
)
server <- function(input, output) {
output$cyl <- renderUI({
if ("cyl" %in% input$sel_col) {
selectInput(
inputId = "sel_cyl",
label = "Select cylinders",
choices = unique(sub_cars$cyl),
multiple = TRUE,
selectize = TRUE
)
}
})
output$gear <- renderUI({
if ("gear" %in% input$sel_col) {
selectInput(
inputId = "sel_gear",
label = "Select gears",
choices = unique(sub_cars$gear),
multiple = TRUE,
selectize = TRUE
)
}
})
output$am <- renderUI({
if ("am" %in% input$sel_col) {
selectInput(
inputId = "sel_am",
label = "Select am",
choices = unique(sub_cars$am),
multiple = TRUE,
selectize = TRUE
)
}
})
# make a small filter table
filter_df <- reactive({
validate(
need(!is_null(input$sel_col),
message = "Please select a column"))
cols <- input$sel_col
cols_vals <- map(cols, function(x) input[[paste0("sel_", x, collapse="")]])
df <- map2_dfr(cols, cols_vals, function(x, y)
filter(sub_cars,!!as.name(x) %in% y)) %>%
select(one_of(cols)) %>%
distinct()
return(df)
})
output$filter_table <- renderTable({
validate(
need(nrow(filter_df()) > 0,
message = "Please select filter values"))
filter_df()
})
# inner join the larger table
large_df <- reactive({
validate(
need(nrow(filter_df()) > 0,
message = "Please select filter values"))
cols <- input$sel_col
inner_join(x=filter_df(), y=mtcars, by = cols)
})
output$large_table <- renderTable({large_df()})
}
shinyApp(ui, server)
Here is a gif of what it does.

Using a selected row to subset another table in r shiny

I am new to using DT in R shiny.Basically what i am trying to do here is to use the select value from the first table to filter the second table.
my Ui.r is
library(shiny)
library(shinydashboard)
ui <- dashboardPage(skin="green",
dashboardHeader(title="Inventory Management"),
dashboardSidebar(disable = TRUE),
dashboardBody(fluidRow(column(4,box(status="success",
uiOutput("Firstselection"),
br(),
uiOutput("Secondselection"))
),
column(4,infoBoxOutput("salesbox")),
column(4,infoBoxOutput("Runoutbox")),
column(4,infoBoxOutput("Excessbox"))),
actionButton("actionbtn","Run"),
fluidRow(tabBox(tabPanel(
DT::dataTableOutput(outputId="table"),title = "Stock Available for the category chosen",width = 12),
tabPanel(DT::dataTableOutput(outputId="asso"),title = "Associated products",width = 12)))
))
and my server is
server <-function(input, output, session) {
observeEvent(input$actionbtn, {source('global.r',local = TRUE)
#choose sub category based on category
output$Firstselection<-renderUI({selectInput("ray",
"Category:",
c("All",unique(as.character(bestpred$lib_ray))))})
output$Secondselection<-renderUI({selectInput("sray",
"Sub Category:",
c("All",unique(as.character(bestpred[bestpred$lib_ray==input$ray,"lib_sray"]))))})
# Filter data based on selections
output$table <- DT::renderDataTable({
data <- bestpred
if (input$ray != "All"){
data <- data[data$lib_ray == input$ray,]
}
if (input$sray != "All"){
data <- data[data$lib_sray == input$sray,]
}
data
},filter="top"
)
output$salesbox<-renderInfoBox({infoBox("Total Sales",sum(data()$Total_Sales),icon = icon("line-chart"))})
output$Runoutbox<-renderInfoBox({infoBox("Total Runout",sum(data()$status=="Runout"),icon = icon("battery-quarter"))})
output$Excessbox<-renderInfoBox({infoBox("Total excess",sum(data()$status=="Excess"),icon = icon("exclamation-triangle"))})
output$asso <- DT::renderDataTable({
asso <- test1
s=data[input$tablatable_rows_selected,1]
asso <- asso[asso$num_art == s,]
asso
},filter="top")
})}
So when i select a row in the output table i wanna use that as an filter for my asso table
this code dosent poup any error but the output table asso is always empty
Find a generalized solution in the following:
Adapted from here: https://yihui.shinyapps.io/DT-rows/
library(shiny)
library(DT)
server <- shinyServer(function(input, output, session) {
output$x1 = DT::renderDataTable(cars, server = FALSE)
output$x2 = DT::renderDataTable({
sel <- input$x1_rows_selected
if(length(cars)){
cars[sel, ]
}
}, server = FALSE)
})
ui <- fluidPage(
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, DT::dataTableOutput('x2'))
)
)
shinyApp(ui, server)

Resources