在R Shiny的数据表中显示活动详细信息 [英] Diplaying activity details in a data table in R shiny
问题描述
当我在下面运行此R闪亮脚本时，我得到了两个曲线图，其中带有活动路径的图表是从bupaR库的患者数据集中获得的，该数据集的左侧为跟踪资源管理器，而数据表则显示了活动/跟踪详细信息.左图是这样，我们观察到了一系列活动，这些活动具有水平的活动轨迹序列，这些活动轨迹是一个接一个地出现的.单击特定跟踪中的任何框时，跟踪详细信息将显示在右表中.我的要求是，当单击特定跟踪中的任何框时，应动态获取"y"或第四列的值，并且我应该只获得一列来显示跟踪中发生的所有活动.例如.在所附的图像中，当单击最底部路径中的任意位置时，我应该获得一列带有注册"，分类和评估"活动的列.请帮忙，谢谢.
When I run this R shiny script below, I get two plots with a chart for activity path derived from the patients dataset of the bupaR library called trace explorer on the left and a data table to display the activity/trace details. The chart on the left is such,that we observe various paths with sequence of horizontal traces of activities which occur one after the other. When clicked on any box in a particular trace, the trace details are presented on the right table. My requirement is that, when clicked on any box in a particular trace, the "y" or fourth column value should be taken dynamically, and I should get just one column displaying all the activities that occur in the trace. E.g. in the attached image, when clicked anywhere on the bottom most path, I should get one column with activities "Registration", "Triage and Assessment". Please help and thanks.
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)
library(edeaR)
library(scales)
library(splitstackshape)
ui <- dashboardPage(
dashboardHeader(title = "My Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Data Path", status = "primary",height = "455" ,solidHeader = T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
tr <- data.frame(traces(patients, output_traces = T, output_cases = F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
mp1 = ggplot(data = tr.df, aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br> Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 380, width = 605)
})
output$sankey_table <- renderDataTable({
tp2 = event_data("plotly_click")
})
}
shinyApp(ui, server)
第二部分:
library(lubridate)
patients1 <<- arrange(patients, patient)
patients2 <<- patients1 %>% arrange(patient, time)
patients3 <<- patients2 %>%
group_by(patient) %>%
mutate(diff_in_sec = as.POSIXct(time, format = "%m/%d/%Y %H:%M") -
lag(as.POSIXct(time, format = "%m/%d/%Y %H:%M"),
default=first(as.POSIXct(time, format = "%m/%d/%Y %H:%M"))))%>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>% mutate(diff_in_days
= as.numeric(diff_in_hours/24))
运行上述代码后，您将从bupaR库中获取患者数据，以便在患者"列下提供的数据中有500个病例，每种情况下的活动均在处理"列中并进行了排列按其出现时间的升序排列.我的要求是，我想比较从DT表中从先前解决方案获得的值"列，并与唯一(处理)"进行比较，即，在每种情况下，患者3数据集中患者"的唯一活动.在值"列找到完全匹配的情况下，我想在DT表中显示整个对应的行.例如.在最底部路径上单击带有活动注册"，分类和评估"的跟踪时，如果找到匹配项，则应将值"列与活动的唯一性(从1到500)进行比较(如果找到匹配项)对于所有跟踪，都应显示注册"，分类和评估"，并显示具有相应行的案例.谢谢，请帮忙.
Upon running this code above, you get the patients data from the bupaR library such that there are 500 cases in the data given under the "patient" column, the activities in every case are in the "handling" column and are arranged in ascending order of the time of their occurrence. My requirement is that I want to compare the "value" column obtained from the previous solution in the DT table and compare with 'unique(handling)' i.e. unique activities in every case "patient" in the patients3 dataset. The cases where the "value" column finds an exact match, I want to display the entire corresponding rows in the DT table. E.g. when clicked anywhere on the bottom most path, the trace with activities "Registration", "Triage and Assessment", the "value" column should be compared with unique of activities in every case from 1 to 500, if match found i.e. cases with activities "Registration", "Triage and Assessment", those cases with corresponding rows should be displayed, similarly for all traces. Thank you and please help.
第三部分:
我想通过给它一个合适的pageLength来修复第二个框中的数据表，这样它就不应从下面和右边超调.请在下面找到合并的代码，我知道要整合到图中以实现此目的的一些可能语法如下:
I want to fix the data table in the second box by giving it a suitable pageLength, such that it should not overshoot from below and from the right. Please find the consolidated code below, some possible syntax I know to integrate in the plot to achieve this are as follows:
可能的语法:
datatable(Data, options = list(
searching = TRUE,
pageLength = 9
))
**and**
box( title = "Case Details", status = "primary", height = "575",solidHeader
= T,width = "6",
div(DT::dataTableOutput("Data_table"), style = "font-size: 84%; width:
65%"))
**Here is the consolidated final code to be updated**
ui <- dashboardPage(
dashboardHeader(title = "My Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Data Path", status = "primary",height = "455" ,solidHeader = T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", solidHeader
= T,
dataTableOutput("sankey_table"),
width = 6)
)
)
server <- function(input, output)
{
#Plot for Trace Explorer
dta <- reactive({
tr <- data.frame(traces(patients, output_traces = T, output_cases = F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
patients10 <- reactive({
patients11 <- arrange(patients, patient)
patients12 <- patients1 %>% arrange(patient, time,handling_id)
patients12 %>%
group_by(patient) %>%
mutate(time = as.POSIXct(time, format = "%m/%d/%Y %H:%M"),diff_in_sec =
time - lag(time)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
output$trace_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br>
Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 516, width = 605)
})
output$trace_table <- renderDataTable({
req(event_data("plotly_click"))
Values <- dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
valueText <- paste0(Values[[1]] %>% na.omit(),collapse = "")
agg <- aggregate(handling~patient, data = patients10(), FUN = function(y)
{paste0(unique(y),collapse = "")})
currentPatient <- agg$patient[agg$handling == valueText]
patients10() %>%
filter(patient %in% currentPatient)
})
}
shinyApp(ui, server)
请帮助.
推荐答案
我添加了dplyr包
library(dplyr)
因为您已经完成了捕获事件的所有艰苦工作，所以我将tr.df的计算移动到单独的反应堆之后更改了服务器，以便可以将其再次用于表和y值之后的过滤器密谋事件.
since you already had done all the hard work catching the events from plotly I changed the server following moving the calculation of tr.df into seperate reactive so that I could use it again for the table and the filter after the y value the plotly event.
server <- function(input, output)
{
dta <- reactive({
tr <- data.frame(traces(patients, output_traces = T, output_cases = F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
output$sankey_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br> Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 380, width = 605)
})
output$sankey_table <- renderDataTable({
req(event_data("plotly_click"))
dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
})
}
**第二部分** 对于server.r，我是否添加了以下反应式功能
** Second Part ** For the server.r did I add the followning reactive function
patients3 <- reactive({
patients1 <- arrange(patients, patient)
patients2 <- patients1 %>% arrange(patient, time,handling_id)
patients2 %>%
group_by(patient) %>%
mutate(time = as.POSIXct(time, format = "%m/%d/%Y %H:%M"),diff_in_sec = time - lag(time)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
，并相应地更改了renderDataTable
output$sankey_table <- renderDataTable({
req(event_data("plotly_click"))
Values <- dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
patient <- patients3()[["patient"]] %>% unique()
result = NULL
for(p in patient){
handlings <- patients3() %>%
filter(patient == p) %>%
`$`(handling) %>%
unique()
if(sum(!is.na(Values)) == length(handlings) &&
all(handlings %in% Values[[1]])){
result <- rbind(result,
patients3() %>%
filter(patient == p))
}
}
result
})
由于您的新桌子要大得多，我是否也将桌子的盒子改成这样
Since your new table is a lot bigger would I also change the box for the table to something like this
box( title = "Case Summary", status = "primary", solidHeader
= T,
dataTableOutput("sankey_table"),
width = 8)
总共看起来像这样
ui <- dashboardPage(
dashboardHeader(title = "My Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Data Path", status = "primary",height = "455" ,solidHeader = T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", solidHeader
= T,
dataTableOutput("sankey_table"),
width = 8)
)
)
server <- function(input, output)
{
dta <- reactive({
tr <- data.frame(traces(patients, output_traces = T, output_cases = F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
patients3 <- reactive({
patients1 <- arrange(patients, patient)
patients2 <- patients1 %>% arrange(patient, time,handling_id)
patients2 %>%
group_by(patient) %>%
mutate(time = as.POSIXct(time, format = "%m/%d/%Y %H:%M"),diff_in_sec = time - lag(time)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
output$sankey_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br> Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 380, width = 605)
})
output$sankey_table <- renderDataTable({
req(event_data("plotly_click"))
Values <- dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
patient <- patients3()[["patient"]] %>% unique()
result = NULL
for(p in patient){
handlings <- patients3() %>%
filter(patient == p) %>%
`$`(handling) %>%
unique()
if(sum(!is.na(Values)) == length(handlings) &&
all(handlings %in% Values[[1]])){
result <- rbind(result,
patients3() %>%
filter(patient == p))
}
}
result
})
}
希望这会有所帮助！
**加速**
数据表计算中的foor循环要花很多时间，这是为了加快计算速度
the foor loop in the calculations of the datatable is taking quite some time here is a speed up for that calculation
output$sankey_table <- renderDataTable({
req(event_data("plotly_click"))
Values <- dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
valueText <- paste0(Values[[1]] %>% na.omit(),collapse = "")
agg <- aggregate(handling~patient, data = patients3(), FUN = function(y){paste0(unique(y),collapse = "")})
currentPatient <- agg$patient[agg$handling == valueText]
patients3() %>%
filter(patient %in% currentPatient) %>%
DT::datatable(options = list(scrollX = TRUE))
})
这篇关于在R Shiny的数据表中显示活动详细信息的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
