R闪亮

时间：2017-11-22 11:33:05

标签： r shiny plotly dt ggplotly

当我在下面运行这个R闪亮的脚本时，我会得到两个图表，其中包含一个活动路径图表，该图表来自左侧名为trace explorer的bupaR库的患者数据集，以及一个显示活动/跟踪详细信息的数据表。左边的图表是这样的，我们观察到各种路径，其中一系列活动的水平痕迹一个接一个地出现。单击特定跟踪中的任何框时，跟踪详细信息将显示在右侧表中。我的要求是，当点击特定轨迹中的任何框时，＆＃34; y＆＃34;或者第四列值应该是动态的，我应该只得到一列显示跟踪中发生的所有活动。例如。在附图中，当点击最底部路径上的任何位置时，我应该得到一个包含活动的列＆＃34;注册＆＃34;，＆＃34;分类和评估＆＃34;。请帮助和谢谢。

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)

Trace Chart

第二部分：

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库中获取患者数据，以便在＆＃34;患者＆＃34;专栏，每个案例中的活动都在＆＃34;处理＆＃34;列，并按其发生时间的升序排列。我的要求是我要比较＆＃34;值＆＃34;从DT表中的先前解决方案获得的列，并与“唯一（处理）＆＃39;即在每种情况下的独特活动＆＃34;患者＆＃34;在patients3数据集中。 ＆＃34;值＆＃34;列找到完全匹配，我想在DT表中显示整个相应的行。例如。当点击最底部路径上的任何地方时，跟踪活动＆＃34;注册＆＃34;，＆＃34;分类和评估＆＃34;，＆＃34;值＆＃34;在每种情况下，应将列与1至500的唯一活动进行比较，如果匹配，即具有活动的案例＆＃34;注册＆＃34;，＆＃34;分类和评估＆＃34;，那些具有相应行的案例应该是显示，类似于所有痕迹。谢谢，请帮助。

第三部分：

我想通过给出合适的pageLength来修复第二个框中的数据表，这样它就不应该从下面和右边过冲。请查看下面的合并代码，我知道要集成在图中的一些可能的语法，以实现这一点，如下所示：

可能的语法：

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)

请帮忙。 DT table capture

1 个答案:

答案 0 :(得分：1)

我添加了包dplyr 

library(dplyr)

因为你已经完成了从剧情中捕捉事件的所有艰苦工作，所以在将tr.df的计算移动到单独的反应之后更改了服务器，以便我可以再次使用它来表和y之后的过滤器重视情节事件。

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，我添加了跟随反应函数

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
  })

由于您的新表格更大，我还会将表格的框更改为此类

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循环在这里需要相当长的时间才能加快计算速度

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))
    })
相关问题
最新问题