использование tapply внутри блестящего для создания сводных выходных данных

Код ниже воспроизводим:

library(shiny)
library(Rcpp)
library(ggmap)
library(htmlwidgets)
library(leaflet)

crime2 <- crime[1:50,]

ui <- fluidPage(
  titlePanel("Unusual Observations"),

  sidebarLayout(
    sidebarPanel(
      helpText("Create maps with 
        information from the Crime Data"),

      selectInput("var", 
              label = "Choose a variable to display",
              choices = c("Hour",
                          "Number"),
              selected = "Hour"),

      sliderInput("range", 
              label = "Range of interest:",
              min = 0, max = 10, value = c(1, 2))
    ),

    mainPanel(leafletOutput("map"))
  ),

  verbatimTextOutput("stats")
)

server <- function(input, output) {
  output$map <- renderLeaflet({
    data <- switch(input$var,
               "hour" = crime2$hour,
               "number" = crime2$number)

    getColor <- function(data){sapply(data, function(var){
       if(input$var< input$range[1]) {
         "green"
       } else if(input$var <= input$range[2]) {
         "orange"
       } else {
         "red"
        } })
    }

  icons <- awesomeIcons(
  icon = 'ios-close',
  iconColor = 'black',
  library = 'ion',
  markerColor = getColor(crime2)
)

    leaflet(crime2) %>%
      addTiles() %>%
      addAwesomeMarkers(~lon, ~lat, icon=icons)

  })

  output$stats <- renderPrint({
    with(crime2, tapply(input$var, list(type), summary))
  })
}

shinyApp(ui=ui, server=server)

Для вывода статистики я получаю сообщение об ошибке:

Ошибка: аргументы должны иметь одинаковую длину.

Кто-нибудь знает, как решить проблему? Кроме того, у меня также все виджеты отображаются красным цветом, но у меня есть еще один пост с вопросом о проблеме с виджетами. Был бы очень признателен, если бы кто-нибудь мог помочь мне с этим. Заранее спасибо!


r leaflet shiny tapply
person glor    schedule 28.06.2018    source источник

Ответы (1)


arrow_upward
1
arrow_downward

Отладка:

Если мы отлаживаем ваш код, я вижу, что вы пытаетесь сделать это:

crime2 <- crime[1:50,]
with(crime2, tapply("Hour", list(type), summary))

Вне блестящего, я бы предположил, что ваш желаемый результат:

with(crime2, tapply(X = hour, INDEX = type, FUN = summary))

В блестящем вы хотите получить доступ через ввод, поэтому с персонажем. Поэтому вы можете переписать свой код на:

tapply(X = unlist(crime2["hour"]), INDEX = crime2$type, FUN = summary)

или динамически:

tapply(X = unlist(crime2[input$var]), INDEX = crime2$type, FUN = summary)

.

Полностью воспроизводимый пример:

(input$var варианты должны быть изменены на нижний регистр, чтобы включить индексацию,...)

library(shiny)
library(Rcpp)
library(ggmap)
library(htmlwidgets)
library(leaflet)

crime2 <- crime[1:50,]

ui <- fluidPage(
  titlePanel("Unusual Observations"),

  sidebarLayout(
    sidebarPanel(
      helpText("Create maps with 
               information from the Crime Data"),

      selectInput("var", 
                  label = "Choose a variable to display",
                  choices = c("hour",
                              "number"),
                  selected = "hour"),

      sliderInput("range", 
                  label = "Range of interest:",
                  min = 0, max = 10, value = c(1, 2))
      ),

    mainPanel(leafletOutput("map"))
  ),

  verbatimTextOutput("stats")
  )

server <- function(input, output) {
  output$map <- renderLeaflet({
    data <- switch(input$var,
                   "hour" = crime2$hour,
                   "number" = crime2$number)

    getColor <- function(data){sapply(data, function(var){
      if(input$var< input$range[1]) {
        "green"
      } else if(input$var <= input$range[2]) {
        "orange"
      } else {
        "red"
      } })
    }

    icons <- awesomeIcons(
      icon = 'ios-close',
      iconColor = 'black',
      library = 'ion',
      markerColor = getColor(crime2)
    )

    leaflet(crime2) %>%
      addTiles() %>%
      addAwesomeMarkers(~lon, ~lat, icon=icons)

  })

  output$stats <- renderPrint({
    tapply(X = unlist(crime2[input$var]), INDEX = crime2$type, FUN = summary)
  })
}

shinyApp(ui = ui, server = server)
person Tonio Liebrand    schedule 28.06.2018
comment
Большое спасибо за помощь! Завтра утром посмотрю. Это совершенно нормально, если вы не можете, но не могли бы вы также взглянуть на проблему цвета? Я разместил здесь еще один вопрос: stackoverflow.com/questions/51026647/ - person glor; 29.06.2018