Diplaying activity details in a data table in R shiny
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.
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))
})
- Create multiple lagged variables with different offsets
- Expanding dataframe to include non existing values
- Split string to columns based on paragraph ending from ocr'd image
- from magick-image to rasterBrick
- How to remove repeated elements in a vector, similar to 'set' in Python
- Rename multiple variables at once using dplyr
- Reading large multi-part table from file and combing its parts into one tibble
- Processing multiple images with Magick (in R) with transformations
- R: Convert/Read 3D Matrix into a 'magick' object and vice versa
- Error using magick R to import PDF
- Method in R to crop whitespace on svg file
- Read table from a website into R Studio and create a dataframe with the info
- Perspective transformation using R and magick
- R magick: Square crop and circular mask
- r piping image_annotate doesn't work as expected
- reading text portion from list of images and saving in R, using magick
- Difference betweeen Fix and Edit in R
- Conditional coloring in the Flextable in R
- Fast NMF in R on sparse matrices
- cannot find -lMagick++-6.Q16
- Suppressing output from ImageMagick when calling function from the R Animation package
- How to identify relevant strings in this emmeans() output
- Why is message() a better choice than print() in R for writing a package?
- How can I prevent my computer from crashing when running R-script on large dataset
- Crop out circle from image and lay over second image
- R: Swap two variables without using a third
- Literal curly brackets in gtsummary
- Hide "Panel" row from rbinded modelsummary tables
- Ignoring NA cases when getting column index of lowest value in row
- Is there a way to change the color of the tab_spanner when creating a gt table?