Using a selected row to subset another table in r shiny - r

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)

Related

Rshiny Server Side Modularity Using SQL: Filtered Data Table Not Rendering

So far I made a Shiny app with the following procedures/features:
global.R: Connects to the database using pool in R and retrieves min and max date which will be used in the server side
ui.R: I created two tabs but will only include tab2 here. tab2 has three dropdown inputs and a filtered data table based on these inputs
ui_tab2.R: Defined the three inputs explained in ui.R:
var_lab_tab2: A static dropdown input with only two choices Choice1 and Choice2
daterange_tab2_ui: A date range
subid_dropdown_tab2_ui: The last dropdown input that depends on the first two
server_tab2.R:
Function1 dropdownTab2Server:
Defined the date range logic with id daterange_tab2
Defined the last input dropdown logic with id var_list_tab2
Function2 filteredDataTableTab2Server (This part is not working):
Fetch the filtered data using SQL based on the three inputs
So far everything is working except for filteredDataTableTab2Server which is returning an empty data table. I think the problem is related to the dynamic sql part inside glue_sql. Any help would be of great help.
##### 1st module: global.R
#### Libraries
library(pool)
library(dplyr)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinycssloaders)
library(glue)
library(tidyr)
library(DBI)
library(reactable)
library(tidyverse)
#### Source
source("ui_tab2.R", local = T)
source("server_tab2.R", local = T)
# Assume we made our pooled object and saved it as "pool"
min_max_date <- pool %>%
tbl("table1") %>%
summarise(
max_date = max(timestamp, na.rm = T)
)
min_max_date_df <- as.data.frame(min_max_date) %>%
mutate(
min_date = as.Date("2022-01-01"),
max_date = as.Date(max_date)
) %>%
select(c(min_date, max_date))
##### 2nd module: ui.R
dashboardPage(dashboardHeader(
title = "title",
),
dashboardSidebar(
collapsed = F,
sidebarMenu(
menuItem("tab1_title", tabName = "tab1"),
menuItem("tab2_title", tabName = "tab2")
)
),
dashboardBody(
useShinyjs(),
tabItems(
tabItem(
tabName = "tab2",
dropdownTab2UI("dropdown_ui_tab2"),
reactableOutput("table1_tab2"),
)
)
)
)
##### 3rd module: ui_tab2.R
dropdownTab2UI <- function(id) {
ns <- NS(id)
tagList(
div(
shinyWidgets::pickerInput(
ns("var_lab_tab2"),
"ID:",
choices = c("Choice1", "Choice2"),
options = shinyWidgets::pickerOptions(
actionsBox = T,
header = "Close",
liveSearch = T
),
multiple = T
)
),
uiOutput(ns("daterange_tab2_ui")),
uiOutput(ns("subid_dropdown_tab2_ui"))
)
}
###### 4th module: server.R
function(input, output, session) {
dropdownTab2Server("dropdown_ui_tab2")
myvars <- dropdownTab2Server("dropdown_ui_tab2")
# This part is not working. The error message is "Error in as.vector:
# cannot coerce type 'closure' to vector of type 'character'".
# If I remove ```reactive```, then it works but it returns an empty data table.
data_tab2 <- filteredDataTableTab2Server(
id = "table1_tab2",
input1 = reactive(myvars$var1),
input2 = reactive(myvars$var2),
input3 = reactive(myvars$var3)
)
### renderDataTable
output$table1_tab2 <- renderReactable({
reactable(
req(data_tab2())
)
})
}
###### 5th module: server_tab2.R
#### 5-1. A dropdown input dependent on the date range
dropdownTab2Server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
rv <- reactiveValues()
output$daterange_tab2_ui <- renderUI({
req(input$var_lab_tab2)
dateRangeInput(
ns("daterange_tab2"),
"Date Range:",
start = min_max_date_df$min_date,
end = min_max_date_df$max_date
) # Retrieved from "global.R"
})
unique_lists_tab2 <- reactive({
sql <- glue_sql("
SELECT
DISTINCT list AS unique_list
FROM table1
WHERE date BETWEEN date ({dateid1_tab2*}) AND date ({dateid2_tab2*})
",
dateid1_tab2 = input$daterange_tab2[1],
dateid2_tab2 = input$daterange_tab2[2],
.con = pool
)
dbGetQuery(pool, sql)
})
output$subid_dropdown_tab2_ui <- renderUI({
req(input$daterange_tab2[1], input$daterange_tab2[2])
shinyWidgets::pickerInput(
ns("var_list_tab2"),
"Stations:",
choices = unique_lists_tab2(),
options = shinyWidgets::pickerOptions(
actionsBox = T,
header = "Close",
liveSearch = T
),
multiple = T
)
})
observe({
rv$var1 <- input$daterange_tab2[1]
rv$var2 <- input$daterange_tab2[2]
rv$var3 <- input$var_list_tab2
})
return(rv)
}
)
}
#### 5-2. Filtered data based on all inputs => This part is returning an empty data table
filteredDataTableTab2Server <- function(id, input1, input2, input3) {
moduleServer(id, function(input, output, session) {
reactive({
sql <- glue_sql("
SELECT
col1,
col2,
col3
FROM table1
WHERE date BETWEEN date ({dateid_tab2*}) AND date ({dateid_tab2*})
AND system IN ({listid_tab2*})
",
dateid1_tab2 = input1,
dateid2_tab2 = input2,
listid_tab2 = input3,
.con = pool
)
dbGetQuery(pool, sql)
})
}
)
}
You don't evaluate your reactive inputs to the filteredDataTableTab2Server module.
Try:
dateid1_tab2 = input1(),
dateid2_tab2 = input2(),
listid_tab2 = input3(),

Subset a dataframe based on certain column of certain row selection of a datatable

I have the shiny app below in which when I click on a row of the 1st table I should get the correspondent value of species column. Then with this value I should subset the second dataframe df based on its species column.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(DT::dataTableOutput('tableId'),
dataTableOutput("celltext")),
server = function(input, output) {
output$tableId = DT::renderDataTable(
iris[,c(1,5)], selection = list(target = 'row',mode="single")
)
species<-c("setosa","setosa","virginica","virginica")
flower<-c("a","b","c","d")
score<-c(7,5,6,9)
df<-data.frame(species,flower,score)
output$celltext <- renderDataTable({
cell <- input$tableId_rows_selected
df<-df[df$species == iris[row]
})
}
)
Try this
shinyApp(
ui = fluidPage(DT::dataTableOutput('tableId'),
DTOutput("celltext")),
server = function(input, output) {
output$tableId = DT::renderDataTable(
iris[,c(1,5)], selection = list(target = 'row',mode="single")
)
species<-c("setosa","setosa","virginica","virginica")
flower<-c("a","b","c","d")
score<-c(7,5,6,9)
df<-data.frame(species,flower,score)
output$celltext <- renderDT({
cell <- input$tableId_rows_selected
dat<-df[df$species %in% iris[cell,5],]
dat
})
}
)

How to replaceData in DT rendered in R shiny using the datatable function

I have an R shiny app with a DT datatable that is rendered using the datatable function in order to set various options. I would like to use dataTableProxy and replaceData to update the data in the table, but all the examples I can find assume the DT is rendered directly from the data object, not using the datatable function. The reprex below shows what I would like to do, but replaceData doesn't work in this pattern. How do I do this? Thanks.
# based on
# https://community.rstudio.com/t/reorder-data-table-with-seleceted-rows-first/4254
library(shiny)
library(DT)
ui = fluidPage(
actionButton("button1", "Randomize"),
fluidRow(
column(6,
h4("Works"),
DT::dataTableOutput('table1', width="90%")),
column(6,
h4("Doesn't Work"),
DT::dataTableOutput('table2', width="90%"))
)
)
server = function(input, output, session) {
my <- reactiveValues(data = iris)
output$table1 <- DT::renderDataTable(isolate(my$data))
output$table2 <- DT::renderDataTable({
DT::datatable(isolate(my$data),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, info=FALSE),
class = "nowrap cell-border hover stripe",
rownames = FALSE,
editable = FALSE
) %>%
DT::formatStyle('Sepal.Width', `text-align`="center")
})
observeEvent(input$button1, {
# calculate new row order
row_order <- sample(1:nrow(my$data))
my$data <- my$data[row_order, ]
proxy1 <- DT::dataTableProxy('table1')
DT::replaceData(proxy1, my$data)
proxy2 <- DT::dataTableProxy('table2')
DT::replaceData(proxy2, my$data)
})
}
shinyApp(ui, server)
Update: Very strangely, removing rownames = FALSE made it all possible. I'm not exactly sure why, but probably rownames might be essential for replacing Data.
# based on
# https://community.rstudio.com/t/reorder-data-table-with-seleceted-rows-first/4254
library(shiny)
library(DT)
ui = fluidPage(
actionButton("button1", "Randomize"),
fluidRow(
column(6,
h4("Works"),
DT::dataTableOutput('table1', width="90%")),
column(6,
h4("Doesn't Work"),
DT::dataTableOutput('table2', width="90%"))
)
)
server = function(input, output, session) {
my <- reactiveValues(data = iris)
output$table1 <- DT::renderDataTable(isolate(my$data))
output$table2 <- DT::renderDataTable({
DT::datatable(isolate(my$data),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, info=FALSE),
class = "nowrap cell-border hover stripe",
# rownames = FALSE,
editable = FALSE
) %>%
DT::formatStyle('Sepal.Width', `text-align`="center")
})
observeEvent(input$button1, {
# calculate new row order
row_order <- sample(1:nrow(my$data))
my$data <- my$data[row_order, ]
proxy1 <- DT::dataTableProxy('table1')
DT::replaceData(proxy1, my$data)
proxy2 <- DT::dataTableProxy('table2')
DT::replaceData(proxy2, my$data)
})
}
shinyApp(ui, server)

R Shiny - Dynamic Filtering from a CSV File - Rows Go Missing

When using filtering and the verbatimTextOutput function in R Shiny, rows go seemingly go missing when I select more than one of the input choices in my checkboxGroupInput.
Below is my code. Any advice?
Thanks in advance.
infantmort <- read.csv("infantmort.csv", header = TRUE)
ui <- fluidPage(
checkboxGroupInput("regioninputID",
"Select Region(s)",
choices = unique(infantmort$whoregion)
),
mainPanel(
verbatimTextOutput("regionoutputID"), width = "auto", height = "auto"
)
)
server <- function(input, output) {
dataset <- reactive({
as.data.frame(infantmort %>% select(whoregion, year, deathsinthousands) %>%
filter(whoregion == input$regioninputID) )
})
output$regionoutputID <- renderPrint({ dataset()
})
}
shinyApp(ui = ui, server = server)
You need to change your filter from == to %in%
The following should do the trick
server <- function(input, output) {
dataset <- reactive({
as.data.frame(infantmort %>% select(whoregion, year, deathsinthousands) %>%
filter(whoregion %in% input$regioninputID) )
})

Shiny Data table display all data using filter

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)

Resources