Question

我正在尝试修改函数dateRangeInput和updateDateRangeInput以便：

允许日历选择器中的最小级别为月份（而不是默认的每日最低级别），即引入新的参数minviewmode =＆＃34; days＆＃34;，＆＃34; months＆＃34;。< / LI>
允许函数updateDateRangeInput修改参数格式，startview和minviewmode，以便从daterangeinput切换到每日日历选择器到具有月度日历选择器的日期。

使用Display only months in dateRangeInput or dateInput for a shiny app [R programming]我可以解决1。

我试图解决这个问题。

library(shiny)

#### check for updates at https://github.com/rstudio/shiny/blob/master/R/input-daterange.R
dateRangeMonthsInput <- function(inputId, label, start = NULL, end = NULL,
                       min = NULL, max = NULL, format = "yyyy-mm-dd", startview = "month", minviewmode = "days",
                       weekstart = 0, language = "en", separator = " to ", width = NULL) {

 # If start and end are date objects, convert to a string with yyyy-mm-dd format
 # Same for min and max
 if (inherits(start, "Date"))  start <- format(start, "%Y-%m-%d")
 if (inherits(end,   "Date"))  end   <- format(end,   "%Y-%m-%d")
 if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
 if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")

 restored <- restoreInput(id = inputId, default = list(start, end))
 start <- restored[[1]]
 end <- restored[[2]]

 attachDependencies(
  div(id = inputId,
    class = "shiny-date-range-input form-group shiny-input-container",
    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),

    controlLabel(inputId, label),
    # input-daterange class is needed for dropdown behavior
    div(class = "input-daterange input-group",
        tags$input(
          class = "input-sm form-control",
          type = "text",
          `data-date-language` = language,
          `data-date-week-start` = weekstart,
          `data-date-format` = format,
          `data-date-start-view` = startview,
          `data-date-min-view-mode` = minviewmode,
          `data-min-date` = min,
          `data-max-date` = max,
          `data-initial-date` = start
        ),
        span(class = "input-group-addon", separator),
        tags$input(
          class = "input-sm form-control",
          type = "text",
          `data-date-language` = language,
          `data-date-week-start` = weekstart,
          `data-date-format` = format,
          `data-date-start-view` = startview,
          `data-date-min-view-mode` = minviewmode,
          `data-min-date` = min,
          `data-max-date` = max,
          `data-initial-date` = end
          )
       )
   ),
   datePickerDependency
 )
}

`%AND%` <- function(x, y) {
  if (!is.null(x) && !is.na(x))
    if (!is.null(y) && !is.na(y))
     return(y)
  return(NULL)
}


#### check the current version at https://github.com/rstudio/shiny/blob/master/R/input-date.R
controlLabel <- function(controlName, label) {
  label %AND% tags$label(class = "control-label", `for` = controlName, label)
}

#### check the current version at https://github.com/rstudio/shiny/blob/master/R/input-date.R
datePickerDependency <- htmlDependency(
  "bootstrap-datepicker", "1.6.4", c(href = "shared/datepicker"),
  script = "js/bootstrap-datepicker.min.js",
  stylesheet = "css/bootstrap-datepicker3.min.css",
  # Need to enable noConflict mode. See #1346.
  head = "<script>
  (function() {
  var datepicker = $.fn.datepicker.noConflict();
  $.fn.bsDatepicker = datepicker;
  })();
  </script>")

#### check for updates at https://github.com/rstudio/shiny/blob/master/R/update-input.R
updateDateRangeMonthsInput <- function(session, inputId, label = NULL,
                                  start = NULL, end = NULL, min = NULL,
                                  max = NULL
                                  # , format = "yyyy-mm-dd", startview = "month", minviewmode = "days"
                                  ) {
   # Make sure start and end are strings, not date objects. This is for
   # consistency across different locales.
   if (inherits(start, "Date"))  start <- format(start, '%Y-%m-%d')
   if (inherits(end, "Date"))    end <- format(end, '%Y-%m-%d')
   if (inherits(min, "Date"))    min <- format(min, '%Y-%m-%d')
   if (inherits(max, "Date"))    max <- format(max, '%Y-%m-%d')

   message <- dropNulls(list(
     label = label,
     value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max,
     format = format,
     startview = startview,
     minviewmode = minviewmode
   ))

   session$sendInputMessage(inputId, message) ## <- https://github.com/rstudio/shiny/blob/master/R/shiny.R
 }

#### check for updates at https://github.com/rstudio/shiny/blob/master/R/utils.R
dropNulls <- function(x) {
  x[!vapply(x, is.null, FUN.VALUE=logical(1))]
}

ui <- basicPage(dateRangeMonthsInput("dateRange",label = "Periodo :", format = "yyyy-mm",
                                 startview = "year",
                                 minviewmode = "months", start = NULL, end = NULL),
            actionButton(inputId = "daily", label = "month")
)
server <- shinyServer(function(input, output, session){

  observeEvent(input$month,{updateDateRangeInputMonth(session,
                                                  "dateRange",
                                                  start = Sys.Date()-10,
                                                  end = Sys.Date()- 5,
                                                  format = "yyyy-mm-dd",
                                                  startview = "month",
                                                  minviewmode = "days"
                                                   )})
})

shinyApp(ui = ui, server = server)

尽管new updateDateRange函数更新了开始/结束值，但它既不会改变格式，也不会改变startview和minviewmode。

知道为什么吗？

修改dateRangeInput和updateDateRangeInput

0 个答案: