moai-adk 0.34.0__py3-none-any.whl → 1.1.0__py3-none-any.whl

moai_adk/templates/.claude/skills/moai-lang-r/modules/advanced-patterns.md

@@ -0,0 +1,489 @@
+# 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)
+  }
+}
+```