在闪亮的代码中使用 mapply 函数而不是 apply 函数

Question

我想生成与我得到的相同的结果，但我不想使用 apply 函数，而是想在 data_subset.[=18 中使用 mapply 函数=]

这个问题与这个问题非常相似：

所以不用 em data_subset:

All <- cbind(df2, coef = apply(df2, 1, function(x) {return_coef(data(),as.numeric(x[1]),as.Date(x[2]),x[3],var1,var2)}))

我想要下面这样的东西。这与我之前提到的已解决问题类似：

  All<-Datas%>%
    transmute(
    Id,date2, Category,
     coef = mapply(return_coef, list(cur_data()), as.numeric(Id),as.Date(date2), Category, var1 , var2))

从下图中您可以看到我得到了不同的结果。但是，我认为值必须相同。

library(shiny)
library(dplyr)
library(tidyr)
library(lubridate)


df1 <- structure(
  list(
    Id = c(1, 1, 1, 1),
    date1 = c("2022-01-06","2022-01-06","2022-01-06","2022-01-06"),
    date2 = c("2022-01-02","2022-01-03","2022-01-09","2022-01-10"),
    Week = c("Sunday","Monday","Sunday","Monday"),
    Category = c("EFG", "ABC","EFG","ABC"),
    DR1 = c(0, 0, 0, 0),
    DRM0 = c(300, 300, 300, 300),
    DRM01 = c(300, 300, 300, 300),
    DRM02 = c(300,300,300,300),
    DRM03 = c(300,300,300,300),
    DRM04 = c(300,250,350,350)),row.names = c(NA, 4L), class = "data.frame")


return_coef <- function(df1, idd,dmda, CategoryChosse, var1, var2) {
  
  
  x<-df1 %>% select(starts_with("DRM"))
  
  x<-cbind(df1, setNames(df1$DR1 - x, paste0(names(x), "_PV")))
  PV<-select(x,Id, date2,Week, Category, DR1, ends_with("PV"))
  
  med<-PV %>%
    group_by(Id,Category,Week) %>%
    dplyr::summarize(dplyr::across(ends_with("PV"), median),.groups = 'drop')
  
  SPV<-df1%>%
    inner_join(med, by = c('Id','Category', 'Week')) %>%
    mutate(across(matches("^DRM\d+$"), ~.x + 
                    get(paste0(cur_column(), '_PV')),
                  .names = '{col}_{col}_PV')) %>%
    select(Id:Category, DRM0_DRM0_PV:last_col())
  
  SPV<-data.frame(SPV)
  
  mat1 <- df1 %>%
    dplyr::filter(Id==idd,date2 == ymd(dmda), Category == CategoryChosse) %>%
    select(starts_with("DRM")) %>%
    pivot_longer(cols = everything()) %>%
    arrange(desc(row_number())) %>%
    mutate(cs = cumsum(value)) %>%
    dplyr::filter(cs == 0) %>%
    pull(name)
  
  (dropnames <- paste0(mat1,"_",mat1, "_PV"))
  
  SPV <- SPV %>%
    filter(Id==idd,date2 == ymd(dmda), Category == CategoryChosse) %>%
    select(-any_of(dropnames))
  
  if(length(grep("DRM", names(SPV))) == 0) {
    SPV[head(mat1,20)] <- NA_real_
  }
  
  datas <-SPV %>%
    filter(Id==idd,date2 == ymd(dmda)) %>%
    group_by(Category) %>%
    summarize(across(starts_with("DRM"), sum),.groups = 'drop') %>%
    pivot_longer(cols= -Category, names_pattern = "DRM(.+)", values_to = "val") %>%
    mutate(name = readr::parse_number(name))
  colnames(datas)[-1]<-c(var1,var2)
  datas$days <- datas[[as.name(var1)]]
  datas$numbers <- datas[[as.name(var2)]]
  
  datas <- datas %>% 
    group_by(Category) %>% 
    slice((ymd(dmda) - min(as.Date(df1$date1) [
      df1$Category == first(Category)])):max(days)+1) %>%
    ungroup
  
  mod <- lm(numbers ~ I(days^2), datas)
  coef<-coef(mod)[1]
  val<-as.numeric(coef(mod)[1])
  
  
  return(val)
  
}

ui <- fluidPage(
                    br(),
                    tabPanel("PAGE1",
                             sidebarLayout(
                               sidebarPanel(
                                 uiOutput('daterange')
                                 
                               ),
                               mainPanel(
                                 dataTableOutput('table')
                               ))))


server <- function(input, output) {
  
  data<-reactive(df1)
  
  output$daterange <- renderUI({
    req(data())
    dateRangeInput("daterange1", "",
                   min = min(data()$date1),
                   max   = max(data()$date2),
                   format = "dd-mm-yyyy")
    
  })
  
  data_subset <- reactive({
    req(input$daterange1)
    req(input$daterange1[1] <= input$daterange1[2])
    var1 = "Days"
    var2 = "Numbers"
    days <- seq(input$daterange1[1], input$daterange1[2], by = 'day')
    df1<-subset(data(), as.Date(date2) %in% days)
    Datas <- subset(df1, date2 >= date1)
    df2 <- Datas %>% select(Id,date2,Category)
    All <- cbind(df2, coef = apply(df2, 1, function(x) {return_coef(data(),as.numeric(x[1]),as.Date(x[2]),x[3],var1,var2)}))
    
   })
  
  output$table <- renderDataTable({
    
    data_subset()
  })
}

shinyApp(ui = ui, server = server)

Answer 1

问题在于，在您的原始 apply 代码中，您使用的是 data()，这是闪亮的 full 数据集；但是在你使用 mapply 的尝试中，你使用的是 cur_data()，这是 dplyr 的说法（在这种情况下）Datas，一个子集整个数据集的。

如果您替换之前的作业

    All <- cbind(df2, coef = apply(df2, 1, function(x) {
      return_coef(data(), as.numeric(x[1]), as.Date(x[2]), x[3], var1, var2)
    }))

和

    All <- Datas %>%
      transmute(
        Id, date2, Category,
        coef = mapply(return_coef, list(data()), Id, as.Date(date2), Category, var1, var2)
      )
    All
#   Id      date2 Category      coef
# 3  1 2022-01-09      EFG -32.14286
# 4  1 2022-01-10      ABC  50.00000

它按预期工作。

在闪亮的代码中使用 mapply 函数而不是 apply 函数

Use mapply function instead of apply function in shiny code

r

shiny