在 R 中的 Shiny 中链接 dataTableOutput 和 plot
Linking dataTableOutput and plot in Shiny in R
我想要 link 一个 dataTableOutput 和一个 shiny 应用程序中的绘图，这样当在 table 中选择一行或一个单元格时，绘图会反应使用与该行关联的数据进行更新。
这是我的数据：-
数据
#relevant libraries
library(wakefield)#for generating the Status variable
library(dplyr)
library(stringi)
library(Pareto)
library(uuid)
library(ggplot2)
library(shiny)
library(DT)
#mock data creation
set.seed(1)
#data<-data.frame()
Date<-seq(as.Date("2015-01-01"), as.Date("2015-12-31"), by = "1 day")
Date<-sample(rep(Date,each=10),replace = T)
event<-r_sample_factor(x = c("Wrestling", "Drama",
"Information", "Football", "Rugby", "Movie", "Music", "News"), n=length(Date))
channel<-r_sample_factor(x = c("Channel 1", "Channel 2", "Channel 3", "Channel 4"), n=length(Date))
Hour<-r_sample_factor(x = c(0:23), n=length(Date))
Group<-r_sample_factor(x = c("A","B","C","D","E"), n=length(Date))
#creating user ID
set.seed(1)
n_users <- 100
n_rows <- 3650
relative_probs <- rPareto(n = n_users, t = 1, alpha = 0.3, truncation = 500)
unique_ids <- UUIDgenerate(n = n_users)
AnonID <- sample(unique_ids, size = n_rows, prob = relative_probs, replace = TRUE)
data<-data.frame(AnonID,Group,Date,Hour,channel,event)
data$Hour<-as.numeric(data$Hour)
head(data)
到目前为止，这是我闪亮的应用程序：-
亮码
#ui================================
ui<-fluidPage(
titlePanel("Example panel"),
tabsetPanel(
tabPanel("example text",
sidebarPanel(width = 4,
dateRangeInput("daterange","Select dates", format = "yyyy-mm-dd",
start = min("2015-01-01"),
end = max("2015-01-10")),
numericInput("hourmin", "Select mininum hour",10,0,23),
numericInput("hourmax", "Select maximum hour", 22,0,23),
pickerInput("channel", "Select channel",
choices = unique(channel), options = list('actions-box'=T,'live-search'=T),multiple = T)),#end of sidebarPanel
mainPanel(
column(width = 10, plotOutput("barplot", width = "100%")),
column(width = 8, dataTableOutput("table"))
)#end of mainPanel
)
)#end of tabPanel
)#end of tabsetPanel
)#end of fluidPage
#server===========================================
server<-function(input,output,session){
rv <- reactiveVal(NULL)
observe({
rv(data)
output$table<-renderDT({
rv()%>%
arrange(desc(Date))%>%
filter(Date>=input$daterange[1] & Date<=input$daterange[2])%>%
filter(Hour>=input$hourmin & Hour<=input$hourmax)%>%
filter(channel %in% input$channel)%>%
group_by(channel,Date)%>%
arrange(Date)%>%
summarise(Programme=paste0(Hour,":",substr(event,1,3)), .groups = 'drop')%>%
#mutate(rn=rowid(Date))%>%
pivot_wider(names_from = Date,values_from = Programme) # %>%
#select(-rn)
})
output$barplot<-renderPlot({
rv()%>%
filter(Date>=input$daterange[1] & Date<=input$daterange[2])%>%
filter(Hour>=input$hourmin & Hour<=input$hourmax)%>%
filter(channel %in% input$channel)%>%
group_by(Date,Group)%>%
summarise(UniqueID=n_distinct(AnonID))%>%
ggplot()+
geom_bar(aes(x=Date,y=UniqueID, fill=Group), stat = "identity", position = "dodge")
})
})#end of observe
}
shinyApp(ui,server)
哪个会给你这个：-
我想要做的是能够单击 dataTableOutput 中的一行（按日期和小时），然后绘制数据中唯一 UniqueID 的数量与该日期和时间相关联。我的代码中缺少什么可以让我这样做？
谢谢！
作为第一步，我们可以使用 reactiveValues 来保存渲染后的数据 datatable。
rv <- reactiveValues(data = NULL)
其次，我们可以利用 select 行的可能性 DT table。
output$table <- DT::renderDataTable({
DT::datatable(rv$data, selection = list(target = "row"))
})
现在剩下的就是捕获结果 table 中包含的小时和日期，并使用该信息创建 de barplot。
请注意，由于 pivot_table 之前的使用方式，此 table 将包含日期作为列名，并将小时包含在字符串中。
代码：
# relevant libraries
library(wakefield) # for generating the Status variable
library(tidyverse)
library(stringi)
library(Pareto)
library(uuid)
library(shiny)
library(DT)
library(shinyWidgets)
################### // UI //###################
ui <- fluidPage(
titlePanel("Example panel"),
tabsetPanel(
tabPanel(
"example text",
sidebarPanel(
width = 4,
dateRangeInput("daterange", "Select dates",
format = "yyyy-mm-dd",
start = min("2015-01-01"),
end = max("2015-01-10")
),
numericInput("hourmin", "Select mininum hour", 10, 0, 23),
numericInput("hourmax", "Select maximum hour", 22, 0, 23),
pickerInput("channel", "Select channel",
choices = unique(channel),
options = list("actions-box" = T, "live-search" = T),
multiple = T,
selected = unique(channel)
)
), # end of sidebarPanel
mainPanel(
column(width = 10, plotOutput("barplot", width = "100%")),
column(width = 8, DTOutput("table"))
) # end of mainPanel
) # end of tabPanel
) # end of tabsetPanel
) # end of fluidPage
################### // SERVER //###################
server <- function(input, output, session) {
rv <- reactiveValues(data = NULL)
# TABLE -------------------------------------------------------------------
observe({
rv$data <-
data %>% # data was created outside the shiny app meaning that is present in the global env
arrange(desc(Date)) %>%
filter(Date >= input$daterange[1] & Date <= input$daterange[2]) %>%
filter(Hour >= input$hourmin & Hour <= input$hourmax) %>%
filter(channel %in% input$channel) %>%
group_by(channel, Date) %>%
arrange(Date) %>%
summarise(Programme = paste0(Hour, ":", substr(event, 1, 3)), .groups = "drop") %>%
pivot_wider(
names_from = Date,
values_from = Programme,
values_fn = as_mapper(~ reduce(., paste, sep = ","))
)
output$table <- DT::renderDataTable({
DT::datatable(rv$data, selection = list(target = "row"))
})
})
observeEvent(input$table_rows_selected, {
req(input$table_rows_selected)
# the dates i want are the names of the columns
dts <- rv$data[input$table_rows_selected, ] %>%
names() %>%
`[`(-1)
hrs <- # this will give me the hours present in the cells selected from DT
rv$data[input$table_rows_selected, ] %>%
map(~ str_extract_all(., "\d+")) %>%
`[`(-1) %>%
reduce(c) %>%
reduce(c)
# i know that i need the first column only
channel_values <- rv$data[input$table_rows_selected, 1] %>%
pull(channel) %>%
as.character()
###### BARPLOT #########
output$barplot <- renderPlot({
data %>%
filter(Date >= min(dts) & Date <= max(dts)) %>%
filter(Hour >= min(hrs, na.rm = TRUE) & Hour <= max(hrs, na.rm = TRUE)) %>%
filter(channel %in% channel_values) %>%
group_by(Date, Group) %>%
summarise(UniqueID = n_distinct(AnonID)) %>%
ggplot() +
geom_bar(aes(x = Date, y = UniqueID, fill = Group), stat = "identity", position = "dodge")
})
}) # end of observe
}
shinyApp(ui, server)
我想要 link 一个 dataTableOutput 和一个 shiny 应用程序中的绘图，这样当在 table 中选择一行或一个单元格时，绘图会反应使用与该行关联的数据进行更新。
这是我的数据：-
数据
#relevant libraries
library(wakefield)#for generating the Status variable
library(dplyr)
library(stringi)
library(Pareto)
library(uuid)
library(ggplot2)
library(shiny)
library(DT)
#mock data creation
set.seed(1)
#data<-data.frame()
Date<-seq(as.Date("2015-01-01"), as.Date("2015-12-31"), by = "1 day")
Date<-sample(rep(Date,each=10),replace = T)
event<-r_sample_factor(x = c("Wrestling", "Drama",
"Information", "Football", "Rugby", "Movie", "Music", "News"), n=length(Date))
channel<-r_sample_factor(x = c("Channel 1", "Channel 2", "Channel 3", "Channel 4"), n=length(Date))
Hour<-r_sample_factor(x = c(0:23), n=length(Date))
Group<-r_sample_factor(x = c("A","B","C","D","E"), n=length(Date))
#creating user ID
set.seed(1)
n_users <- 100
n_rows <- 3650
relative_probs <- rPareto(n = n_users, t = 1, alpha = 0.3, truncation = 500)
unique_ids <- UUIDgenerate(n = n_users)
AnonID <- sample(unique_ids, size = n_rows, prob = relative_probs, replace = TRUE)
data<-data.frame(AnonID,Group,Date,Hour,channel,event)
data$Hour<-as.numeric(data$Hour)
head(data)
到目前为止，这是我闪亮的应用程序：-
亮码
#ui================================
ui<-fluidPage(
titlePanel("Example panel"),
tabsetPanel(
tabPanel("example text",
sidebarPanel(width = 4,
dateRangeInput("daterange","Select dates", format = "yyyy-mm-dd",
start = min("2015-01-01"),
end = max("2015-01-10")),
numericInput("hourmin", "Select mininum hour",10,0,23),
numericInput("hourmax", "Select maximum hour", 22,0,23),
pickerInput("channel", "Select channel",
choices = unique(channel), options = list('actions-box'=T,'live-search'=T),multiple = T)),#end of sidebarPanel
mainPanel(
column(width = 10, plotOutput("barplot", width = "100%")),
column(width = 8, dataTableOutput("table"))
)#end of mainPanel
)
)#end of tabPanel
)#end of tabsetPanel
)#end of fluidPage
#server===========================================
server<-function(input,output,session){
rv <- reactiveVal(NULL)
observe({
rv(data)
output$table<-renderDT({
rv()%>%
arrange(desc(Date))%>%
filter(Date>=input$daterange[1] & Date<=input$daterange[2])%>%
filter(Hour>=input$hourmin & Hour<=input$hourmax)%>%
filter(channel %in% input$channel)%>%
group_by(channel,Date)%>%
arrange(Date)%>%
summarise(Programme=paste0(Hour,":",substr(event,1,3)), .groups = 'drop')%>%
#mutate(rn=rowid(Date))%>%
pivot_wider(names_from = Date,values_from = Programme) # %>%
#select(-rn)
})
output$barplot<-renderPlot({
rv()%>%
filter(Date>=input$daterange[1] & Date<=input$daterange[2])%>%
filter(Hour>=input$hourmin & Hour<=input$hourmax)%>%
filter(channel %in% input$channel)%>%
group_by(Date,Group)%>%
summarise(UniqueID=n_distinct(AnonID))%>%
ggplot()+
geom_bar(aes(x=Date,y=UniqueID, fill=Group), stat = "identity", position = "dodge")
})
})#end of observe
}
shinyApp(ui,server)
哪个会给你这个：-
我想要做的是能够单击 dataTableOutput 中的一行（按日期和小时），然后绘制数据中唯一 UniqueID 的数量与该日期和时间相关联。我的代码中缺少什么可以让我这样做？
谢谢！
作为第一步，我们可以使用 reactiveValues 来保存渲染后的数据 datatable。
rv <- reactiveValues(data = NULL)
其次，我们可以利用 select 行的可能性 DT table。
output$table <- DT::renderDataTable({
DT::datatable(rv$data, selection = list(target = "row"))
})
现在剩下的就是捕获结果 table 中包含的小时和日期，并使用该信息创建 de barplot。
请注意，由于 pivot_table 之前的使用方式，此 table 将包含日期作为列名，并将小时包含在字符串中。
代码：
# relevant libraries
library(wakefield) # for generating the Status variable
library(tidyverse)
library(stringi)
library(Pareto)
library(uuid)
library(shiny)
library(DT)
library(shinyWidgets)
################### // UI //###################
ui <- fluidPage(
titlePanel("Example panel"),
tabsetPanel(
tabPanel(
"example text",
sidebarPanel(
width = 4,
dateRangeInput("daterange", "Select dates",
format = "yyyy-mm-dd",
start = min("2015-01-01"),
end = max("2015-01-10")
),
numericInput("hourmin", "Select mininum hour", 10, 0, 23),
numericInput("hourmax", "Select maximum hour", 22, 0, 23),
pickerInput("channel", "Select channel",
choices = unique(channel),
options = list("actions-box" = T, "live-search" = T),
multiple = T,
selected = unique(channel)
)
), # end of sidebarPanel
mainPanel(
column(width = 10, plotOutput("barplot", width = "100%")),
column(width = 8, DTOutput("table"))
) # end of mainPanel
) # end of tabPanel
) # end of tabsetPanel
) # end of fluidPage
################### // SERVER //###################
server <- function(input, output, session) {
rv <- reactiveValues(data = NULL)
# TABLE -------------------------------------------------------------------
observe({
rv$data <-
data %>% # data was created outside the shiny app meaning that is present in the global env
arrange(desc(Date)) %>%
filter(Date >= input$daterange[1] & Date <= input$daterange[2]) %>%
filter(Hour >= input$hourmin & Hour <= input$hourmax) %>%
filter(channel %in% input$channel) %>%
group_by(channel, Date) %>%
arrange(Date) %>%
summarise(Programme = paste0(Hour, ":", substr(event, 1, 3)), .groups = "drop") %>%
pivot_wider(
names_from = Date,
values_from = Programme,
values_fn = as_mapper(~ reduce(., paste, sep = ","))
)
output$table <- DT::renderDataTable({
DT::datatable(rv$data, selection = list(target = "row"))
})
})
observeEvent(input$table_rows_selected, {
req(input$table_rows_selected)
# the dates i want are the names of the columns
dts <- rv$data[input$table_rows_selected, ] %>%
names() %>%
`[`(-1)
hrs <- # this will give me the hours present in the cells selected from DT
rv$data[input$table_rows_selected, ] %>%
map(~ str_extract_all(., "\d+")) %>%
`[`(-1) %>%
reduce(c) %>%
reduce(c)
# i know that i need the first column only
channel_values <- rv$data[input$table_rows_selected, 1] %>%
pull(channel) %>%
as.character()
###### BARPLOT #########
output$barplot <- renderPlot({
data %>%
filter(Date >= min(dts) & Date <= max(dts)) %>%
filter(Hour >= min(hrs, na.rm = TRUE) & Hour <= max(hrs, na.rm = TRUE)) %>%
filter(channel %in% channel_values) %>%
group_by(Date, Group) %>%
summarise(UniqueID = n_distinct(AnonID)) %>%
ggplot() +
geom_bar(aes(x = Date, y = UniqueID, fill = Group), stat = "identity", position = "dodge")
})
}) # end of observe
}
shinyApp(ui, server)