问题
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)
Second Part:
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))
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.
Third Part:
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:
Possible syntax:
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)
Please help.
回答1:
I added the package dplyr
library(dplyr)
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)
})
}
** 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))
})
and changed the renderDataTable accordingly
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)
all in all together it looks something like this
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
})
}
Hope this helps!
** Speed Up **
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))
})
来源：https://stackoverflow.com/questions/47433655/diplaying-activity-details-in-a-data-table-in-r-shiny