r语言 - 在DT单元格内添加一个指示箭头，该箭头将显示每个时间段的趋势

Question

我创建了一个闪亮的应用程序，该应用程序使用下面的数据帧进行汇总，Dealer根据我们处于最近日期("2020-01-09"(的事实显示前一天的name计数和过去 3 天的name计数。

现在，我想在每个选定的周期(单元格(中添加一个指示箭头，该箭头将显示相对于相同长度的最后一个时间段的趋势，因此例如，您可以计算 3 天的平均name数，然后在后台计算前 3 天。前一天也一样。箭头将指示显示的是更高还是更低。我在这里根据这个答案工作。

library(shiny)
library(shinydashboard)
library(dplyr)
name<-c("John","John","John","John","John","John","John")
Dealer<-c("ASD","ASD","ASD","ASD","ASD","ASD","ASD")
Date<-c("2020-01-03","2020-01-04","2020-01-05","2020-01-06","2020-01-07","2020-01-08","2020-01-09")
dataset<-data.frame(name,Dealer,Date)
new<-dataset %>%
mutate(Date = as.Date(Date)) %>%
arrange_all %>%
group_by(Dealer) %>%
summarise(PreviousDay = sum(Date == last(Date) - 1), 
PreviousThree = sum(Date %in% (last(Date) - 3) : last(Date)))
new2<-dataset %>%
mutate(Date = as.Date(Date)) %>%
arrange_all %>%
group_by(Dealer) %>%
summarise(PreviousDay = sum(Date == last(Date) - 2), 
PreviousThree = sum(Date %in% (last(Date) - 6) : last(Date)))
total<-rbind(new,new2)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(box(width = 12, solidHeader = TRUE,
tableOutput("example_table"))
)
)
ui <- dashboardPage(dashboardHeader(title = "Example"),
sidebar,
body
)

server <- function(input, output) {
output$example_table <- renderTable(total)
}
shinyApp(ui, server)

Answer 1

根据您的示例，这是我所做的：

library(shiny)
library(shinydashboard)
library(dplyr)
library(formattable)
name<-c("John","John","John","John","John","John","John")
Dealer<-c("ASD","ASD","ASD","ASD","ASD","ASD","ASD")
Date<-c("2020-01-03","2020-01-04","2020-01-05","2020-01-06","2020-01-07","2020-01-08","2020-01-09")
dataset<-data.frame(name,Dealer,Date)
new<-dataset %>%
mutate(Date = as.Date(Date)) %>%
arrange_all %>%
group_by(Dealer) %>%
summarise(PreviousDay = sum(Date == last(Date) - 1), 
PreviousThree = sum(Date %in% (last(Date) - 3) : last(Date))) %>%
mutate(period = 2)
new2<-dataset %>%
mutate(Date = as.Date(Date)) %>%
arrange_all %>%
group_by(Dealer) %>%
summarise(PreviousDay = sum(Date == last(Date) - 2), 
PreviousThree = sum(Date %in% (last(Date) - 6) : last(Date))) %>%
mutate(period = 1)
total<-rbind(new,new2) %>%
arrange(period)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(box(width = 12, solidHeader = TRUE,
formattableOutput("example_table"))
)
)
ui <- dashboardPage(dashboardHeader(title = "Example"),
sidebar,
body
)

server <- function(input, output) {
output$example_table <- renderFormattable({
improvement_formatter <- formatter("span", 
style = x ~ style(font.weight = "bold", 
color = ifelse(x-lag(x) > 0, "green", 
  ifelse(x-lag(x) < 0, "red", "black"))), 
x ~ icontext(ifelse(x-lag(x)>0, "arrow-up", 
ifelse(x-lag(x)<0, "arrow-down", "")), 
x)
)
formattable(total, list(
`PreviousThree` = improvement_formatter,
`PreviousDay` = improvement_formatter)
)
})
}
shinyApp(ui, server)

在formatter中，我使用x-lag(x)符号来确定数字的颜色和箭头的方向，因为你想要两个周期之间的演变。这需要在最终数据帧中创建一个列周期，以确定lag(x)的值是多少。如果不想显示列period，可以在formattable中放置total[, -4]而不是total。

我不知道这个解决方案是否可以很容易地推广，但至少它是一个工作基础。

请参阅此处以自定义formattable。