在Shiny中计算日期范围的平均值和中位数

Question

Want to calculate mean and median of the numeric variables grouped by a selected date range for the datatable only, not the leaflet data. The leaflet map works (just need to zoom out to see the fake long/lat plots but not worried about that now).

I created a second dataframe df10 for the datatable median/mean summations of the data.

So far tried altering the input function to create separate variables for the mean but found it to be cumbersome and not necessary for my needs.

Attempted to use colMeans(dataset()[,which(sapply(dataset(), class) != "Date")]) here Shiny calculate the mean of columns in dataframe

The error is "invalid 'x' type in 'x && y" . It's in relation to the colmeans

### Generate a dataset ###
start_date <- as.Date('2018-01-01')  
end_date <- as.Date('2019-05-10')   
set.seed(1984)
date1 <- as.Date(sample( as.numeric(start_date): as.numeric(end_date), 988, 
                         replace = T), origin = '1970-01-01')
group <- rep(letters[1:26], each = 38)
x1 <- runif(n = 988, min = 3.26, max = 10)
x2 <- runif(n = 988, min = 3.26, max = 10)
x3 <- runif(n = 988, min = 3.26, max = 10)
x4 <- runif(n = 988, min = 3.26, max = 10)
x5 <- runif(n = 988, min = 3.26, max = 10)
latitude <- runif(988,40.75042,50.75042)
longitude <- runif(988,-73.98928,-63.98928)

dataframe <- cbind(data.frame(date1,group,x1,x2,x3,x4,x5,latitude,longitude))

df10 <- cbind(data.frame(date1,group,x1,x2,x3,x4,x5))
library(lubridate)
dataframe$date <- ymd(dataframe$date1)
df10$date <- ymd(df10$date1)

library(shiny)
library(leaflet)
library(DT)
dataframe$defectrateLvl <- cut(dataframe$x1, 
                               c(3.26,6,100), include.lowest = T,
                               labels = c('3.26-6x','6x+')) 
beatCol <- colorFactor(palette = c('yellow', 'red'), dataframe$defectrateLvl)


ui <- fluidPage(
  dateInput(inputId = "date", label="Select a date", value = "2019-03-01", min = "2018-01-01", max = "2019-05-10",
            format = "yyyy-mm-dd", startview = "month",
            language = "en", width = NULL),
  leafletOutput("map"),
  fluidRow(
    dateRangeInput("daterange","Date range:",start=Sys.Date()-10, end=Sys.Date() -1),
    DT::dataTableOutput("tbl")
  )
)

server <- shinyServer(function (input, output,session) {
  dailyData <- reactive(dataframe[dataframe$date == format(input$date, '%Y/%m/%d'), ] )
  output$map <- renderLeaflet({
    dataframe <- dailyData()  # Added this in attempt to integrate
    dataframe %>% leaflet() %>% 
      setView(lng = -73.98928, lat = 40.75042, zoom = 10) %>%
      addProviderTiles("CartoDB.Positron", options = providerTileOptions(noWrap = TRUE)) %>%
      addCircleMarkers(
        lng=~dataframe$longitude, # Longitude coordinates
        lat=~dataframe$latitude, # Latitude coordinates
        #radius=~defectrateLvl, # Total count
        popup =~ dataframe$group,
        color = ~beatCol(dataframe$defectrateLvl),
        fillOpacity=0.5 # Circle Fill Opacity
      )
  })  
  output$tbl<-DT::renderDataTable({
    dataset <- reactive({df10 })
    dataset() %>% group_by(group) %>% 
      filter(date > input$daterange[1],
             date < input$daterange[2])
    #sapply(Filter(is.numeric, df6), mean)
    colMeans(dataset()[,which(sapply(dataset(), class) !="date","date1","group")])
  })

})


shinyApp(ui, server)

I expect to have the numeric variables to be summarized by mean and if possible by median but that's less important at this time. Any help would be greatly appreciated.

Answer 1

The error is caused by the last function.

colMeans(df[,which(sapply(df, class) !="date","date1","group")])

This code will apply the function to all columns which are not of class xy. "date" or "group" are column names.

ColMeans also produces a numeric vector, which will result in an error, because DT can only display a matrix or a data.frame. I provided you a code with creates a dataframe. But in generell I would think about using dplyr to create your result. It is much easier.

Here is a solution that works, however you have to change the dateinputs, since the predefined selection creates a data.frame with 0 rows.

library(lubridate)
library(shiny)
library(leaflet)
library(DT)
library(dplyr)

### Generate a dataset ###
start_date <- as.Date('2018-01-01')  
end_date <- as.Date('2019-05-10')   
set.seed(1984)
date1 <- as.Date(sample( as.numeric(start_date): as.numeric(end_date), 988, 
                         replace = T), origin = '1970-01-01')
group <- rep(letters[1:26], each = 38)
x1 <- runif(n = 988, min = 3.26, max = 10)
x2 <- runif(n = 988, min = 3.26, max = 10)
x3 <- runif(n = 988, min = 3.26, max = 10)
x4 <- runif(n = 988, min = 3.26, max = 10)
x5 <- runif(n = 988, min = 3.26, max = 10)
latitude <- runif(988,40.75042,50.75042)
longitude <- runif(988,-73.98928,-63.98928)

dataframe <- cbind(data.frame(date1,group,x1,x2,x3,x4,x5,latitude,longitude))

df10 <- cbind(data.frame(date1,group,x1,x2,x3,x4,x5))
dataframe$date <- ymd(dataframe$date1)
df10$date <- ymd(df10$date1)


dataframe$defectrateLvl <- cut(dataframe$x1, 
                               c(3.26,6,100), include.lowest = T,
                               labels = c('3.26-6x','6x+')) 
beatCol <- colorFactor(palette = c('yellow', 'red'), dataframe$defectrateLvl)


ui <- fluidPage(
    dateInput(inputId = "date", label="Select a date", value = "2019-03-01", min = "2018-01-01", max = "2019-05-10",
              format = "yyyy-mm-dd", startview = "month",
              language = "en", width = NULL),
    leafletOutput("map"),
    fluidRow(
        dateRangeInput("daterange","Date range:",start=Sys.Date()-10, end=Sys.Date() -1),
        DT::dataTableOutput("tbl")
    )
)

server <- shinyServer(function (input, output,session) {
    dailyData <- reactive(dataframe[dataframe$date == format(input$date, '%Y/%m/%d'), ] )
    output$map <- renderLeaflet({
        dataframe <- dailyData()  # Added this in attempt to integrate
        dataframe %>% leaflet() %>% 
            setView(lng = -73.98928, lat = 40.75042, zoom = 10) %>%
            addProviderTiles("CartoDB.Positron", options = providerTileOptions(noWrap = TRUE)) %>%
            addCircleMarkers(
                lng=~dataframe$longitude, # Longitude coordinates
                lat=~dataframe$latitude, # Latitude coordinates
                #radius=~defectrateLvl, # Total count
                popup =~ dataframe$group,
                color = ~beatCol(dataframe$defectrateLvl),
                fillOpacity=0.5 # Circle Fill Opacity
            )
    })  

    dataset <- reactive({df10 })

    output$tbl <-DT::renderDataTable({
        df <- dataset()

        df <- df %>% 
            group_by(group) %>% 
            filter(date > input$daterange[1],
                   date < input$daterange[2])
        #sapply(Filter(is.numeric, df6), mean)
        result <- data.frame(colMeans(df[which(sapply(df, class)=="numeric")]))
        colnames(result)[1] <- "Result"
        result
        #colMeans(df[,which(sapply(df, class) !="date","date1","group")])
    })

})


shinyApp(ui, server)