(R) 有条件地格式化 Table 中的单元格

Question

我的 R Shiny 仪表板有 2 个不同的问题我希望大家能帮助我：

1.) 我正在尝试使用动态数据 table 允许用户 select 按组和月平均的指标，并且 table 将根据指标的 selection。现在，table 适当更新，但它输出错误的数字。有人可以看看这有什么问题吗？

2.) 我在使用此处找到的示例时遇到了一些问题：https://rstudio.github.io/DT/010-style.html 根据它们的值突出显示 table 中的单元格。

这是一个可重现的数据示例：

Group=c('A','B','B','A','C','A','C','A','B','B')
Date=c("2019-03-14","2019-03-21","2019-03-28","2019-04-04","2019-04-09",
   "2019-04-18","2019-05-02","2019-05-14","2019-05-23","2019-05-30")
Metric1=c(15,20,45,22,19,25,24,34,20,10)
Metric2=c(500, 510, 520, 540, 539, 645, 600, 585, 534, 589)
Metric3=c(100,110,120,130,140,140,150,155,155,167)

data=as.data.frame(cbind(Group, Date, Metric1, Metric2, Metric3))

这是我用来生成仪表板的代码：

#Load libraries
library(lubridate)
library(shiny)
library(shinydashboard)
library(DT)
library(ggplot2)
library(zoo)
library(dplyr)


#Manipulate data
data$YearMon=as.yearmon(data$Date)
Year_Month=unique(data$YearMon)
MetricChoices=c("Metric1", "Metric2","Metric3")


# Define UI for application 
 ui = fluidPage(
    titlePanel("Data Analysis"),
    dashboardPage(
      dashboardHeader(title=""),
      dashboardSidebar(
         sidebarMenu(
          menuItem("Metrics",
                   tabName = "heat_table",
                   icon=icon("calculator")
          ),
          selectInput(inputId = "metricselect",label="Select a Metric:",choices=MetricChoices)

        )
       ),
      dashboardBody(
        tabItems(

          tabItem(
             tabName = "heat_table",
            DTOutput("heat_table")
          )

        )
      )
     )
   )

# Define server logic 
server <- function(input, output) {

    HighlightTableData=reactive({

     #Make the highlight table 

     subdata = data %>%
      select(Group,YearMon,input$metricselect)

     subdata=data.frame(subdata)
     subtable=as.data.frame(aggregate(x=as.numeric(subdata[,3]),
                                      by=list(as.factor(subdata[,1]),
                                              as.factor(subdata[,2])),
                                     FUN=mean))
     subtable$x=round(subtable$x,2)

     library(reshape)
     subtable2=as.matrix(reshape(subtable,direction="wide",
                                 v.names="x",
                                 timevar="Group.2",
                                 idvar="Group.1"))
     Year.Mon=as.character(unique(subtable$Group.2))
     colnames(subtable2)=c("Group",Year.Mon)
     return(subtable2)

  })
   output$heat_table=renderDT({

   # brks <- quantile(HighlightTableData()[-1], probs = seq(.05, .95, .05), na.rm = TRUE)
   # clrs <- round(seq(255, 40, length.out = length(brks) + 1), 0) %>%
   # {paste0("rgb(255,", ., ",", ., ")")}

    datatable(HighlightTableData(),rownames=FALSE,
              options = list(scrollX = TRUE,
                             lengthChange=FALSE,
                             dom = 't'))# %>%

     # formatStyle(Year_Month, backgroundColor = styleInterval(brks, clrs))
  })  
}

# Run the application 
shinyApp(ui = ui, server = server)

注释掉的行试图创建一个带有突出显示单元格的 table。取消注释时，我收到一条错误消息，"non-numeric argument to binary operator."

有人可以帮我指明正确的方向吗？我不确定如何解决这些问题。如有任何帮助，我们将不胜感激！

谢谢！

Answer 1

想通了 - 必须砍掉在反应代码块中创建的 table 的第一列，以匹配在 renderDT 部分中格式化的列。然后，将 rownames=FALSE 切换为 TRUE。

代码如下：

 HighlightTableData=reactive({

  #Make the highlight table static first

  subdata = mydata %>%
    dplyr::select(Location,YearMon,input$metricselect)

  subdata=data.frame(subdata)
  subtable=as.data.frame(aggregate(x=subdata[,3],
                                 by=list(subdata[,1],
                                         subdata[,2]),
                                 FUN=mean))
  subtable$x=round(subtable$x,0)

  library(reshape)
  subtable2=as.data.frame(reshape(subtable,direction="wide",
                             v.names="x",
                             timevar="Group.2",
                             idvar="Group.1"))
  Year.Mon=as.character(unique(subtable$Group.2))
  colnames(subtable2)=c("Studio",Year.Mon)
  subtable3=subtable2[-1]
  rownames(subtable3)=c(unique(mydata$Location))
  return(subtable3)




 })

output$heat_table=renderDT({

   brks <- quantile(HighlightTableData(), probs = seq(.05, .95, .05), na.rm = TRUE)
  clrs <- round(seq(255, 40, length.out = length(brks) + 1), 0) %>%
  {paste0("rgb(255,", ., ",", ., ")")}

  datatable(HighlightTableData(),rownames=TRUE,
            options = list(scrollX = TRUE,
                           lengthChange=FALSE,
                           dom = 't')) %>%
 formatStyle(names(subtable3), backgroundColor = styleInterval(brks, clrs))

 })

(R) 有条件地格式化 Table 中的单元格

(R) Conditionally Format Cells in Table

datatable

formatting

dashboard

r

shiny