# R Advanced Patterns

## Advanced Shiny Patterns

Async Processing:
```r
library(shiny)
library(promises)
library(future)
plan(multisession)

server <- function(input, output, session) {
  output$result <- renderText({
    future({
      # Long-running computation
      Sys.sleep(5)
      expensive_calculation()
    }) %...>%
      as.character()
  })
}
```

Caching with memoise:
```r
library(memoise)

# Cache expensive calculations
expensive_function <- memoise(function(data) {
  # Complex computation
  result <- heavy_processing(data)
  result
})

# In Shiny
server <- function(input, output, session) {
  cached_data <- reactive({
    expensive_function(input$data_source)
  }) |> bindCache(input$data_source)
}
```

Shiny Modules Advanced:
```r
# Advanced module with return values
filterModuleUI <- function(id) {
  ns <- NS(id)
  tagList(
    selectInput(ns("category"), "Category:", choices = NULL),
    sliderInput(ns("range"), "Range:", min = 0, max = 100, value = c(0, 100)),
    actionButton(ns("apply"), "Apply Filter")
  )
}

filterModuleServer <- function(id, data, default_category = NULL) {
  moduleServer(id, function(input, output, session) {
    # Update choices based on data
    observe({
      categories <- unique(data()$category)
      selected <- if (!is.null(default_category) && default_category %in% categories) {
        default_category
      } else {
        categories[1]
      }
      updateSelectInput(session, "category", choices = categories, selected = selected)
    })

    # Return reactive values
    filtered_data <- eventReactive(input$apply, {
      req(input$category)
      data() |>
        filter(
          category == input$category,
          value >= input$range[1],
          value <= input$range[2]
        )
    }, ignoreNULL = FALSE)

    # Return both data and metadata
    list(
      data = filtered_data,
      selected_category = reactive(input$category),
      range = reactive(input$range)
    )
  })
}
```

## Complex ggplot2 Extensions

Custom Theme:
```r
library(ggplot2)

theme_custom <- function(base_size = 12, base_family = "") {
  theme_minimal(base_size = base_size, base_family = base_family) %+replace%
    theme(
      # Plot elements
      plot.title = element_text(face = "bold", size = rel(1.2), hjust = 0),
      plot.subtitle = element_text(color = "grey40", hjust = 0),
      plot.caption = element_text(color = "grey60", hjust = 1),
      plot.margin = margin(10, 10, 10, 10),

      # Panel elements
      panel.grid.major = element_line(color = "grey90"),
      panel.grid.minor = element_blank(),
      panel.background = element_rect(fill = "white", color = NA),

      # Axis elements
      axis.title = element_text(face = "bold", size = rel(0.9)),
      axis.text = element_text(color = "grey30"),
      axis.ticks = element_line(color = "grey30"),

      # Legend elements
      legend.position = "bottom",
      legend.background = element_rect(fill = "transparent"),
      legend.key = element_rect(fill = "transparent"),
      legend.title = element_text(face = "bold"),

      # Strip elements (facets)
      strip.background = element_rect(fill = "grey95", color = NA),
      strip.text = element_text(face = "bold", size = rel(0.9))
    )
}

# Usage
ggplot(data, aes(x, y)) +
  geom_point() +
  theme_custom()
```

Custom Geom:
```r
library(ggplot2)
library(grid)

GeomTimeline <- ggproto("GeomTimeline", GeomPoint,
  required_aes = c("x", "y"),
  default_aes = aes(
    shape = 19, colour = "black", size = 3,
    fill = NA, alpha = 0.7, stroke = 0.5
  ),

  draw_panel = function(data, panel_params, coord) {
    coords <- coord$transform(data, panel_params)

    # Draw connecting lines
    line_grob <- segmentsGrob(
      x0 = min(coords$x), y0 = coords$y,
      x1 = max(coords$x), y1 = coords$y,
      gp = gpar(col = "grey70", lwd = 1)
    )

    # Draw points
    point_grob <- pointsGrob(
      coords$x, coords$y,
      pch = coords$shape,
      gp = gpar(
        col = alpha(coords$colour, coords$alpha),
        fill = alpha(coords$fill, coords$alpha),
        fontsize = coords$size * .pt + coords$stroke * .stroke / 2
      )
    )

    grobTree(line_grob, point_grob)
  }
)

geom_timeline <- function(mapping = NULL, data = NULL, stat = "identity",
                          position = "identity", ..., na.rm = FALSE,
                          show.legend = NA, inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomTimeline,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}
```

## Database Integration

dbplyr with pool:
```r
library(DBI)
library(pool)
library(dbplyr)

# Create connection pool
pool <- dbPool(
  drv = RPostgres::Postgres(),
  dbname = "mydb",
  host = "localhost",
  user = Sys.getenv("DB_USER"),
  password = Sys.getenv("DB_PASSWORD"),
  minSize = 1,
  maxSize = 5
)

# Use with dbplyr
users_db <- tbl(pool, "users")

# Query with dbplyr
result <- users_db |>
  filter(active == TRUE) |>
  group_by(department) |>
  summarise(
    count = n(),
    avg_salary = mean(salary, na.rm = TRUE)
  ) |>
  arrange(desc(count)) |>
  collect()

# Close pool on exit
onStop(function() {
  poolClose(pool)
})
```

Transaction Handling:
```r
with_transaction <- function(pool, expr) {
  conn <- poolCheckout(pool)
  on.exit(poolReturn(conn))

  dbBegin(conn)

  tryCatch({
    result <- expr
    dbCommit(conn)
    result
  }, error = function(e) {
    dbRollback(conn)
    stop(e)
  })
}

# Usage
with_transaction(pool, {
  dbExecute(conn, "UPDATE accounts SET balance = balance - 100 WHERE id = 1")
  dbExecute(conn, "UPDATE accounts SET balance = balance + 100 WHERE id = 2")
})
```

## R Package Development

Package Structure:
```r
# DESCRIPTION file
Package: mypackage
Title: What the Package Does
Version: 0.1.0
Authors@R:
    person("First", "Last", email = "first.last@example.com", role = c("aut", "cre"))
Description: A longer description of what the package does.
License: MIT + file LICENSE
Encoding: UTF-8
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.2.3
Imports:
    dplyr (>= 1.0.0),
    ggplot2
Suggests:
    testthat (>= 3.0.0),
    knitr,
    rmarkdown
Config/testthat/edition: 3
```

Roxygen Documentation:
```r
#' Calculate Growth Rate
#'
#' Calculates the period-over-period growth rate for a numeric vector.
#'
#' @param x A numeric vector of values.
#' @param periods Number of periods for growth calculation. Default is 1.
#' @param na.rm Logical. Should NA values be removed? Default is TRUE.
#'
#' @return A numeric vector of growth rates.
#'
#' @examples
#' calculate_growth(c(100, 110, 121))
#' calculate_growth(c(100, 110, 121), periods = 2)
#'
#' @export
calculate_growth <- function(x, periods = 1, na.rm = TRUE) {
  if (!is.numeric(x)) {
    stop("x must be numeric")
  }

  growth <- (x - dplyr::lag(x, n = periods)) / dplyr::lag(x, n = periods)

  if (na.rm) {
    growth[is.na(growth)] <- NA_real_
  }

  growth
}
```

## Performance Optimization

data.table for Large Data:
```r
library(data.table)

# Convert and process
dt <- as.data.table(large_df)

# Fast grouping
result <- dt[, .(
  count = .N,
  mean_value = mean(value, na.rm = TRUE),
  max_value = max(value, na.rm = TRUE)
), by = .(category, year)]

# In-place updates
dt[, new_col := value * 2]

# Efficient joins
dt1[dt2, on = .(key_col)]

# Rolling operations
dt[, rolling_mean := frollmean(value, n = 7), by = category]
```

Parallel Processing:
```r
library(future)
library(furrr)

# Set up parallel backend
plan(multisession, workers = 4)

# Parallel map
results <- future_map(file_list, \(f) {
  read_csv(f) |>
    process_data()
}, .progress = TRUE)

# Parallel with error handling
safe_process <- possibly(process_data, otherwise = NULL)
results <- future_map(data_list, safe_process)

# Clean up
plan(sequential)
```

## Production Deployment

Docker for R:
```dockerfile
FROM rocker/shiny:4.4.0

RUN apt-get update && apt-get install -y \
    libcurl4-gnutls-dev \
    libssl-dev \
    libpq-dev \
    && rm -rf /var/lib/apt/lists/*

COPY renv.lock renv.lock
RUN R -e "install.packages('renv'); renv::restore()"

COPY . /srv/shiny-server/
RUN chown -R shiny:shiny /srv/shiny-server

EXPOSE 3838

CMD ["/usr/bin/shiny-server"]
```

Posit Connect Deployment:
```r
# rsconnect for deployment
library(rsconnect)

# Set up account
rsconnect::setAccountInfo(
  name = "your-account",
  token = Sys.getenv("CONNECT_TOKEN"),
  secret = Sys.getenv("CONNECT_SECRET")
)

# Deploy app
rsconnect::deployApp(
  appDir = ".",
  appName = "my-shiny-app",
  appTitle = "My Shiny Application",
  forceUpdate = TRUE
)
```

## testthat Advanced Patterns

Test Fixtures:
```r
# tests/testthat/helper.R
setup_test_db <- function() {
  conn <- DBI::dbConnect(RSQLite::SQLite(), ":memory:")
  DBI::dbExecute(conn, "CREATE TABLE users (id INTEGER, name TEXT)")
  conn
}

teardown_test_db <- function(conn) {
  DBI::dbDisconnect(conn)
}

# tests/testthat/test-db.R
test_that("database operations work correctly", {
  conn <- setup_test_db()
  on.exit(teardown_test_db(conn))

  DBI::dbExecute(conn, "INSERT INTO users VALUES (1, 'Test')")
  result <- DBI::dbGetQuery(conn, "SELECT * FROM users")

  expect_equal(nrow(result), 1)
  expect_equal(result$name, "Test")
})
```

Property-Based Testing:
```r
library(hedgehog)

test_that("reverse is involutory", {
  forall(gen.c(gen.element(letters), from = 1, to = 100), function(x) {
    expect_equal(rev(rev(x)), x)
  })
})

test_that("sort is idempotent", {
  forall(gen.c(gen.int(100), from = 1, to = 50), function(x) {
    expect_equal(sort(sort(x)), sort(x))
  })
})
```

## Error Handling

Condition System:
```r
# Define custom conditions
validation_error <- function(message, field = NULL) {
  rlang::abort(
    message,
    class = "validation_error",
    field = field
  )
}

# Handle conditions
process_input <- function(data) {
  tryCatch(
    {
      validate_data(data)
      transform_data(data)
    },
    validation_error = function(e) {
      cli::cli_alert_danger("Validation failed: {e$message}")
      cli::cli_alert_info("Field: {e$field}")
      NULL
    },
    error = function(e) {
      cli::cli_alert_danger("Unexpected error: {e$message}")
      rlang::abort("Processing failed", parent = e)
    }
  )
}

# Retry logic
retry <- function(expr, n = 3, delay = 1) {
  for (i in seq_len(n)) {
    result <- tryCatch(
      expr,
      error = function(e) {
        if (i == n) stop(e)
        Sys.sleep(delay)
        NULL
      }
    )
    if (!is.null(result)) return(result)
  }
}
```
