需要帮助找出反应性数据帧中的逻辑错误

Question

我这里有一个应用程序，如果第 2 列和第 3 列中的值不同，则使用 DT 的 formatStyle 函数突出显示第 3 列行。但是，目前我看到所有变异值都在 ifelse 函数中触发“是”子句-

我的 dput of iris.xlsx 看起来像这样-

structure(list(date = structure(c(1356998400, 1357084800, 1359936000, 
1360022400, 1360108800, 1364342400, 1364428800), class = c("POSIXct", 
"POSIXt"), tzone = "UTC"), Sepal.Length = c(5.1, 4.9, 4.9, 5, 
5.5, NA, 6.7), Sepal.Width = c(3.5, NA, NA, NA, NA, 3.4, 3.1), 
    Petal.Length = c(1.4, 1.4, 1.5, 1.2, 1.3, 4.5, 4.7), Petal.Width = c(0.2, 
    0.2, 0.2, 0.2, 0.2, 1.6, 1.5), Species = c("setosa", "setosa", 
    "setosa", "setosa", "setosa", "versicolor", "versicolor")), row.names = c(NA, 
-7L), class = c("tbl_df", "tbl", "data.frame"))

这是我的代表-

library(shiny)
library(readxl)
library(shinyjs)
library(htmltools)
library(lubridate)
library(DT)
library(dplyr)
library(tidyr)


#global.R

local_iris <- data.frame(Date= lubridate::mdy(c("1/1/2013","1/2/2013","3/27/2013","3/28/2013",
                                                "1/18/2013","2/4/2013","2/5/2013","2/6/2013")),
                         SPECLENTH= c(5.1,4.9,4.7,4.6,5,NA,4.6,5.1),
                         SPECWIDTH= c(3,7,6, 8,8,9,5,1))

#ui.R -------------

ui <- fluidPage(
  
  useShinyjs(),
  
  sidebarLayout(
    sidebarPanel(
      
      fileInput("xlsxfile", "Choose an xlsx file",
                accept = c(".xlsx")),
      
      tags$hr(),
      
      # Select variables to display ----
      uiOutput("selectionbox_x"),
      uiOutput("selectionbox_y"),
      
      tags$hr(),
      uiOutput("joinxybutton") 
    ),
    mainPanel(
      DT::DTOutput("contents")
    )
  )
)

#server.R -------------

server <- function(input, output) {
  
  # File handler ----
  mydata <- reactive({
    req(input$xlsxfile)
    inFile <- input$xlsxfile
    
    req(input$xlsxfile,
        file.exists(input$xlsxfile$datapath))
    readxl::read_xlsx(inFile$datapath)
    
  })
  
  # Dynamically generate UI input when data is uploaded, only sow numeric columns ----
  output$selectionbox_x <- renderUI({
    
    selectInput(inputId = "selected_x_var", 
                label = "Select a Varible X: ", 
                choices = c("", names(mydata() %>%
                                        dplyr::select_if(is.numeric))),
                selected = NULL, 
                multiple = FALSE)
  })
  
  # Select columns to print ----
  inputr_var <- reactive({
    req(input$selected_x_var)
    
    inputr_var <- mydata() 
    inputr_var
  })
  
  
  # Same as above but for global.R variable  ----
  output$selectionbox_y <- renderUI({
    
    if (is.null(mydata())) return(NULL)
    
    selectInput(inputId = "selected_y_var", 
                label = "Compare an X with: ", 
                choices = c("", names(local_iris %>%
                                        dplyr::select_if(is.numeric))),
                selected = NULL, 
                multiple = FALSE)
  })
  
  
  globalr_var <- reactive({
    req(input$selected_y_var)
    local_iris 
  })
  
  # Beging on action  ----
  output$joinxybutton <- renderUI({
    if (is.null(input$xlsxfile)) return()
    actionButton("action", "Begin")
  })
  
  # Join the dataframes together based on a key  ----
  joined_dfs <-  eventReactive(input$action, {
    df_joi <- dplyr::inner_join(inputr_var(), globalr_var(), by= c("date" = "Date"))
    df_joi
  })
  
  
  # Render data frame ----
  
  output$contents <- DT::renderDT(server = FALSE, {
    
    req(input$action)
    
    
    DT::datatable(
      
      #***************************************************************#
      # It seems all the values are triggering 'YES' in the mutate!? Not sure why.
      #***************************************************************#
        joined_dfs() %>%
          dplyr::mutate(highlight = tidyr::replace_na(ifelse(input$selected_x_var != input$selected_y_var,
                                      yes= 'y',
                                      no= 'n'), 'n')) %>%
          dplyr::select(date,highlight, input$selected_x_var,input$selected_y_var)
        
    ) %>%
      formatStyle(
        columns = 4,
        valueColumns = 'highlight',
        backgroundColor = styleEqual('y', 'yellow') 
      )
    
  })
  
  # After rendering, hide action button ----
  observeEvent(input$action,{
    shinyjs::toggle("action")
  })
  
  
}

# Run  ----
shinyApp(ui, server)

奇怪的是，我已经测试了我的逻辑，一切正常，但是一旦我在闪亮的应用程序中有类似的实现，逻辑就会中断。

local_iris <- data.frame(Date= lubridate::mdy(c("1/1/2013","1/2/2013","3/27/2013","3/28/2013",
                                                "1/18/2013","2/4/2013","2/5/2013","2/6/2013")),
                         SPECLENTH= c(5.1,4.9,4.7,4.6,5,NA,4.6,5.1),
                         SPECWIDTH= c(3,7,6, 8,8,9,5,1))

imported_iris <- data.frame(date= lubridate::mdy(c("1/1/2013","1/2/2013","2/4/2013","2/5/2013",
                                                   "2/6/2013","3/27/2013","3/28/2013")),
                            Sepal.Length= c(5.1,4.9,4.9,5,5.5,NA,6.7),
                            Sepal.Width= c(3.5,NA,NA,NA,NA,3.4,3.1),
                            Petal.Length= c(1.4,1.4,1.5,1.2,1.3,4.5,4.7),
                            Petal.Width= c(0.2,0.2,0.2,0.2,0.2,1.6,1.5),
                            Species= c("setosa","setosa","setosa","setosa","setosa","versicolor","versicolor"))
  

DT::datatable(
  dplyr::inner_join(imported_iris,local_iris,  by= c("date"="Date")) %>%
    dplyr::mutate(highlight = tidyr::replace_na(ifelse(Sepal.Length != SPECLENTH,
                                                       yes= 'y',
                                                       no= 'n'), 'y')) %>%
    dplyr::select(date, highlight, Sepal.Length,SPECLENTH)
) %>% 
  formatStyle(
    columns = 4,
    valueColumns = 'highlight',
    backgroundColor = styleEqual('y', 'yellow') 
  )

我什至打印出了闪亮的数据框， joinedf() 看起来不错。感谢任何帮助或提示。

Answer 1

替换

dplyr::mutate(highlight = tidyr::replace_na(ifelse(input$selected_x_var != input$selected_y_var,
                                      yes= 'y',
                                      no= 'n'), 'n'))

和

dplyr::mutate(highlight = case_when(.data[[input$selected_x_var]] == .data[[input$selected_y_var]] ~'n', TRUE ~ 'y'))

你得到

需要帮助找出反应性数据帧中的逻辑错误

Need help figuring out the logic error within a reactive dataframe

r

dplyr

shiny

dt

shiny-reactivity