对表格中的单元格进行条件格式

Question

我的 R Shiny 仪表板有两个单独的问题：

1.）我试图拥有一个动态数据表，允许用户选择按组和月份平均的指标，并且该表将根据指标的选择自动更新。 现在，该表已正确更新，但输出了错误的数字。 有人可以看一下这有什么问题吗？

2.）我在使用在这里找到的示例时遇到了一些麻烦：https://rstudio.github.io/DT/010-style.html根据单元格的值突出显示表格中的单元格。

这是数据的可重现示例：

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)

注释掉的行尝试创建一个包含突出显示单元格的表格。 取消注释时，我收到一条错误，内容为“二元运算符的非数字参数。”

有人可以帮我指出正确的方向吗？

Answer 1

弄清楚了 - 必须砍掉在反应性代码块中创建的表的第一列，以匹配在 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))

 })