library(shiny)
library(bslib)
library(dplyr)
library(lubridate)
library(plotly)
library(nycflights13)
library(histoslider)
library(rlang)

# Data prep
flights <- flights %>%
  left_join(
    airports %>%
      transmute(dest_name = paste0(name, " (", faa, ")"), dest = faa, end_lat = lat, end_lon = lon)
  ) %>%
  filter(!is.na(dest_name)) %>%
  left_join(
    airports %>% select(origin = faa, start_lat = lat, start_lon = lon)
  ) %>%
  left_join(airlines, by = "carrier") %>%
  rename(carrier_name = name) %>%
  left_join(weather) %>%
  mutate(
    # The overwhelming majority of precipation is 0 so transform
    # with some help from MASS::boxcox() https://stats.stackexchange.com/a/1452/48604
    precip = scales::rescale(precip^-1.55/-.55),
    date = lubridate::ymd(paste(year, month, day, sep = "-"))
  )

PRIMARY <- "#0675DD"

sidebar <- card(
  card_header("Filter controls"),
  uiOutput("origin_reset"),
  checkboxGroupInput(
    "origin",
    span("Origin", icon("plane-departure")),
    choices = sort(unique(flights$origin)),
    inline = TRUE
  ),
  selectInput(
    "dest_name",
    span("Destination", icon("plane-arrival")),
    choices = sort(unique(flights$dest_name)),
    multiple = TRUE,
    width = "100%"
  ),
  selectInput(
    "carrier_name",
    span("Carrier", icon("user-tie")),
    unique(flights$carrier_name),
    multiple = TRUE,
    width = "100%"
  ),
  input_histoslider(
    "sched_dep_time", "Departure time",
    flights$sched_dep_time,
    options = list(
      handleLabelFormat = "0d",
      selectedColor = PRIMARY
    )
  ),
  input_histoslider(
    "sched_arr_time", "Arrival time",
    flights$sched_arr_time,
    options = list(
      handleLabelFormat = "0d",
      selectedColor = PRIMARY
    )
  ),
  input_histoslider(
    "date", "Date",
    flights$date, breaks = "months",
    options = list(
      handleLabelFormat = "%b %e",
      selectedColor = PRIMARY
    )
  )
)


flights_card <- card(
  full_screen = TRUE,
  card_header("Flight paths"),
  card_body_fill(plotlyOutput("flight_paths")),
  card_footer("Marker areas are proportional to mean arrival delay")
)

delay_corr_card <- card(
  full_screen = TRUE,
  card_header(
    "Arrival vs departure delay",
    checkboxInput("scatter_summarize", "Summarize", TRUE, width = "fit-content"),
    class = "d-flex justify-content-between"
  ),
  card_body_fill(plotlyOutput("scatter_delay"))
)

delay_card <- navs_pill_card(
  title = "Arrival delay",
  full_screen = TRUE,
  wrapper = card_body_fill,
  nav(
    "Overall",
    plotlyOutput("arr_delay")
  ),
  nav(
    "Over time",
    plotlyOutput("arr_delay_series")
  )
)

main <- layout_column_wrap(
  width = 1, heights_equal = "row",
  uiOutput("value_boxes", fill = TRUE),
  layout_column_wrap(
    width = "200px", class = "my-3",
    flights_card, delay_corr_card
  ),
  layout_column_wrap(
    width = 1,
    delay_card
  )
)


flights_ui <- layout_column_wrap(
  height = "calc(100vh - 90px)",
  width = NULL, style = "grid-template-columns: 280px 1fr",
  sidebar, main
)


ui <- page_navbar(
  fluid = TRUE,
  theme = bs_theme(
    base_font = font_google(
      "Open Sans", wght = c(300, 400, 500, 600, 700, 800),
      ital = c(0, 1)
    ),
    "primary" = PRIMARY,
    "navbar-bg" = PRIMARY
  ),
  title = tags$span(
    tags$img(
      src = "logo.png",
      style = "width:46px;height:auto;margin-right:24px;"
    ),
    "Demo"
  ),
  nav("NYC Flights", flights_ui),
  nav_spacer(),
  nav_item(
    tags$a(
      tags$span(
        bsicons::bs_icon("code-slash"), "Source code"
      ),
      href = "https://github.com/rstudio/bslib/tree/main/inst/examples/demo",
      target = "_blank"
    )
  )
)

server <- function(input, output, session) {
  # ---------------------------------------------------------
  # Flights tab logic
  #
  # WARNING: this server-side filtering logic is VERY experimental
  # at this point and won't be easily adapt to different use cases.
  # If you feel tempted to use it, use with caution.
  # ---------------------------------------------------------

  # Mapping from input id name to updating input function
  input_discrete_vars <- list(
    origin = function(...) updateCheckboxGroupInput(..., inline = TRUE),
    dest_name = updateSelectInput,
    carrier_name = updateSelectInput
  )
  input_numeric_vars <- list(
    sched_dep_time = update_histoslider,
    sched_arr_time = update_histoslider,
    date = update_histoslider
  )
  input_vars <- c(
    input_discrete_vars,
    input_numeric_vars
  )

  filter_index <- function(d) {
    idx <- rep(TRUE, nrow(d))
    for (var in names(d)) {
      idx <- idx & filter_col(d, var)
    }
    idx & !is.na(idx)
  }

  filter_col <- function(d, var) {
    vals <- d[[var]]
    input_val <- input[[var]]
    if (is.null(input_val)) {
      return(TRUE)
    }

    if (is.character(vals) || is.factor(vals) || is.logical(vals)) {
      return(d[[var]] %in% input_val)
    }

    # N.B. between() will remove NAs, which we probably don't
    # want to remove until the slider is considered 'active'
    rng <- range(vals, na.rm = TRUE)
    active <- isTRUE(rng[1] <= input_val[1] || input_val[2] <= rng[2])

    if (!active) {
      return(TRUE)
    }

    dplyr::between(vals, input_val[1], input_val[2])
  }

  # When a particular input filter changes, we need to update every other filter
  # with data
  lapply(names(input_vars), function(var) {

    index <- reactive({
      filter_index(flights[, setdiff(names(input_vars), var)])
    })

    observeEvent(index(), ignoreInit = TRUE, ignoreNULL = FALSE, {

      d <- flights[index(), ]
      if (nrow(d) == 0) return()
      input_val <- input[[var]]
      update_input_func <- input_vars[[var]]

      if (var %in% names(input_discrete_vars)) {
        choices <- sort(unique(d[[var]]))
        update_input_func(
          inputId = var, choices = choices, selected = input_val %||% character(0)
        )
      } else {
        update_input_func(
          id = var,
          values = d[[var]],
          start = input_val[1],
          end = input_val[2]
        )
      }

    })
  })

  output$origin_reset <- renderUI({
    actionLink(
      "origin_reset", "Reset",
      style = htmltools::css(
        text_decoration = "none",
        font_weight = 700,
        font_size = ".875rem",
        float = "right",
        visibility = if (length(input$origin) > 0) "visible" else "hidden",
        margin_top = "-7px"
      )
    )
  })

  observeEvent(input$origin_reset, {
    updateCheckboxGroupInput(
      inputId = "origin",
      choices = sort(unique(flights$origin)),
      selected = character(0)
    )
  })

  # Flights with all filters applied (i.e., data used for value boxes/plots)
  flight_dat <- reactive({
    flights[filter_index(flights), ]
  })

  output$value_boxes <- renderUI({
    d <- flight_dat()
    n_flights <- value_box(
      "A TOTAL OF",
      paste(nrow(d), "flights"),
      paste(
        "Across", length(unique(d$dest_name)),
        "destinations"
      ),
      tags$p(paste(
        "On", length(unique(d$carrier_name)), "different carriers"
      )),
      showcase = bsicons::bs_icon("airplane")
    )

    delay_dep <- value_box(
      "AVERAGE DEPARTURE",
      paste(
        round(mean(d$dep_delay, na.rm = T), 0),
        "mins late"
      ),
      paste0(
        round(100 * sum(d$dep_delay > 0, na.rm = T) / nrow(d), 1),
        "% of flights depart late"
      ),
      showcase = bsicons::bs_icon("hourglass-split")
    )

    delay_arr <- value_box(
      "AVERAGE ARRIVAL",
      paste(
        round(mean(d$arr_delay, na.rm = T), 0),
        "mins late"
      ),
      paste0(
        round(100 * sum(d$arr_delay > 0, na.rm = TRUE) / nrow(d), 1),
        "% of flights arrive late"
      ),
      showcase = bsicons::bs_icon("hourglass-bottom")
    )

    layout_column_wrap(width = 1/3, n_flights, delay_dep, delay_arr)
  })

  output$flight_paths <- renderPlotly({
    flight_dat() %>%
      group_by(start_lon, start_lat, end_lon, end_lat, origin, dest) %>%
      summarise(mean_delay = mean(arr_delay, na.rm = TRUE)) %>%
      plot_geo(color = I("#0D6EFD"), showlegend = FALSE) %>%
      add_segments(
        x = ~start_lon, xend = ~end_lon,
        y = ~start_lat, yend = ~end_lat,
        alpha = 0.5, size = I(1), hoverinfo = "none"
      ) %>%
      add_markers(
        x = ~end_lon, y = ~end_lat, size = ~mean_delay,
        hoverinfo = "text", alpha = 0.1,
        text = ~paste0(
          origin, " -> ", dest, "<br>",
          "Average delay: ", round(mean_delay, 1)
        )
      ) %>%
      config(displayModeBar = FALSE) %>%
      layout(
        geo = list(
          projection = list(
            type = 'orthographic',
            rotation = list(lon = -100, lat = 40, roll = 0)
          ),
          showland = TRUE,
          landcolor = toRGB("gray95"),
          countrycolor = toRGB("gray80")
        )
      )
  })

  output$scatter_delay <- renderPlotly({
    d <- flight_dat()
    req(nrow(d) > 0)

    if (isTRUE(input$scatter_summarize)) {
      x <- d$dep_delay
      y <- d$arr_delay
      p <- plot_ly() %>%
        add_histogram2dcontour(
          x = x, y = y, hovertemplate = "Number of flights: %{z}<extra></extra>"
        ) %>%
        layout(
          xaxis = list(
            title = "Departure delay",
            range = c(-30, 100)
          ),
          yaxis = list(
            title = "Arrival delay",
            range = c(-50, 100)
          )
        ) %>%
        colorbar(title = "Number of flights", y = 0.5, yanchor = "middle")

      return(p)
    }

    m <- loess(arr_delay~dep_delay, data = d)
    rng <- range(d$dep_delay, na.rm = TRUE)
    grid <- data.frame(
      dep_delay = seq(rng[1], rng[2], length = 100)
    )
    grid <- modelr::add_predictions(grid, m)

    plot_ly() %>%
      add_markers(
        data = d,
        x = ~dep_delay,
        y = ~arr_delay,
        stroke = I(PRIMARY),
        color = I("transparent"),
        span = I(1),
        text = ~paste0(
          origin, " -> ",
          substr(dest_name, nchar(dest_name) - 3, nchar(dest_name) - 1), "\n",
          carrier_name, "\n",
          "Arrival: ", arr_delay, "\n",
          "Departure: ", dep_delay, "\n"
        ),
        hoverinfo = "text",
        name = "Flights"
      ) %>%
      add_lines(
        data = grid,
        x = ~dep_delay,
        y = ~pred,
        text = ~paste0("Given a departure delay of ", round(dep_delay), "\n expect an arrival delay of ", round(pred)),
        hoverinfo = "text",
        name = "Predicted"
      ) %>%
      layout(
        legend = list(
          orientation = "h",
          x = 0.1, xanchor = "left",
          y = 0.95, yanchor = "top",
          bgcolor = "transparent"
        ),
        xaxis = list(title = "Departure delay"),
        yaxis = list(title = "Arrival delay")
      ) %>%
      toWebGL()
  })


  output$arr_delay <- renderPlotly({
    x <- flight_dat()$arr_delay
    req(length(x) > 0)

    x_mean <- mean(x, na.rm = TRUE)
    end <- quantile(x, probs = 0.99, na.rm = TRUE)
    plot_ly(x = x, hovertemplate = "%{y} flights were %{x} min late <extra></extra>", color = I(PRIMARY)) %>%
      config(displayModeBar = FALSE) %>%
      rangeslider(start = min(x, na.rm = TRUE), end = as.numeric(end)) %>%
      # TODO: add annotations for each line?
      layout(
        shapes = list(
          type = "line",
          x0 = x_mean, x1 = x_mean,
          y0 = 0, y1 = 1,
          yref = "paper",
          line = list(color = "orange", dash = "solid")
        )
      )
  })

  output$arr_delay_series <- renderPlotly({
    d <- flight_dat()
    req(nrow(d) > 0)

    d %>%
      group_by(date) %>%
      summarise(arr_delay_mean = mean(arr_delay, na.rm = TRUE)) %>%
      plot_ly(
        x = ~date, y = ~arr_delay_mean,
        hovertemplate = "%{y:.1f}<extra></extra>",
        color = I(PRIMARY)
      ) %>%
      add_lines() %>%
      layout(
        hovermode = "x",
        xaxis = list(title = "", tickformat = "%b %e"),
        yaxis = list(title = "Average delay")
      )
  })

}

shinyApp(ui, server)
