R Interview Questions with Answers

# Hello World in R
print("Hello, World!")

# Variables in R
x <- 10          # Integer
y <- 3.14        # Float
name <- "R"      # String
is_active <- TRUE # Boolean

print(x)
print(y)
print(name)
print(is_active)

# Data Types in R
# Integer types
a <- 10L         # Integer
b <- 127L        # Integer

# Numeric (double)
d <- 3.14        # Numeric
e <- 2.5         # Numeric

# Character (string)
f <- "Hello R"

# Logical (boolean)
g <- TRUE
h <- FALSE

# Complex
i <- 1 + 2i

# Vector
j <- c(1, "hello", 3.14)

# Numeric vector
k <- c(1, 2, 3, 4, 5)

# List
l <- list(name = "R", version = 4.3)

# Data frame
df <- data.frame(
  Name = c("Alice", "Bob"),
  Age = c(25, 30)
)

# NULL
m <- NULL

print(class(a))
print(class(d))

# Functions in R
# Function declaration
add <- function(a, b) {
    return(a + b)
}

# Function with default parameters
greet <- function(name = "Guest") {
    return(paste("Hello,", name, "!"))
}

# One-line function
subtract <- function(a, b) a - b

# Anonymous function
square <- function(x) x^2

# Function with variable arguments
sum_all <- function(...) {
    return(sum(...))
}

# Function with named arguments
create_person <- function(name, age = 0, city = "Unknown") {
    return(list(name = name, age = age, city = city))
}

# Using functions
print(add(5, 3))
print(greet("Alice"))
print(square(4))
print(sum_all(1, 2, 3, 4, 5))
print(create_person("Alice", age = 25, city = "NYC"))

# Vectors in R
arr <- c(1, 2, 3, 4, 5)

# Map - transform each element
doubled <- sapply(arr, function(x) x * 2)
print(doubled)

# Filter - select elements
evens <- arr[arr %% 2 == 0]
print(evens)

# Reduce - aggregate
sum_value <- sum(arr)
print(sum_value)

# Vectorized operations
squares <- (1:10)^2
print(squares)

# Push and pop
arr <- c(arr, 6)
print(arr)
arr <- arr[-length(arr)]
print(arr)

# Vector operations
a <- c(1, 2, 3)
b <- c(4, 5, 6)
c <- a + b  # Element-wise addition
print(c)

# Lists (Dictionaries) in R
# Create list
person <- list(
    name = "Alice",
    age = 25,
    city = "NYC"
)

# Access values
print(person$name)
print(person[["age"]])
print(person["city"])

# Add/update values
person$country <- "USA"
person$age <- 26

# Get with default
city <- person$city %||% "Unknown"

# Names
print(names(person))

# Iterate over list
for (key in names(person)) {
    print(paste(key, ":", person[[key]]))
}

# Delete element
person$country <- NULL

# Check if key exists
print("name" %in% names(person))

# List comprehension using lapply
squares <- lapply(1:5, function(x) x^2)
print(squares)

# Vectors as Tuples in R
# Create tuple-like vector
t <- c(1, "hello", 3.14, TRUE)

# Access elements
print(t[1])
print(t[2])

# Named vector (like named tuple)
person <- c(name = "Alice", age = "25", city = "NYC")
print(person["name"])
print(person["age"])

# Function returning multiple values
divide <- function(a, b) {
    return(c(quotient = a %/% b, remainder = a %% b))
}
result <- divide(10, 3)
print(result["quotient"])
print(result["remainder"])

# List concatenation
t1 <- list(1, 2, 3)
t2 <- list(4, 5, 6)
t3 <- c(t1, t2)
print(t3)

# Control Flow in R
# If-else statement
age <- 25
if (age < 18) {
    print("Minor")
} else if (age < 65) {
    print("Adult")
} else {
    print("Senior")
}

# Ternary-like (using ifelse)
status <- ifelse(age >= 18, "Adult", "Minor")
print(status)

# For loop
for (i in 1:5) {
    print(i)
}

# For loop with vector
fruits <- c("apple", "banana", "orange")
for (fruit in fruits) {
    print(fruit)
}

# While loop
i <- 1
while (i <= 5) {
    print(i)
    i <- i + 1
}

# Break and continue
for (i in 1:10) {
    if (i == 6) {
        break
    }
    if (i %% 2 == 0) {
        next
    }
    print(i)
}

# Vector Generation in R
# Using sequence
squares <- (1:10)^2
print(squares)

# Filter with which
evens <- (1:20)[(1:20) %% 2 == 0]
print(evens)

# Nested loops using expand.grid
matrix_data <- expand.grid(i = 1:3, j = 1:3)
print(matrix_data)

# List comprehension using lapply
square_dict <- setNames(lapply(1:5, function(x) x^2), 1:5)
print(square_dict)

# Conditional vector
results <- ifelse(1:10 %% 2 == 0, "even", "odd")
print(results)

# Using replicate
random_numbers <- replicate(10, runif(1))
print(random_numbers)

# Strings in R
# String creation
str1 <- "Hello"
str2 <- 'World'
str3 <- "Multi-line\nstring"

# String concatenation
greeting <- paste(str1, str2)
print(greeting)

# String interpolation (using glue)
# install.packages("glue")
# library(glue)
# name <- "R"
# version <- 4.3
# print(glue("Welcome to {name} version {version}"))

# String functions
text <- "Hello, World!"
print(nchar(text))
print(toupper(text))
print(tolower(text))
print(gsub("World", "R", text))

# Substring
print(substr(text, 1, 5))

# Split and join
words <- strsplit("Hello World R", " ")[[1]]
print(words)
joined <- paste(words, collapse = "-")
print(joined)

# String comparison
print("hello" == "hello")
print("hello" < "world")

# String formatting
print(sprintf("Value: %.2f", 3.14159))

# Packages and Modules in R
# Installing packages
# install.packages("dplyr")
# install.packages("ggplot2")

# Loading packages
library(dplyr)
library(ggplot2)

# Creating a package
# Use devtools to create package structure
# devtools::create("mypackage")

# Package functions
# In R package, functions are defined in R/ directory

# Sourcing files
source("my_functions.R")

# Using a package without loading
# dplyr::filter(data, condition)

# Checking installed packages
# installed.packages()

# Package namespace
# importFrom(dplyr, filter)

# Creating a simple package structure
# mypackage/
#   DESCRIPTION
#   NAMESPACE
#   R/
#     myfunctions.R

# Example package function
# my_add <- function(a, b) {
#   return(a + b)
# }

# Exporting functions (in NAMESPACE)
# export(my_add)

# Using roxygen2 for documentation
# #' Add two numbers
# #' @param a First number
# #' @param b Second number
# #' @return Sum of a and b
# #' @export
# my_add <- function(a, b) {
#   return(a + b)
# }

# Classes and Types in R
# S3 Class
# Define class
person <- function(name, age, city = "Unknown") {
    obj <- list(name = name, age = age, city = city)
    class(obj) <- "Person"
    return(obj)
}

# Method for S3 class
print.Person <- function(x) {
    cat("Name:", x$name, "\n")
    cat("Age:", x$age, "\n")
    cat("City:", x$city, "\n")
}

# S4 Class
# setClass("Animal",
#     slots = list(
#         name = "character",
#         age = "numeric"
#     )
# )
# setMethod("show", "Animal", function(object) {
#     cat("Animal:", object@name, "\n")
# })

# Reference Class (R5)
# Animal <- setRefClass("Animal",
#     fields = list(
#         name = "character",
#         age = "numeric"
#     ),
#     methods = list(
#         initialize = function(name, age) {
#             .self$name <- name
#             .self$age <- age
#         },
#         make_sound = function() {
#             return("Some sound")
#         }
#     )
# )
# dog <- Animal$new("Rex", 3)

# Usage
alice <- person("Alice", 25, "NYC")
print(alice)

# Type System in R
# Type checking
is_integer <- function(x) {
    return(is.integer(x))
}

is_numeric <- function(x) {
    return(is.numeric(x))
}

is_character <- function(x) {
    return(is.character(x))
}

is_logical <- function(x) {
    return(is.logical(x))
}

is_list <- function(x) {
    return(is.list(x))
}

# Type conversion
as_integer <- function(x) {
    return(as.integer(x))
}

as_numeric <- function(x) {
    return(as.numeric(x))
}

as_character <- function(x) {
    return(as.character(x))
}

as_logical <- function(x) {
    return(as.logical(x))
}

# Type checking examples
x <- 42
print(is.numeric(x))
print(is.integer(x))

y <- 42L
print(is.integer(y))

z <- "Hello"
print(is.character(z))

# Class checking
print(class(x))
print(class(y))
print(class(z))

# Type coercion
num <- as.numeric("42")
char <- as.character(42)
print(num)
print(char)

# Mode and storage mode
print(mode(x))
print(storage.mode(x))

# Using typeof
print(typeof(x))
print(typeof(y))

# Exception Handling in R
# Try-catch block
tryCatch({
    # Code that might error
    result <- 10 / 0
    print(result)
}, error = function(e) {
    print(paste("Error caught:", e$message))
})

# Specific error handling
tryCatch({
    arr <- c(1, 2, 3)
    print(arr[10])
}, error = function(e) {
    if (grepl("subscript out of bounds", e$message)) {
        print("Index out of bounds!")
    } else {
        print(paste("Other error:", e$message))
    }
})

# Finally block
tryCatch({
    file <- file("data.txt", "r")
    print("File opened successfully")
    close(file)
}, error = function(e) {
    print(paste("Error opening file:", e$message))
}, finally = {
    print("Cleanup performed")
})

# Throwing errors
divide <- function(a, b) {
    if (b == 0) {
        stop("Cannot divide by zero")
    }
    return(a / b)
}

# Using error
tryCatch({
    print(divide(10, 0))
}, error = function(e) {
    print(paste("Error:", e$message))
})

# Custom error classes
my_error <- function(message) {
    condition(message, class = "MyError")
}

tryCatch({
    stop(my_error("Custom error message"))
}, MyError = function(e) {
    print(paste("MyError caught:", e$message))
})

# File I/O in R
# Reading files
tryCatch({
    content <- readLines("example.txt")
    print(content)
}, error = function(e) {
    print("File not found")
})

# Reading line by line
tryCatch({
    con <- file("data.txt", "r")
    while (length(line <- readLines(con, n = 1)) > 0) {
        print(line)
    }
    close(con)
}, error = function(e) {
    print("Error reading file")
})

# Writing files
writeLines("Hello, World!\nThis is line 2", "output.txt")

# Appending to files
write("Appended line", "output.txt", append = TRUE)

# Reading CSV
data <- read.csv("data.csv")
print(data)

# Writing CSV
data <- data.frame(
    Name = c("Alice", "Bob"),
    Age = c(25, 30),
    City = c("NYC", "LA")
)
write.csv(data, "output.csv", row.names = FALSE)

# File operations
files <- list.files(pattern = "\.txt$")
for (file in files) {
    print(file)
    print(file.info(file)$size)
}

# Using read.table
data <- read.table("data.txt", header = TRUE, sep = ",")

# Writing with write.table
write.table(data, "output.txt", sep = "	", row.names = FALSE)

# Packages in R
# Installing packages
# install.packages("tidyverse")
# install.packages("data.table")
# install.packages("shiny")

# Loading packages
library(tidyverse)
library(data.table)
library(shiny)

# Using package functions
# dplyr functions
# filter(), select(), mutate(), summarise()

# data.table
# DT <- data.table(x = 1:10, y = 11:20)

# shiny
# Run a shiny app
# shinyApp(ui, server)

# Package management
# installed.packages()
# update.packages()

# Package dependencies
# install.packages("devtools")
# devtools::install_github("user/repo")

# Package documentation
# help(package = "dplyr")
# vignette("dplyr")

# Creating a package
# devtools::create("mypackage")
# devtools::document()
# devtools::install()

# Package structure
# mypackage/
#   DESCRIPTION
#   NAMESPACE
#   R/
#   man/
#   tests/
#   vignettes/

# Using renv for project isolation
# install.packages("renv")
# renv::init()
# renv::snapshot()
# renv::restore()

# Plotting in R
# Using base R graphics
x <- 1:10
y <- x^2
plot(x, y, type = "l", main = "Square Function", xlab = "x", ylab = "y")

# Multiple series
y2 <- 2*x + 1
plot(x, y, type = "l", col = "red")
lines(x, y2, col = "blue")
legend("topleft", legend = c("x²", "2x+1"), col = c("red", "blue"), lty = 1)

# Scatter plot
plot(x, y, pch = 19, main = "Scatter Plot")

# Histogram
data <- rnorm(1000)
hist(data, breaks = 30, main = "Histogram")

# Using ggplot2
library(ggplot2)
df <- data.frame(x = x, y = y)
ggplot(df, aes(x, y)) +
    geom_line() +
    ggtitle("Square Function") +
    xlab("x") +
    ylab("y")

# 3D plot (using rgl)
# library(rgl)
# z <- outer(1:10, 1:10, function(x, y) x^2 + y^2)
# persp3d(z)

# Using plotly
# library(plotly)
# plot_ly(x = ~x, y = ~y, type = "scatter", mode = "lines")

# Saving plots
png("plot.png")
plot(x, y)
dev.off()

# Using lattice
# library(lattice)
# xyplot(y ~ x, data = df)

# Data Structures in R
# Vector (basic)
vec <- c(1, 2, 3, 4, 5)

# List
lst <- list(a = 1, b = "hello", c = TRUE)

# Matrix
mat <- matrix(1:9, nrow = 3, ncol = 3)

# Data frame
df <- data.frame(
    id = 1:3,
    name = c("Alice", "Bob", "Charlie"),
    age = c(25, 30, 35)
)

# Array
arr <- array(1:24, dim = c(2, 3, 4))

# Factor
fac <- factor(c("low", "medium", "high", "low", "medium"))

# Data table (from data.table package)
# library(data.table)
# dt <- data.table(id = 1:3, name = c("Alice", "Bob", "Charlie"))

# Tibble (from tibble package)
# library(tibble)
# tb <- tibble(id = 1:3, name = c("Alice", "Bob", "Charlie"))

# Environment
env <- new.env()
env$x <- 10
env$y <- 20

# Function closure
counter <- function() {
    count <- 0
    function() {
        count <<- count + 1
        return(count)
    }
}
cnt <- counter()
print(cnt())
print(cnt())
print(cnt())

# Statistics in R
# Basic statistics
data <- 1:10
print(mean(data))
print(median(data))
print(sd(data))
print(var(data))

# Random data
set.seed(123)
random_data <- rnorm(1000)
print(mean(random_data))
print(sd(random_data))

# Correlation
x <- 1:100
y <- 2*x + rnorm(100)
print(cor(x, y))

# Quantiles
print(quantile(data, probs = c(0.25, 0.5, 0.75)))

# Summary statistics
print(summary(data))

# Statistical tests
# t.test(data, mu = 5.5)
# wilcox.test(data, mu = 5.5)

# ANOVA
# group <- factor(rep(1:3, each = 10))
# values <- c(rnorm(10, mean = 0), rnorm(10, mean = 1), rnorm(10, mean = 2))
# anova_result <- aov(values ~ group)
# summary(anova_result)

# Linear regression
x <- 1:100
y <- 2*x + rnorm(100)
model <- lm(y ~ x)
summary(model)

# Confidence intervals
print(confint(model))

# Hypothesis testing
# t.test(x, y)
# prop.test(c(10, 20), c(100, 100))

# Linear Algebra in R
# Matrix operations
A <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 10), nrow = 3, ncol = 3)
b <- c(1, 2, 3)

# Matrix multiplication
print(A %*% b)

# Transpose
print(t(A))

# Solving linear systems
x <- solve(A, b)
print(x)

# Matrix decomposition
print(chol(A))  # Cholesky
print(qr(A))    # QR
print(svd(A))   # SVD

# Eigenvalues
eigenvalues <- eigen(A)$values
print(eigenvalues)

# Determinant
print(det(A))

# Inverse
print(solve(A))

# Identity matrix
I <- diag(3)
print(I)

# Special matrices
zeros_matrix <- matrix(0, 3, 3)
ones_matrix <- matrix(1, 3, 3)
print(zeros_matrix)
print(ones_matrix)

# Cross product
print(crossprod(A))

# Diagonal
print(diag(A))

# Trace
trace <- sum(diag(A))
print(trace)

# Norm
library(Matrix)
print(norm(A, type = "F"))

# Outer product
print(outer(1:3, 1:3))

# Dates and Time in R
# Current date and time
now <- Sys.time()
print(now)

# Date creation
date1 <- as.Date("2024-01-01")
date2 <- as.POSIXct("2024-01-01 12:00:00")
print(date1)
print(date2)

# Date arithmetic
print(date1 + 10)
print(date1 + months(2))
print(date2 + hours(3))

# Date difference
diff <- difftime(now, date2, units = "days")
print(diff)

# Formatting dates
print(format(date1, "%Y-%m-%d"))
print(format(date2, "%Y-%m-%d %H:%M:%S"))

# Date functions
print(format(now, "%Y"))
print(format(now, "%m"))
print(format(now, "%d"))
print(format(now, "%A"))

# Date range
dates <- seq(as.Date("2024-01-01"), as.Date("2024-01-10"), by = "day")
for (d in dates) {
    print(d)
}

# Timezone handling
Sys.setenv(TZ = "America/New_York")
print(Sys.time())

# Lubridate package
# library(lubridate)
# now <- now()
# year(now)
# month(now)
# day(now)
# wday(now, label = TRUE)

# Parsing dates
# ymd("2024-01-01")
# mdy("01/01/2024")
# dmy("01/01/2024")

# Date arithmetic with lubridate
# now + days(10)
# now + months(2)
# now + hours(3)

# Regular Expressions in R
# Match
text <- "hello world"
result <- regexpr("hello", text)
print(result)

# Find all
text2 <- "hello world hello again"
matches <- gregexpr("hello", text2)
regmatches(text2, matches)

# Regex with capture groups
text3 <- "Date: 2024-01-01"
pattern <- "(\d{4})-(\d{2})-(\d{2})"
matches <- regexec(pattern, text3)
result <- regmatches(text3, matches)
print(result[[1]][2])  # year
print(result[[1]][3])  # month
print(result[[1]][4])  # day

# Replace with regex
replaced <- gsub("\d+", "NUM", "Hello 123 World")
print(replaced)

# Case insensitive
result <- grepl("hello", "HELLO world", ignore.case = TRUE)
print(result)

# String split with regex
parts <- strsplit("Hello World R", "[, ]+")[[1]]
print(parts)

# grep - find indices
indices <- grep("\d+", c("abc", "123", "def", "456"))
print(indices)

# grepl - logical vector
matches <- grepl("\d+", c("abc", "123", "def", "456"))
print(matches)

# sub - replace first match
result <- sub("\d+", "NUM", "Hello 123 World 456")
print(result)

# gsub - replace all matches
result <- gsub("\d+", "NUM", "Hello 123 World 456")
print(result)

# regexec - detailed match info
result <- regexec("(\d+)-(\d+)", "123-456")
print(regmatches("123-456", result))

# Parallel Computing in R
# Using parallel package
library(parallel)

# Detect cores
num_cores <- detectCores()
print(num_cores)

# Parallel lapply
result <- mclapply(1:10, function(x) {
    Sys.sleep(1)
    return(x^2)
}, mc.cores = 2)
print(result)

# Parallel sapply
result <- mcmapply(function(x) x^2, 1:10, mc.cores = 2)
print(result)

# Using foreach
# install.packages("foreach")
# install.packages("doParallel")
# library(foreach)
# library(doParallel)
# registerDoParallel(cores = 2)

# result <- foreach(i = 1:10) %dopar% {
#     Sys.sleep(1)
#     return(i^2)
# }
# print(result)

# Parallel random number generation
# RNGkind("L'Ecuyer-CMRG")
# set.seed(123)
# result <- mclapply(1:10, function(x) {
#     runif(1)
# }, mc.cores = 2)

# Parallel processing with clusters
cl <- makeCluster(2)
clusterExport(cl, "my_function")
result <- parLapply(cl, 1:10, function(x) x^2)
stopCluster(cl)

# Parallel apply
result <- parApply(cl, matrix(1:9, 3, 3), 1, sum)
stopCluster(cl)

# Using parallel with data frames
# library(parallel)
# df <- data.frame(x = 1:1000, y = rnorm(1000))
# result <- mclapply(1:nrow(df), function(i) {
#     df[i, "x"] + df[i, "y"]
# }, mc.cores = 2)

# Using snow package
# library(snow)
# cl <- makeCluster(2)
# clusterExport(cl, "my_function")
# result <- clusterApply(cl, 1:10, function(x) x^2)
# stopCluster(cl)

# Metaprogramming in R
# Using eval and parse
code <- "x <- 10; y <- 20; x + y"
result <- eval(parse(text = code))
print(result)

# Dynamic function calls
add <- function(a, b) { return(a + b) }
function_name <- "add"
result <- do.call(function_name, list(5, 3))
print(result)

# Dynamic method calls
obj <- list(
    method1 = function() { return("Method 1 called") },
    method2 = function() { return("Method 2 called") }
)
method_name <- "method1"
result <- obj[[method_name]]()
print(result)

# Using bquote for expression construction
x <- 10
expr <- bquote(.(x) + 3)
print(eval(expr))

# Using substitute
expr <- substitute(x + y, list(x = 10, y = 20))
print(eval(expr))

# Using quote
expr <- quote(x + y)
print(eval(expr, list(x = 10, y = 20)))

# Using call
call_expr <- call("+", 10, 20)
print(eval(call_expr))

# Creating functions dynamically
func <- function(x, expr) {
    return(eval(substitute(expr), list(x = x)))
}
result <- func(5, x^2)
print(result)

# Using with
data <- list(a = 10, b = 20)
result <- with(data, a + b)
print(result)

# Using within
data <- list(a = 10, b = 20)
result <- within(data, { c <- a + b })
print(result)

# Using attach/detach
data <- list(a = 10, b = 20)
attach(data)
print(a + b)
detach(data)

# Using environments
env <- new.env()
env$x <- 10
env$y <- 20
eval(quote(x + y), env)

# Interoperability with C in R
# Using .C for C interface
# C function: void add(double *a, double *b, double *c)
# .C("add", a = as.double(5), b = as.double(3), c = as.double(0))

# Using .Call for C interface
# C function: SEXP add(SEXP a, SEXP b)
# .Call("add", 5, 3)

# Using Rcpp
# install.packages("Rcpp")
# library(Rcpp)

# cppFunction('
#     int add(int a, int b) {
#         return a + b;
#     }
# ')
# print(add(5, 3))

# Using Rcpp with vectors
# cppFunction('
#     NumericVector add_vec(NumericVector a, NumericVector b) {
#         return a + b;
#     }
# ')
# print(add_vec(c(1,2,3), c(4,5,6)))

# Using sourceCpp
# Rcpp::sourceCpp("my_functions.cpp")

# Using .Fortran for Fortran interface
# .Fortran("add", as.double(5), as.double(3), as.double(0))

# External pointers
# .Call("create_pointer")
# .Call("use_pointer", ptr)

# Inline C code
# library(inline)
# code <- "
#     SEXP add(SEXP a, SEXP b) {
#         return ScalarInteger(INTEGER(a)[0] + INTEGER(b)[0]);
#     }
# "
# add <- cfunction(c(a = "integer", b = "integer"), code)
# print(add(5L, 3L))

# Using C++ with Rcpp
# library(Rcpp)
# cppFunction('
#     NumericVector square(NumericVector x) {
#         return x * x;
#     }
# ')
# print(square(1:10))

# Compiling C code
# system("R CMD SHLIB mycode.c")
# dyn.load("mycode.so")
# .C("my_function", ...)

# Performance Optimization in R
# Performance tips

# 1. Use vectorized operations
vectorized <- function(x) {
    return(x^2)
}

# 2. Avoid loops when possible
# Instead of:
# result <- numeric(1000)
# for (i in 1:1000) {
#     result[i] <- i^2
# }

# Use:
result <- (1:1000)^2

# 3. Preallocate vectors
preallocate <- function(n) {
    result <- numeric(n)
    for (i in 1:n) {
        result[i] <- i^2
    }
    return(result)
}

# 4. Use apply family functions
# lapply, sapply, vapply, apply

# 5. Use data.table for large data
# library(data.table)
# dt <- data.table(x = 1:1000, y = rnorm(1000))
# dt[, z := x + y]

# 6. Use matrix operations
matrix_ops <- function(A, B) {
    return(A %*% B)
}

# 7. Use Rcpp for critical code
# library(Rcpp)
# cppFunction('
#     NumericVector square(NumericVector x) {
#         return x * x;
#     }
# ')

# 8. Use byte code compilation
# library(compiler)
# f <- cmpfun(function(x) x^2)

# 9. Use profvis for profiling
# library(profvis)
# profvis({
#     # Code to profile
# })

# 10. Use microbenchmark for benchmarking
# library(microbenchmark)
# microbenchmark(
#     loop = { for (i in 1:100) i^2 },
#     vectorized = { (1:100)^2 }
# )

# 11. Use memory profiling
# memory.profile()

# 12. Use gc() for garbage collection
# gc()

# 13. Use set operations
# union, intersect, setdiff

# 14. Use fast functions from base R
# rowSums, colSums, rowMeans, colMeans

# Networking in R
# HTTP GET request using httr
# install.packages("httr")
library(httr)

fetch_data <- function(url) {
    tryCatch({
        response <- GET(url)
        return(content(response, "text"))
    }, error = function(e) {
        print(paste("Error:", e$message))
        return(NULL)
    })
}

# Example
# data <- fetch_data("https://api.github.com")
# print(substr(data, 1, 500))

# HTTP POST request
post_data <- function(url, data) {
    tryCatch({
        response <- POST(url,
            body = data,
            encode = "json",
            content_type_json()
        )
        return(content(response, "text"))
    }, error = function(e) {
        print(paste("Error:", e$message))
        return(NULL)
    })
}

# Using curl
library(curl)

# GET request with curl
curl_fetch <- function(url) {
    handle <- new_handle()
    response <- curl_fetch_memory(url, handle = handle)
    return(rawToChar(response$content))
}

# WebSocket (using websocket package)
# library(websocket)
# ws <- WebSocket$new("wss://echo.websocket.org")
# ws$onMessage(function(event) {
#     print(paste("Received:", event$data))
# })
# ws$send("Hello")

# TCP client
tcp_client <- function(host, port, message) {
    con <- socketConnection(host = host, port = port, blocking = TRUE)
    writeLines(message, con)
    response <- readLines(con, 1)
    close(con)
    return(response)
}

# TCP server
tcp_server <- function(port = 8080) {
    server <- serverSocket(port)
    print(paste("Server listening on port", port))
    
    while (TRUE) {
        client <- acceptSocket(server)
        request <- readLines(client, 1)
        response <- "HTTP/1.1 200 OK\r\nContent-Type: text/html\r\n\r\nHello from server!"
        writeLines(response, client)
        close(client)
    }
}

# DNS resolution
# library(nsl)
# hostname <- "example.com"
# ip <- nsl(hostname)
# print(ip)

# Working with JSON in R
# Using jsonlite
library(jsonlite)

# Encode to JSON
data <- list(
    name = "Alice",
    age = 25,
    city = "NYC",
    hobbies = c("reading", "coding")
)
json_string <- toJSON(data, auto_unbox = TRUE)
print(json_string)

# Pretty print
pretty_json <- toJSON(data, auto_unbox = TRUE, pretty = TRUE)
print(pretty_json)

# Decode from JSON
json_str <- '{"name":"Bob","age":30,"city":"LA"}'
parsed <- fromJSON(json_str)
print(parsed$name)
print(parsed$age)

# Working with arrays
json_array <- toJSON(c(1, 2, 3, 4, 5))
print(json_array)
parsed_array <- fromJSON(json_array)
print(parsed_array)

# Nested structures
nested <- list(
    user = list(
        id = 1,
        profile = list(
            name = "Alice",
            email = "alice@example.com"
        )
    )
)
print(toJSON(nested, auto_unbox = TRUE, pretty = TRUE))

# Read JSON from file
data <- fromJSON("data.json")

# Write JSON to file
write_json(data, "output.json", pretty = TRUE)

# Error handling
tryCatch({
    parsed <- fromJSON('{"invalid":"json"}')
}, error = function(e) {
    print(paste("JSON Error:", e$message))
})

# JSON with data frame
df <- data.frame(
    name = c("Alice", "Bob"),
    age = c(25, 30)
)
json_df <- toJSON(df)
print(json_df)
parsed_df <- fromJSON(json_df)
print(parsed_df)

# Streaming JSON
# stream_in(file("data.json"))
# stream_out(data, file("output.json"))

# Testing in R
# Using testthat
# install.packages("testthat")
library(testthat)

# Basic tests
test_that("Math operations work", {
    expect_equal(1 + 1, 2)
    expect_equal(2 * 3, 6)
})

# Floating point tests
test_that("Floating point works", {
    expect_equal(0.1 + 0.2, 0.3, tolerance = 0.001)
})

# Exception tests
test_that("Division by zero throws error", {
    expect_error(10 / 0)
})

# Tests with lists
test_that("List operations work", {
    lst <- list(1, 2, 3)
    expect_length(lst, 3)
    expect_equal(lst[[2]], 2)
})

# Tests with data frames
test_that("Data frame operations work", {
    df <- data.frame(name = c("Alice", "Bob"), age = c(25, 30))
    expect_equal(nrow(df), 2)
    expect_equal(ncol(df), 2)
    expect_equal(df$name[1], "Alice")
})

# Property-based testing
test_that("Addition is associative", {
    for (i in 1:100) {
        x <- runif(1, 1, 100)
        expect_equal(x + 0, x)
    }
})

# Tests with fixtures
setup <- function() {
    return(list(x = 10, y = 20))
}

test_that("Fixture works", {
    data <- setup()
    expect_equal(data$x + data$y, 30)
})

# Running tests
# test_file("test_file.R")
# test_dir("tests/")
# test_package("mypackage")

# Using with with testthat
# with_mock(
#     `function` = mock_function,
#     expect_equal(function(), expected)
# )

# Skip tests
# skip("Skipping this test")

# Expectation functions
# expect_equal()
# expect_identical()
# expect_match()
# expect_output()
# expect_message()
# expect_warning()
# expect_error()

# Debugging in R
# Using print for debugging
debug_function <- function(x) {
    print(paste("Entering function with x =", x))
    result <- x * 2
    print(paste("Result =", result))
    return(result)
}
debug_function(5)

# Using browser for interactive debugging
debug_function <- function(x) {
    browser()
    result <- x * 2
    return(result)
}

# Using debug
debug(debug_function)
debug_function(5)
undebug(debug_function)

# Using trace
trace("mean", browser)
mean(1:10)
untrace("mean")

# Using recover for error debugging
options(error = recover)
# Code that errors
options(error = NULL)

# Using traceback
# traceback()

# Using warnings
options(warn = 1)
warning("This is a warning")
options(warn = 0)

# Using stop for errors
stop("This is an error")

# Using try for error handling
result <- try(10 / 0, silent = TRUE)
if (inherits(result, "try-error")) {
    print("Division by zero")
}

# Using tryCatch for advanced handling
tryCatch({
    result <- 10 / 0
}, warning = function(w) {
    print(paste("Warning:", w$message))
}, error = function(e) {
    print(paste("Error:", e$message))
})

# Using assertthat
# install.packages("assertthat")
# library(assertthat)
# assert_that(is.numeric(x))
# assert_that(x > 0)

# Using stopifnot
stopifnot(1 == 2)

# Using message for informational messages
message("This is a message")

# Using cat for output
cat("Debug:", x, "\n")

# Using sprintf for formatted output
print(sprintf("Value: %d", x))

# Abstract Classes and Interfaces in R
# Using S3 for abstract classes
# Define abstract class
Animal <- function(name, age) {
    obj <- list(name = name, age = age)
    class(obj) <- c("Animal")
    return(obj)
}

# Abstract method
make_sound <- function(obj) {
    UseMethod("make_sound")
}

# Default method
make_sound.default <- function(obj) {
    stop("make_sound not implemented for this class")
}

# Concrete classes
Dog <- function(name, age) {
    obj <- Animal(name, age)
    class(obj) <- c("Dog", "Animal")
    return(obj)
}

Cat <- function(name, age) {
    obj <- Animal(name, age)
    class(obj) <- c("Cat", "Animal")
    return(obj)
}

# Implement methods
make_sound.Dog <- function(obj) {
    return("Woof!")
}

make_sound.Cat <- function(obj) {
    return("Meow!")
}

# Using S4 for formal classes
# setClass("AnimalS4",
#     slots = list(
#         name = "character",
#         age = "numeric"
#     )
# )
# setGeneric("make_sound_s4", function(obj) standardGeneric("make_sound_s4"))
# setMethod("make_sound_s4", "AnimalS4", function(obj) {
#     stop("make_sound_s4 not implemented")
# })
# setClass("DogS4", contains = "AnimalS4")
# setMethod("make_sound_s4", "DogS4", function(obj) {
#     return("Woof!")
# })

# Usage
dog <- Dog("Rex", 3)
cat <- Cat("Whiskers", 2)

print(make_sound(dog))
print(make_sound(cat))

# Type checking
print(inherits(dog, "Animal"))
print(inherits(dog, "Dog"))
print(inherits(dog, "Cat"))

# Interface-like using S3 methods
# Define interface
speak <- function(obj) {
    UseMethod("speak")
}

# Implement interface for classes
speak.Dog <- function(obj) {
    return("Woof!")
}

speak.Cat <- function(obj) {
    return("Meow!")
}

# Check if object implements interface
has_method <- function(obj, method) {
    return(paste0(method, ".", class(obj)[1]) %in% methods(method))
}

print(has_method(dog, "speak"))
print(has_method(cat, "speak"))

# Generic Functions in R
# Creating generic functions
my_generic <- function(x) {
    UseMethod("my_generic")
}

# Default method
my_generic.default <- function(x) {
    return("Default method")
}

# Methods for specific classes
my_generic.numeric <- function(x) {
    return(paste("Numeric:", x))
}

my_generic.character <- function(x) {
    return(paste("Character:", x))
}

# S3 generic with multiple dispatch
my_generic2 <- function(x, y) {
    UseMethod("my_generic2")
}

my_generic2.numeric <- function(x, y) {
    return(x + y)
}

my_generic2.character <- function(x, y) {
    return(paste(x, y))
}

# S4 generics
# setGeneric("my_s4_generic", function(x) standardGeneric("my_s4_generic"))
# setMethod("my_s4_generic", "numeric", function(x) {
#     return(x * 2)
# })
# setMethod("my_s4_generic", "character", function(x) {
#     return(toupper(x))
# })

# Generic with default arguments
my_generic3 <- function(x, factor = 1) {
    UseMethod("my_generic3")
}

my_generic3.default <- function(x, factor = 1) {
    return(x * factor)
}

my_generic3.numeric <- function(x, factor = 2) {
    return(x * factor)
}

# Method dispatch
print(my_generic(10))
print(my_generic("hello"))
print(my_generic(TRUE))

print(my_generic2(10, 20))
print(my_generic2("hello", "world"))

# Checking methods
print(methods(my_generic))
print(methods(my_generic2))

# Finding method
print(getS3method("my_generic", "numeric"))

# Using NextMethod
my_generic4 <- function(x) {
    UseMethod("my_generic4")
}

my_generic4.default <- function(x) {
    return("Default")
}

my_generic4.numeric <- function(x) {
    return(paste("Numeric:", NextMethod()))
}

print(my_generic4(10))

# S3 and S4 Classes in R
# S3 Class
# Define class
person <- function(name, age, city = "Unknown") {
    obj <- list(
        name = name,
        age = age,
        city = city
    )
    class(obj) <- "Person"
    return(obj)
}

# Methods for S3 class
print.Person <- function(x) {
    cat("Name:", x$name, "\n")
    cat("Age:", x$age, "\n")
    cat("City:", x$city, "\n")
}

summary.Person <- function(object) {
    cat(paste("Person:", object$name, "
"))
    cat(paste("Age:", object$age, "
"))
    cat(paste("City:", object$city, "
"))
}

# S4 Class
# setClass("Animal",
#     slots = list(
#         name = "character",
#         age = "numeric",
#         sound = "character"
#     )
# )
# 
# setMethod("show", "Animal", function(object) {
#     cat("Animal:", object@name, "
")
#     cat("Age:", object@age, "
")
#     cat("Sound:", object@sound, "
")
# })

# Reference Class (R5)
# PersonRC <- setRefClass("PersonRC",
#     fields = list(
#         name = "character",
#         age = "numeric",
#         city = "character"
#     ),
#     methods = list(
#         initialize = function(name, age, city = "Unknown") {
#             .self$name <- name
#             .self$age <- age
#             .self$city <- city
#         },
#         greet = function() {
#             return(paste("Hello, I'm", name))
#         }
#     )
# )
# 
# alice <- PersonRC$new("Alice", 25, "NYC")
# print(alice$greet())

# Usage
alice <- person("Alice", 25, "NYC")
print(alice)
summary(alice)

# S3 class checking
print(class(alice))
print(inherits(alice, "Person"))

# S3 class inheritance
Employee <- function(name, age, city, title) {
    obj <- person(name, age, city)
    obj$title <- title
    class(obj) <- c("Employee", "Person")
    return(obj)
}

bob <- Employee("Bob", 30, "LA", "Developer")
print(bob)

# S3 method for Employee
print.Employee <- function(x) {
    NextMethod()
    cat("Title:", x$title, "
")
}

# Generators and Coroutines in R
# Using functions with closure as generators
fibonacci_generator <- function() {
    a <- 0
    b <- 1
    function() {
        c <- a
        a <<- b
        b <<- c + b
        return(c)
    }
}

fib <- fibonacci_generator()
for (i in 1:10) {
    print(fib())
}

# Counter generator
counter_generator <- function(start = 0) {
    count <- start
    function() {
        count <<- count + 1
        return(count)
    }
}

counter <- counter_generator()
print(counter())
print(counter())
print(counter())

# Using iterators package
# install.packages("iterators")
# library(iterators)
# it <- iter(1:10)
# while (TRUE) {
#     val <- try(nextElem(it), silent = TRUE)
#     if (inherits(val, "try-error")) break
#     print(val)
# }

# Using yield-like behavior with returns
generate_numbers <- function(start, end) {
    for (i in start:end) {
        i
    }
}

# Using coroutines with async
# install.packages("coro")
# library(coro)
# 
# async_function <- async(function() {
#     await(delay(1))
#     return("Done")
# })
# 
# result <- sync(async_function())
# print(result)

# Using promises
# install.packages("promises")
# library(promises)
# 
# promise <- future({ Sys.sleep(2); 42 })
# promise <- promise(...)

# Using R6 for coroutine-like behavior
# library(R6)
# Coroutine <- R6Class("Coroutine",
#     private = list(
#         state = 0
#     ),
#     public = list(
#         next_value = function() {
#             private$state <- private$state + 1
#             return(private$state)
#         }
#     )
# )
# 
# coro <- Coroutine$new()
# print(coro$next_value())
# print(coro$next_value())
# print(coro$next_value())

# Generator using environment
generator <- function() {
    env <- new.env()
    env$state <- 0
    function() {
        env$state <- env$state + 1
        return(env$state)
    }
}
gen <- generator()
print(gen())
print(gen())
print(gen())

# Advanced Array Operations
# Array initialization
A <- array(0, dim = c(3, 3))
B <- array(1, dim = c(3, 3))
C <- array(5, dim = c(3, 3))

# Identity matrix
I <- diag(3)

# Reshaping
arr <- 1:9
matrix_reshaped <- matrix(arr, nrow = 3, ncol = 3)
print(matrix_reshaped)

# Transpose
print(t(matrix_reshaped))

# Element-wise operations
A <- matrix(1:9, nrow = 3, ncol = 3)
B <- A + 1
C <- A * 2
D <- A^2

print(B)
print(C)
print(D)

# Matrix multiplication
X <- matrix(runif(9), nrow = 3, ncol = 3)
Y <- matrix(runif(9), nrow = 3, ncol = 3)
Z <- X %*% Y
print(Z)

# Element-wise multiplication
W <- X * Y
print(W)

# Linear algebra functions
norm_X <- norm(X, type = "F")
trace_X <- sum(diag(X))
diag_X <- diag(X)

print(paste("Norm:", norm_X))
print(paste("Trace:", trace_X))
print(paste("Diagonal:", paste(diag_X, collapse = ", ")))

# Array operations with apply
row_sums <- apply(A, 1, sum)
col_sums <- apply(A, 2, sum)

print(row_sums)
print(col_sums)

# Broadcasting (recycling)
vec <- c(1, 2, 3)
result <- A + vec
print(result)

# Outer product
outer_result <- outer(1:3, 1:3, function(x, y) x^2 + y^2)
print(outer_result)

# Kronecker product
kronecker_result <- kronecker(matrix(1:4, 2, 2), matrix(1:4, 2, 2))
print(kronecker_result)

# Working with Missing Data (NA)
# Creating vectors with missing values
data <- c(1, 2, NA, 4, 5, NA, 7)
print(data)

# Check for missing values
print(is.na(data))
print(any(is.na(data)))

# Remove missing values
clean_data <- na.omit(data)
print(clean_data)

# Remove missing values (alternative)
clean_data <- data[!is.na(data)]
print(clean_data)

# Replace missing values
replaced <- ifelse(is.na(data), 0, data)
print(replaced)

# Operations with missing values
x <- c(1, 2, NA, 4)
y <- c(5, 6, NA, 8)
z <- x + y  # Results in c(6, 8, NA, 12)
print(z)

# Ignoring missing values
sum_complete <- sum(x, na.rm = TRUE)
print(sum_complete)

# Working with data frames
df <- data.frame(
    A = c(1, 2, 3, 4),
    B = c(NA, 5, 6, NA),
    C = c("x", NA, "z", "w")
)
print(df)

# Summary with missing values
print(summary(df))

# Drop missing rows
df_clean <- na.omit(df)
print(df_clean)

# Complete cases
complete <- complete.cases(df)
print(complete)
df_clean2 <- df[complete, ]
print(df_clean2)

# Using tidyr for missing data
# library(tidyr)
# df %>% drop_na()
# df %>% replace_na(list(A = 0, B = 0, C = "Unknown"))

# Using dplyr for missing data
# library(dplyr)
# df %>% filter(!is.na(A))
# df %>% mutate(A = ifelse(is.na(A), 0, A))

# Interpolation
# library(zoo)
# na.approx(data)
# na.locf(data)

# Sorting and Searching
# Basic sorting
arr <- c(5, 2, 8, 1, 9, 3)
sorted <- sort(arr)
print(sorted)

# Sorting without mutation
arr2 <- c(5, 2, 8, 1, 9, 3)
sorted <- sort(arr2)
print(arr2)
print(sorted)

# Sorting with custom comparator
arr3 <- data.frame(
    x = c(5, 3, 8),
    y = c("apple", "banana", "cherry")
)
sorted3 <- arr3[order(arr3$x), ]
print(sorted3)

# Sorting descending
arr4 <- c(5, 2, 8, 1, 9, 3)
sorted4 <- sort(arr4, decreasing = TRUE)
print(sorted4)

# Sorting data frames
df <- data.frame(
    name = c("Alice", "Bob", "Charlie", "David"),
    age = c(25, 30, 35, 40)
)
sorted_df <- df[order(df$age), ]
print(sorted_df)

# Search functions
arr5 <- c(1, 3, 5, 7, 9, 11)
greater_than_5 <- arr5[arr5 > 5]
print(greater_than_5)

first_greater_than_5 <- arr5[arr5 > 5][1]
print(paste("First greater:", first_greater_than_5))

last_greater_than_5 <- arr5[arr5 > 5][length(arr5[arr5 > 5])]
print(paste("Last greater:", last_greater_than_5))

# Contains
has_seven <- 7 %in% arr5
has_four <- 4 %in% arr5
print(paste("Has 7:", has_seven))
print(paste("Has 4:", has_four))

# Find indices
indices <- which(arr5 > 5)
print(indices)

# Find position
pos <- match(7, arr5)
print(paste("Position of 7:", pos))

# Binary search (requires sorted array)
binary_search <- function(arr, target) {
    left <- 1
    right <- length(arr)
    while (left <= right) {
        mid <- floor((left + right) / 2)
        if (arr[mid] == target) {
            return(mid)
        } else if (arr[mid] < target) {
            left <- mid + 1
        } else {
            right <- mid - 1
        }
    }
    return(-1)
}

arr6 <- c(1, 2, 3, 4, 5, 6, 7)
index <- binary_search(arr6, 5)
print(paste("Found at index:", index))

# Mathematical Operations
# Basic arithmetic
x <- 10
y <- 3
print(paste("x + y =", x + y))
print(paste("x - y =", x - y))
print(paste("x * y =", x * y))
print(paste("x / y =", x / y))
print(paste("x %% y =", x %% y))
print(paste("x ^ y =", x ^ y))

# Mathematical functions
print(paste("sin(pi/4) =", sin(pi/4)))
print(paste("cos(pi/4) =", cos(pi/4)))
print(paste("tan(pi/4) =", tan(pi/4)))
print(paste("exp(1) =", exp(1)))
print(paste("log(e) =", log(exp(1))))
print(paste("log10(100) =", log10(100)))
print(paste("sqrt(9) =", sqrt(9)))

# Special functions
print(paste("abs(-5) =", abs(-5)))
print(paste("ceiling(3.14) =", ceiling(3.14)))
print(paste("floor(3.14) =", floor(3.14)))
print(paste("round(3.14) =", round(3.14)))
print(paste("max(1, 3, 5, 2, 4) =", max(c(1, 3, 5, 2, 4))))
print(paste("min(1, 3, 5, 2, 4) =", min(c(1, 3, 5, 2, 4))))

# Random numbers
set.seed(123)
print(paste("Random uniform:", runif(1)))
print(paste("Random normal:", rnorm(1)))
print(paste("Random integer:", sample(1:10, 1)))

# Statistics (using base R)
data <- 1:10
print(paste("sum =", sum(data)))
print(paste("mean =", mean(data)))
print(paste("min =", min(data)))
print(paste("max =", max(data)))

# Linear algebra functions
A <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)
B <- matrix(c(5, 6, 7, 8), nrow = 2, ncol = 2)
C <- A %*% B
print(C)

# Eigenvalues
eigen_values <- eigen(A)$values
print(eigen_values)

# Determinant
det_A <- det(A)
print(paste("Determinant:", det_A))

# Data Serialization
# Using save and load
data <- list(name = "Alice", age = 25, hobbies = c("reading", "coding"))
save(data, file = "data.RData")
loaded_data <- load("data.RData")
print(data)

# Using saveRDS and readRDS
saveRDS(data, file = "data.rds")
loaded_data <- readRDS("data.rds")
print(loaded_data)

# Using dput and dget
dput(data, file = "data.R")
loaded_data <- dget("data.R")
print(loaded_data)

# Using JSON
library(jsonlite)
json_data <- toJSON(data, auto_unbox = TRUE)
write(json_data, file = "data.json")
loaded_data <- fromJSON("data.json")
print(loaded_data)

# Using CSV
df <- data.frame(
    name = c("Alice", "Bob"),
    age = c(25, 30)
)
write.csv(df, file = "data.csv", row.names = FALSE)
loaded_df <- read.csv("data.csv")
print(loaded_df)

# Using XML
# library(XML)
# xml_data <- xmlTreeParse("data.xml")
# loaded_data <- xmlToList(xml_data)

# Using YAML
# library(yaml)
# yaml_data <- as.yaml(data)
# write(yaml_data, file = "data.yaml")
# loaded_data <- yaml.load_file("data.yaml")

# Using feather
# library(feather)
# write_feather(df, "data.feather")
# loaded_df <- read_feather("data.feather")

# Using parquet
# library(arrow)
# write_parquet(df, "data.parquet")
# loaded_df <- read_parquet("data.parquet")

# Serialization with raw
serialized <- serialize(data, NULL)
deserialized <- unserialize(serialized)
print(deserialized)

# Interfacing with External Systems
# Database connections
# Using RSQLite
# library(RSQLite)
# con <- dbConnect(SQLite(), "database.db")
# dbWriteTable(con, "users", data.frame(id = 1:3, name = c("Alice", "Bob", "Charlie")))
# data <- dbGetQuery(con, "SELECT * FROM users")
# dbDisconnect(con)

# Using RMySQL
# library(RMySQL)
# con <- dbConnect(MySQL(), 
#     host = "localhost",
#     user = "user",
#     password = "pass",
#     dbname = "test"
# )
# data <- dbGetQuery(con, "SELECT * FROM users")
# dbDisconnect(con)

# Using ODBC
# library(odbc)
# con <- dbConnect(odbc(), 
#     Driver = "SQL Server",
#     Server = "localhost",
#     Database = "test",
#     UID = "user",
#     PWD = "pass"
# )
# data <- dbGetQuery(con, "SELECT * FROM users")
# dbDisconnect(con)

# Executing shell commands
system("ls -la")
output <- system("ls -la", intern = TRUE)
print(output)

# Using reticulate for Python
# library(reticulate)
# py_run_string("import numpy as np")
# py_run_string("arr = np.array([1, 2, 3, 4, 5])")
# arr <- py$arr
# print(arr)

# Using httr for HTTP
# library(httr)
# response <- GET("https://api.github.com")
# content(response)

# Using XML for web scraping
# library(xml2)
# page <- read_html("https://example.com")
# nodes <- xml_find_all(page, "//a")

# Using jsonlite for JSON
# library(jsonlite)
# data <- fromJSON("https://api.github.com")

# Using rvest for web scraping
# library(rvest)
# page <- read_html("https://example.com")
# title <- html_text(html_nodes(page, "title"))

# Using curl for downloads
# library(curl)
# curl_download("https://example.com/file.csv", "file.csv")

# Reverse a string
reverse_string <- function(s) {
    chars <- strsplit(s, "")[[1]]
    reversed <- paste(rev(chars), collapse = "")
    return(reversed)
}

reverse_string_manual <- function(s) {
    chars <- strsplit(s, "")[[1]]
    len <- length(chars)
    reversed <- character(len)
    for (i in 1:len) {
        reversed[i] <- chars[len - i + 1]
    }
    return(paste(reversed, collapse = ""))
}

reverse_string_recursive <- function(s) {
    if (nchar(s) <= 1) {
        return(s)
    }
    return(paste0(
        reverse_string_recursive(substr(s, 2, nchar(s))),
        substr(s, 1, 1)
    ))
}

s <- "hello"
print(paste("Original:", s))
print(paste("Reversed:", reverse_string(s)))
print(paste("Reversed (manual):", reverse_string_manual(s)))
print(paste("Reversed (recursive):", reverse_string_recursive(s)))

# Check palindrome
is_palindrome <- function(s) {
    cleaned <- tolower(gsub(" ", "", s))
    return(cleaned == reverse_string(cleaned))
}

is_palindrome_manual <- function(s) {
    cleaned <- tolower(gsub(" ", "", s))
    chars <- strsplit(cleaned, "")[[1]]
    len <- length(chars)
    for (i in 1:floor(len/2)) {
        if (chars[i] != chars[len - i + 1]) {
            return(FALSE)
        }
    }
    return(TRUE)
}

is_palindrome_recursive <- function(s) {
    cleaned <- tolower(gsub(" ", "", s))
    if (nchar(cleaned) <= 1) {
        return(TRUE)
    }
    if (substr(cleaned, 1, 1) != substr(cleaned, nchar(cleaned), nchar(cleaned))) {
        return(FALSE)
    }
    return(is_palindrome_recursive(substr(cleaned, 2, nchar(cleaned) - 1)))
}

strings <- c("racecar", "hello", "A man a plan a canal Panama", "race a car")
for (s in strings) {
    print(paste(s, "is palindrome:", is_palindrome(s)))
}

# Find max in vector
find_max <- function(arr) {
    return(max(arr))
}

find_max_manual <- function(arr) {
    if (length(arr) == 0) {
        return(NULL)
    }
    max_val <- arr[1]
    for (val in arr) {
        if (val > max_val) {
            max_val <- val
        }
    }
    return(max_val)
}

find_max_recursive <- function(arr, index = 1, max_val = NULL) {
    if (index > length(arr)) {
        return(max_val)
    }
    if (is.null(max_val) || arr[index] > max_val) {
        max_val <- arr[index]
    }
    return(find_max_recursive(arr, index + 1, max_val))
}

arr <- c(1, 5, 3, 9, 2)
print(paste("Array:", paste(arr, collapse = ", ")))
print(paste("Max:", find_max(arr)))
print(paste("Max (manual):", find_max_manual(arr)))
print(paste("Max (recursive):", find_max_recursive(arr)))

# Remove duplicates
remove_duplicates <- function(arr) {
    return(unique(arr))
}

remove_duplicates_manual <- function(arr) {
    seen <- c()
    result <- c()
    for (val in arr) {
        if (!(val %in% seen)) {
            seen <- c(seen, val)
            result <- c(result, val)
        }
    }
    return(result)
}

remove_duplicates_set <- function(arr) {
    return(names(table(arr)))
}

arr <- c("apple", "banana", "apple", "orange", "banana", "grape")
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Without duplicates:", paste(remove_duplicates(arr), collapse = ", ")))
print(paste("Without duplicates (manual):", paste(remove_duplicates_manual(arr), collapse = ", ")))

# Merge vectors
merge_arrays <- function(arr1, arr2) {
    return(c(arr1, arr2))
}

merge_sorted <- function(arr1, arr2) {
    result <- c()
    i <- 1
    j <- 1
    while (i <= length(arr1) && j <= length(arr2)) {
        if (arr1[i] <= arr2[j]) {
            result <- c(result, arr1[i])
            i <- i + 1
        } else {
            result <- c(result, arr2[j])
            j <- j + 1
        }
    }
    while (i <= length(arr1)) {
        result <- c(result, arr1[i])
        i <- i + 1
    }
    while (j <= length(arr2)) {
        result <- c(result, arr2[j])
        j <- j + 1
    }
    return(result)
}

arr1 <- c(1, 2, 3)
arr2 <- c(4, 5, 6)
print(paste("Merged:", paste(merge_arrays(arr1, arr2), collapse = ", ")))

sorted1 <- c(1, 3, 5, 7)
sorted2 <- c(2, 4, 6, 8)
print(paste("Merged sorted:", paste(merge_sorted(sorted1, sorted2), collapse = ", ")))

# Convert string to number
string_to_number <- function(s) {
    return(as.numeric(s))
}

string_to_int <- function(s) {
    return(as.integer(s))
}

string_to_float <- function(s) {
    return(as.numeric(s))
}

string_to_number_safe <- function(s) {
    result <- tryCatch(as.numeric(s), warning = function(w) NA)
    if (is.na(result)) {
        return(0)
    }
    return(result)
}

strings <- c("42", "3.14", "hello", "123", "45.67")
for (s in strings) {
    print(paste(s, "-> int:", string_to_int(s), "float:", string_to_float(s)))
}

# Loop through list (dictionary)
loop_dict <- function(dict) {
    for (key in names(dict)) {
        print(paste(key, "=>", dict[[key]]))
    }
}

find_key <- function(dict, key) {
    if (key %in% names(dict)) {
        return(dict[[key]])
    }
    return(NULL)
}

data <- list(name = "Alice", age = 25, city = "NYC")
print("Dictionary:")
loop_dict(data)
print("")

name <- find_key(data, "name")
print(paste("Name:", name))
country <- find_key(data, "country")
print(paste("Country:", ifelse(is.null(country), "Not found", country)))

# Delay function execution
delay_seconds <- function(seconds, callback) {
    Sys.sleep(seconds)
    return(callback())
}

delay_async <- function(seconds, callback) {
    # Using parallel for async
    library(parallel)
    mcparallel({
        Sys.sleep(seconds)
        callback()
    })
}

delay_with_callback <- function(seconds, callback, result_callback) {
    library(parallel)
    mcparallel({
        Sys.sleep(seconds)
        result <- callback()
        result_callback(result)
    })
}

delayed_print <- function(message, seconds) {
    print(paste("Starting delay of", seconds, "seconds"))
    delay_seconds(seconds, function() {
        print(message)
        return(TRUE)
    })
}

print("Delayed execution examples:")
delayed_print("After 2 seconds", 2)
print("Main script continues")

# Alternative using future
# library(future)
# future({
#     Sys.sleep(2)
#     print("After 2 seconds")
# })

# HTTP GET request
# Using httr
library(httr)

fetch_data <- function(url) {
    tryCatch({
        response <- GET(url)
        if (status_code(response) == 200) {
            return(content(response, "text"))
        } else {
            print(paste("HTTP error:", status_code(response)))
            return(NULL)
        }
    }, error = function(e) {
        print(paste("Error:", e$message))
        return(NULL)
    })
}

post_data <- function(url, data) {
    tryCatch({
        response <- POST(url,
            body = data,
            encode = "json",
            content_type_json()
        )
        return(content(response, "text"))
    }, error = function(e) {
        print(paste("Error:", e$message))
        return(NULL)
    })
}

# Using curl
library(curl)

fetch_data_curl <- function(url) {
    handle <- new_handle()
    response <- curl_fetch_memory(url, handle = handle)
    return(rawToChar(response$content))
}

# Example
# result <- fetch_data("https://api.github.com")
# if (!is.null(result)) {
#     print(substr(result, 1, 500))
# }

# Using RCurl
# library(RCurl)
# result <- getURL("https://api.github.com")

# Using jsonlite with URL
# library(jsonlite)
# data <- fromJSON("https://api.github.com")

# Create a promise-like task
# Using future
# library(future)
# plan(multisession)

create_promise <- function(should_resolve) {
    future({
        Sys.sleep(1)
        if (should_resolve) {
            return("Success!")
        } else {
            stop("Failed!")
        }
    })
}

# Using promises package
# library(promises)

create_promise_lite <- function(should_resolve) {
    promise(function(resolve, reject) {
        later::later(function() {
            if (should_resolve) {
                resolve("Success!")
            } else {
                reject("Failed!")
            }
        }, 1)
    })
}

# Chain promises
chain_promises <- function(p1, p2) {
    promise(function(resolve, reject) {
        p1 %>% 
            then(function(result1) {
                print(paste("First:", result1))
                return(p2)
            }) %>%
            then(function(result2) {
                print(paste("Second:", result2))
                resolve(list(result1, result2))
            }) %>%
            catch(function(error) {
                reject(error)
            })
    })
}

# Using async/await with promises
# library(await)
# await_all <- function(promises) {
#     promise_all(...)
# }

# Example
# p1 <- create_promise(TRUE)
# p2 <- create_promise(TRUE)
# chain_promises(p1, p2)

# Alternative using callbacks
create_promise_callback <- function(should_resolve, callback) {
    future({
        Sys.sleep(1)
        if (should_resolve) {
            callback(NULL, "Success!")
        } else {
            callback("Failed!", NULL)
        }
    })
}

# Usage
# create_promise_callback(TRUE, function(err, result) {
#     if (is.null(err)) {
#         print(paste("Result:", result))
#     } else {
#         print(paste("Error:", err))
#     }
# })

# Factorial
factorial_recursive <- function(n) {
    if (n <= 1) {
        return(1)
    }
    return(n * factorial_recursive(n - 1))
}

factorial_iterative <- function(n) {
    result <- 1
    for (i in 2:n) {
        result <- result * i
    }
    return(result)
}

factorial_tail <- function(n, acc = 1) {
    if (n <= 1) {
        return(acc)
    }
    return(factorial_tail(n - 1, acc * n))
}

n <- 5
print(paste("Factorial of", n, ":"))
print(paste("Recursive:", factorial_recursive(n)))
print(paste("Iterative:", factorial_iterative(n)))
print(paste("Tail recursive:", factorial_tail(n)))

# Fibonacci
fibonacci_recursive <- function(n) {
    if (n <= 1) {
        return(n)
    }
    return(fibonacci_recursive(n - 1) + fibonacci_recursive(n - 2))
}

fibonacci_iterative <- function(n) {
    if (n <= 1) {
        return(n)
    }
    a <- 0
    b <- 1
    for (i in 2:n) {
        c <- a + b
        a <- b
        b <- c
    }
    return(b)
}

fibonacci_memoized <- function(n) {
    cache <- c(0, 1)
    fib <- function(n) {
        if (n < length(cache)) {
            return(cache[n + 1])
        }
        result <- fib(n - 1) + fib(n - 2)
        cache <<- c(cache, result)
        return(result)
    }
    return(fib(n))
}

n <- 10
print(paste("Fibonacci of", n, ":"))
print(paste("Recursive:", fibonacci_recursive(n)))
print(paste("Iterative:", fibonacci_iterative(n)))
print(paste("Memoized:", fibonacci_memoized(n)))

# FizzBuzz
fizzbuzz <- function(n) {
    for (i in 1:n) {
        if (i %% 15 == 0) {
            print("FizzBuzz")
        } else if (i %% 3 == 0) {
            print("Fizz")
        } else if (i %% 5 == 0) {
            print("Buzz")
        } else {
            print(i)
        }
    }
}

fizzbuzz_vector <- function(n) {
    result <- character(n)
    for (i in 1:n) {
        if (i %% 15 == 0) {
            result[i] <- "FizzBuzz"
        } else if (i %% 3 == 0) {
            result[i] <- "Fizz"
        } else if (i %% 5 == 0) {
            result[i] <- "Buzz"
        } else {
            result[i] <- as.character(i)
        }
    }
    return(result)
}

fizzbuzz_apply <- function(n) {
    sapply(1:n, function(i) {
        if (i %% 15 == 0) "FizzBuzz"
        else if (i %% 3 == 0) "Fizz"
        else if (i %% 5 == 0) "Buzz"
        else as.character(i)
    })
}

print("FizzBuzz for 15:")
fizzbuzz(15)

print("FizzBuzz vector:")
result <- fizzbuzz_vector(15)
print(result)

# Find missing number
find_missing <- function(arr) {
    n <- length(arr) + 1
    total <- n * (n + 1) / 2
    sum_arr <- sum(arr)
    return(total - sum_arr)
}

find_missing_xor <- function(arr) {
    n <- length(arr) + 1
    xor_all <- 0
    for (i in 1:n) {
        xor_all <- xor_all ^ i
    }
    xor_arr <- 0
    for (val in arr) {
        xor_arr <- xor_arr ^ val
    }
    return(xor_all ^ xor_arr)
}

arr <- c(1, 2, 4, 5, 6)
print(paste("Missing number:", find_missing(arr)))
print(paste("Missing number (XOR):", find_missing_xor(arr)))

# Find duplicates
find_duplicates <- function(arr) {
    seen <- c()
    duplicates <- c()
    for (val in arr) {
        if (val %in% seen && !(val %in% duplicates)) {
            duplicates <- c(duplicates, val)
        } else {
            seen <- c(seen, val)
        }
    }
    return(duplicates)
}

find_duplicates_table <- function(arr) {
    tbl <- table(arr)
    return(names(tbl[tbl > 1]))
}

arr <- c(1, 2, 3, 2, 4, 3, 5, 6, 5)
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Duplicates:", paste(find_duplicates(arr), collapse = ", ")))
print(paste("Duplicates (table):", paste(find_duplicates_table(arr), collapse = ", ")))

# Sum of vector
sum_vector <- function(arr) {
    return(sum(arr))
}

sum_vector_manual <- function(arr) {
    total <- 0
    for (val in arr) {
        total <- total + val
    }
    return(total)
}

sum_vector_reduce <- function(arr) {
    return(Reduce(, arr))
}

arr <- c(1, 2, 3, 4, 5)
print(paste("Vector:", paste(arr, collapse = ", ")))
print(paste("Sum:", sum_vector(arr)))
print(paste("Sum (manual):", sum_vector_manual(arr)))
print(paste("Sum (reduce):", sum_vector_reduce(arr)))

# Average of vector
average_vector <- function(arr) {
    if (length(arr) == 0) {
        return(0)
    }
    return(mean(arr))
}

average_integer <- function(arr) {
    if (length(arr) == 0) {
        return(0)
    }
    return(floor(sum(arr) / length(arr)))
}

int_arr <- c(1, 2, 3, 4, 5)
float_arr <- c(1.0, 2.0, 3.0, 4.0, 5.0)
print(paste("Average (int array):", average_vector(int_arr)))
print(paste("Average (float array):", mean(float_arr)))
print(paste("Average (integer):", average_integer(int_arr)))

# Sort vector ascending
sort_ascending <- function(arr) {
    return(sort(arr))
}

sort_ascending_inplace <- function(arr) {
    return(arr[order(arr)])
}

arr <- c(5, 2, 8, 1, 9, 3)
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Sorted ascending:", paste(sort_ascending(arr), collapse = ", ")))
print(paste("Sorted in-place:", paste(sort_ascending_inplace(arr), collapse = ", ")))

# Sort vector descending
sort_descending <- function(arr) {
    return(sort(arr, decreasing = TRUE))
}

sort_descending_inplace <- function(arr) {
    return(arr[order(arr, decreasing = TRUE)])
}

arr <- c(5, 2, 8, 1, 9, 3)
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Sorted descending:", paste(sort_descending(arr), collapse = ", ")))
print(paste("Sorted in-place:", paste(sort_descending_inplace(arr), collapse = ", ")))

# Flatten nested list
flatten <- function(lst) {
    result <- c()
    for (item in lst) {
        if (is.list(item)) {
            result <- c(result, flatten(item))
        } else {
            result <- c(result, item)
        }
    }
    return(result)
}

flatten_one_level <- function(lst) {
    return(unlist(lst))
}

nested <- list(list(1, 2), list(3, 4, 5), list(6), list(7, 8, 9, 10))
deeper <- list(list(1, 2), list(3, list(4, 5)))

print(paste("Nested:", paste(nested, collapse = ", ")))
print(paste("Flatten:", paste(flatten(nested), collapse = ", ")))
print(paste("Flatten one level:", paste(flatten_one_level(nested), collapse = ", ")))
print(paste("Deeper:", paste(deeper, collapse = ", ")))
print(paste("Flatten deeper:", paste(flatten(deeper), collapse = ", ")))

# Chunk vector
chunk_vector <- function(arr, size) {
    chunks <- list()
    for (i in seq(1, length(arr), by = size)) {
        end <- min(i + size - 1, length(arr))
        chunks[[length(chunks) + 1]] <- arr[i:end]
    }
    return(chunks)
}

arr <- 1:10
print(paste("Original:", paste(arr, collapse = ", ")))
print("Chunk (size 3):")
chunks <- chunk_vector(arr, 3)
for (chunk in chunks) {
    print(paste("[", paste(chunk, collapse = ", "), "]"))
}

# Binary search
binary_search <- function(arr, target) {
    left <- 1
    right <- length(arr)
    while (left <= right) {
        mid <- floor((left + right) / 2)
        if (arr[mid] == target) {
            return(mid)
        } else if (arr[mid] < target) {
            left <- mid + 1
        } else {
            right <- mid - 1
        }
    }
    return(-1)
}

binary_search_recursive <- function(arr, target, left = 1, right = NULL) {
    if (is.null(right)) {
        right <- length(arr)
    }
    if (left > right) {
        return(-1)
    }
    mid <- floor((left + right) / 2)
    if (arr[mid] == target) {
        return(mid)
    } else if (arr[mid] < target) {
        return(binary_search_recursive(arr, target, mid + 1, right))
    } else {
        return(binary_search_recursive(arr, target, left, mid - 1))
    }
}

arr <- c(1, 2, 3, 4, 5, 6, 7)
target <- 5
index <- binary_search(arr, target)
print(paste("Found", target, "at index:", index))

target2 <- 8
index2 <- binary_search(arr, target2)
print(paste("Found", target2, "at index:", index2))

# Quick sort
quick_sort <- function(arr) {
    if (length(arr) <= 1) {
        return(arr)
    }
    pivot <- arr[1]
    left <- arr[arr < pivot]
    right <- arr[arr > pivot]
    return(c(quick_sort(left), pivot, quick_sort(right)))
}

quick_sort_inplace <- function(arr, low = 1, high = NULL) {
    if (is.null(high)) {
        high <- length(arr)
    }
    if (low < high) {
        pi <- partition(arr, low, high)
        quick_sort_inplace(arr, low, pi - 1)
        quick_sort_inplace(arr, pi + 1, high)
    }
    return(arr)
}

partition <- function(arr, low, high) {
    pivot <- arr[high]
    i <- low - 1
    for (j in low:(high - 1)) {
        if (arr[j] <= pivot) {
            i <- i + 1
            temp <- arr[i]
            arr[i] <- arr[j]
            arr[j] <- temp
        }
    }
    temp <- arr[i + 1]
    arr[i + 1] <- arr[high]
    arr[high] <- temp
    return(i + 1)
}

arr <- c(5, 3, 8, 4, 2, 7, 1, 6)
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Quick sort:", paste(quick_sort(arr), collapse = ", ")))
print(paste("Quick sort (in-place):", paste(quick_sort_inplace(arr), collapse = ", ")))

# Merge sort
merge_sort <- function(arr) {
    if (length(arr) <= 1) {
        return(arr)
    }
    mid <- floor(length(arr) / 2)
    left <- merge_sort(arr[1:mid])
    right <- merge_sort(arr[(mid + 1):length(arr)])
    return(merge(left, right))
}

merge <- function(left, right) {
    result <- c()
    i <- 1
    j <- 1
    while (i <= length(left) && j <= length(right)) {
        if (left[i] <= right[j]) {
            result <- c(result, left[i])
            i <- i + 1
        } else {
            result <- c(result, right[j])
            j <- j + 1
        }
    }
    while (i <= length(left)) {
        result <- c(result, left[i])
        i <- i + 1
    }
    while (j <= length(right)) {
        result <- c(result, right[j])
        j <- j + 1
    }
    return(result)
}

arr <- c(5, 3, 8, 4, 2, 7, 1, 6)
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Merge sort:", paste(merge_sort(arr), collapse = ", ")))

# Bubble sort
bubble_sort <- function(arr) {
    n <- length(arr)
    for (i in 1:(n - 1)) {
        for (j in 1:(n - i)) {
            if (arr[j] > arr[j + 1]) {
                temp <- arr[j]
                arr[j] <- arr[j + 1]
                arr[j + 1] <- temp
            }
        }
    }
    return(arr)
}

bubble_sort_optimized <- function(arr) {
    n <- length(arr)
    for (i in 1:(n - 1)) {
        swapped <- FALSE
        for (j in 1:(n - i)) {
            if (arr[j] > arr[j + 1]) {
                temp <- arr[j]
                arr[j] <- arr[j + 1]
                arr[j + 1] <- temp
                swapped <- TRUE
            }
        }
        if (!swapped) {
            break
        }
    }
    return(arr)
}

arr <- c(5, 3, 8, 4, 2, 7, 1, 6)
print(paste("Original:", paste(arr, collapse = ", ")))
print(paste("Bubble sort:", paste(bubble_sort(arr), collapse = ", ")))
print(paste("Bubble sort optimized:", paste(bubble_sort_optimized(arr), collapse = ", ")))

# Intersection of vectors
intersection <- function(arr1, arr2) {
    return(arr1[arr1 %in% arr2])
}

intersection_manual <- function(arr1, arr2) {
    result <- c()
    for (val in arr1) {
        if (val %in% arr2 && !(val %in% result)) {
            result <- c(result, val)
        }
    }
    return(result)
}

arr1 <- c("apple", "banana", "orange", "grape", "kiwi")
arr2 <- c("banana", "kiwi", "mango", "grape")
print(paste("Intersection:", paste(intersection(arr1, arr2), collapse = ", ")))
print(paste("Intersection (manual):", paste(intersection_manual(arr1, arr2), collapse = ", ")))

ints1 <- c(1, 2, 3, 4, 5)
ints2 <- c(4, 5, 6, 7, 8)
print(paste("Intersection (ints):", paste(intersection(ints1, ints2), collapse = ", ")))

# Union of vectors
union_vectors <- function(arr1, arr2) {
    return(unique(c(arr1, arr2)))
}

union_manual <- function(arr1, arr2) {
    result <- arr1
    for (val in arr2) {
        if (!(val %in% result)) {
            result <- c(result, val)
        }
    }
    return(result)
}

arr1 <- c("apple", "banana", "orange")
arr2 <- c("orange", "grape", "kiwi")
print(paste("Union:", paste(union_vectors(arr1, arr2), collapse = ", ")))
print(paste("Union (manual):", paste(union_manual(arr1, arr2), collapse = ", ")))

ints1 <- c(1, 2, 3, 4)
ints2 <- c(4, 5, 6, 7)
print(paste("Union (ints):", paste(union_vectors(ints1, ints2), collapse = ", ")))

# Difference of vectors
difference <- function(arr1, arr2) {
    return(arr1[!(arr1 %in% arr2)])
}

difference_manual <- function(arr1, arr2) {
    result <- c()
    for (val in arr1) {
        if (!(val %in% arr2)) {
            result <- c(result, val)
        }
    }
    return(result)
}

symmetric_difference <- function(arr1, arr2) {
    return(c(difference(arr1, arr2), difference(arr2, arr1)))
}

arr1 <- c("apple", "banana", "orange", "grape")
arr2 <- c("banana", "kiwi", "grape")
print(paste("Difference:", paste(difference(arr1, arr2), collapse = ", ")))
print(paste("Symmetric difference:", paste(symmetric_difference(arr1, arr2), collapse = ", ")))

ints1 <- c(1, 2, 3, 4, 5)
ints2 <- c(4, 5, 6, 7, 8)
print(paste("Difference (ints):", paste(difference(ints1, ints2), collapse = ", ")))

# Group by property
group_by <- function(df, key) {
    groups <- list()
    for (i in 1:nrow(df)) {
        key_val <- df[i, key]
        if (!(key_val %in% names(groups))) {
            groups[[as.character(key_val)]] <- data.frame()
        }
        groups[[as.character(key_val)]] <- rbind(groups[[as.character(key_val)]], df[i, ])
    }
    return(groups)
}

group_by_dplyr <- function(df, key) {
    library(dplyr)
    return(df %>% group_by(!!sym(key)) %>% summarise(count = n()))
}

# Example data
people <- data.frame(
    name = c("Alice", "Bob", "Charlie", "David", "Eve"),
    age = c(25, 30, 25, 35, 30),
    city = c("NYC", "LA", "NYC", "Chicago", "LA"),
    stringsAsFactors = FALSE
)

print("Group by age:")
by_age <- group_by(people, "age")
for (age in names(by_age)) {
    names <- by_age[[age]]$name
    print(paste("Age", age, ":", paste(names, collapse = ", ")))
}

print("Group by city:")
by_city <- group_by(people, "city")
for (city in names(by_city)) {
    names <- by_city[[city]]$name
    print(paste("City", city, ":", paste(names, collapse = ", ")))
}

# Deep clone object
deep_clone <- function(obj) {
    if (is.list(obj)) {
        result <- list()
        for (name in names(obj)) {
            result[[name]] <- deep_clone(obj[[name]])
        }
        return(result)
    } else {
        return(obj)
    }
}

# Example
address <- list(street = "123 Main St", city = "NYC")
person <- list(name = "Alice", address = address)
cloned <- deep_clone(person)

cloned$address$street <- "456 Oak St"
print(paste("Original:", person$address$street))
print(paste("Cloned:", cloned$address$street))

# Immutable update
update_immutable <- function(obj, path, value) {
    parts <- strsplit(path, "\.")[[1]]
    if (length(parts) == 1) {
        result <- obj
        result[[parts[1]]] <- value
        return(result)
    }
    
    first <- parts[1]
    rest <- paste(parts[-1], collapse = ".")
    result <- obj
    if (first %in% names(result)) {
        result[[first]] <- update_immutable(result[[first]], rest, value)
    } else {
        result[[first]] <- update_immutable(list(), rest, value)
    }
    return(result)
}

state <- list(user = list(name = "Alice", age = 25))
new_state <- update_immutable(state, "user.age", 26)

print(paste("Original:", state$user$age))
print(paste("Updated:", new_state$user$age))

# Pipe function
pipe <- function(value, ...) {
    fns <- list(...)
    result <- value
    for (fn in fns) {
        result <- fn(result)
    }
    return(result)
}

# Using magrittr
# library(magrittr)
# result <- 5 %>% double %>% add_ten %>% square

# Using native pipe (R 4.1+)
double <- function(x) x * 2
add_ten <- function(x) x + 10
square <- function(x) x^2

result <- pipe(5, double, add_ten, square)
print(paste("Pipe:", result))

# Native pipe (R 4.1+)
result2 <- 5 |> double() |> add_ten() |> square()
print(paste("Native pipe:", result2))

# Compose function
compose <- function(...) {
    fns <- list(...)
    function(x) {
        result <- x
        for (fn in rev(fns)) {
            result <- fn(result)
        }
        return(result)
    }
}

double <- function(x) x * 2
add_ten <- function(x) x + 10
square <- function(x) x^2

composed <- compose(double, add_ten, square)
result <- composed(5)
print(paste("Composed:", result))

# Alternative compose
compose2 <- function(f, g) {
    function(x) f(g(x))
}

composed2 <- compose2(square, compose2(add_ten, double))
result2 <- composed2(5)
print(paste("Composed2:", result2))

# Memoization
memoize <- function(fn) {
    cache <- list()
    function(x) {
        if (is.null(cache[[as.character(x)]])) {
            cache[[as.character(x)]] <<- fn(x)
        }
        return(cache[[as.character(x)]])
    }
}

# Using memoise package
# library(memoise)
# memo_fib <- memoise(function(n) {
#     if (n <= 1) return(n)
#     return(memo_fib(n-1) + memo_fib(n-2))
# })

# Example: Fibonacci with memoization
fib <- memoize(function(n) {
    if (n <= 1) return(n)
    return(fib(n-1) + fib(n-2))
})

start <- Sys.time()
print(paste("Fibonacci(35):", fib(35)))
time1 <- Sys.time() - start
print(paste("Time:", time1))

start2 <- Sys.time()
print(paste("Fibonacci(35) again:", fib(35)))
time2 <- Sys.time() - start2
print(paste("Time:", time2))

# Once function
once <- function(fn) {
    called <- FALSE
    result <- NULL
    function(...) {
        if (!called) {
            called <<- TRUE
            result <<- fn(...)
        }
        return(result)
    }
}

once_with_reset <- function(fn) {
    called <- FALSE
    result <- NULL
    reset <- function() {
        called <<- FALSE
        result <<- NULL
    }
    
    fn_once <- function(...) {
        if (!called) {
            called <<- TRUE
            result <<- fn(...)
        }
        return(result)
    }
    
    return(list(fn = fn_once, reset = reset))
}

initialize <- once(function(value) {
    print(paste("Initialized with", value))
    return(value * 2)
})

print(paste("First call:", initialize(10)))
print(paste("Second call:", initialize(20)))

init <- once_with_reset(function(value) {
    print(paste("Initialized with", value))
    return(value * 2)
})

print(paste("First with reset:", init$fn(10)))
init$reset()
print(paste("After reset:", init$fn(20)))

# Debounce with leading edge
debounce_leading <- function(fn, delay) {
    last_call <- 0
    timeout <- NULL
    function(...) {
        now <- Sys.time()
        if (as.numeric(difftime(now, last_call, units = "secs")) >= delay) {
            last_call <<- now
            return(fn(...))
        }
        
        if (is.null(timeout)) {
            timeout <<- list(
                start = now,
                args = list(...)
            )
            later::later(function() {
                last_call <<- Sys.time()
                fn(...)
                timeout <<- NULL
            }, delay - as.numeric(difftime(now, last_call, units = "secs")))
        }
    }
}

debounce_simple <- function(fn, delay) {
    last_call <- 0
    function(...) {
        now <- Sys.time()
        if (as.numeric(difftime(now, last_call, units = "secs")) >= delay) {
            last_call <<- now
            return(fn(...))
        }
        return(NULL)
    }
}

# Usage
debounced <- debounce_simple(function(value) {
    print(paste("Processing:", value))
}, 2)

print(debounced(1))
print(debounced(2))
Sys.sleep(3)
print(debounced(3))

# Throttle with leading edge
throttle_leading <- function(fn, delay) {
    last_call <- 0
    function(...) {
        now <- Sys.time()
        if (as.numeric(difftime(now, last_call, units = "secs")) >= delay) {
            last_call <<- now
            return(fn(...))
        }
        return(NULL)
    }
}

throttle_leading_with_skipped <- function(fn, delay) {
    last_call <- 0
    skipped <- 0
    function(...) {
        now <- Sys.time()
        if (as.numeric(difftime(now, last_call, units = "secs")) >= delay) {
            if (skipped > 0) {
                print(paste("Skipped", skipped, "calls"))
                skipped <<- 0
            }
            last_call <<- now
            return(fn(...))
        }
        skipped <<- skipped + 1
        return(NULL)
    }
}

throttle_with_trailing <- function(fn, delay) {
    last_call <- 0
    pending <- NULL
    timer <- NULL
    
    function(...) {
        now <- Sys.time()
        if (as.numeric(difftime(now, last_call, units = "secs")) >= delay) {
            last_call <<- now
            return(fn(...))
        }
        
        pending <<- list(...)
        if (is.null(timer)) {
            remaining <- delay - as.numeric(difftime(now, last_call, units = "secs"))
            timer <<- later::later(function() {
                last_call <<- Sys.time()
                if (!is.null(pending)) {
                    fn(...)
                    pending <<- NULL
                }
                timer <<- NULL
            }, remaining)
        }
    }
}

# Usage
throttled <- throttle_leading(function(value) {
    print(paste("Processing:", value))
}, 2)

print(throttled(1))
print(throttled(2))
Sys.sleep(3)
print(throttled(3))

# Deep equal
deep_equal <- function(obj1, obj2) {
    if (identical(obj1, obj2)) {
        return(TRUE)
    }
    
    if (class(obj1) != class(obj2)) {
        return(FALSE)
    }
    
    if (is.list(obj1) && is.list(obj2)) {
        if (length(obj1) != length(obj2)) {
            return(FALSE)
        }
        for (name in names(obj1)) {
            if (!(name %in% names(obj2))) {
                return(FALSE)
            }
            if (!deep_equal(obj1[[name]], obj2[[name]])) {
                return(FALSE)
            }
        }
        return(TRUE)
    }
    
    if (is.data.frame(obj1) && is.data.frame(obj2)) {
        if (nrow(obj1) != nrow(obj2) || ncol(obj1) != ncol(obj2)) {
            return(FALSE)
        }
        for (col in names(obj1)) {
            if (!deep_equal(obj1[[col]], obj2[[col]])) {
                return(FALSE)
            }
        }
        return(TRUE)
    }
    
    return(FALSE)
}

obj1 <- list(a = 1, b = list(c = 2))
obj2 <- list(a = 1, b = list(c = 2))
obj3 <- list(a = 1, b = list(c = 3))

print(paste("obj1 == obj2:", deep_equal(obj1, obj2)))
print(paste("obj1 == obj3:", deep_equal(obj1, obj3)))

# Observable pattern
Observable <- R6::R6Class("Observable",
    public = list(
        subscribers = list(),
        
        subscribe = function(callback) {
            id <- length(self$subscribers) + 1
            self$subscribers[[as.character(id)]] <- callback
            return(id)
        },
        
        unsubscribe = function(id) {
            self$subscribers[[as.character(id)]] <- NULL
        },
        
        notify = function(data) {
            for (callback in self$subscribers) {
                callback(data)
            }
        },
        
        clear = function() {
            self$subscribers <- list()
        }
    )
)

StatefulObservable <- R6::R6Class("StatefulObservable",
    inherit = Observable,
    public = list(
        state = NULL,
        
        initialize = function(initial_state) {
            self$state <- initial_state
        },
        
        set_state = function(new_state) {
            self$state <- new_state
            self$notify(new_state)
        },
        
        get_state = function() {
            return(self$state)
        }
    )
)

# Usage
observable <- Observable$new()
id1 <- observable$subscribe(function(data) {
    print(paste("Observer1:", data))
})
id2 <- observable$subscribe(function(data) {
    print(paste("Observer2:", data))
})

print("Notifying observers:")
observable$notify("Hello, World!")

observable$unsubscribe(id1)
print("After unsubscribing observer1:")
observable$notify("Hello again!")

stateful <- StatefulObservable$new(0)
stateful$subscribe(function(state) {
    print(paste("State changed to:", state))
})
print(paste("Current state:", stateful$get_state()))
stateful$set_state(10)
stateful$set_state(20)

# Singleton pattern
Singleton <- R6::R6Class("Singleton",
    private = list(
        .data = list()
    ),
    public = list(
        set = function(key, value) {
            private$.data[[key]] <- value
        },
        
        get = function(key) {
            return(private$.data[[key]])
        }
    )
)

# Singleton factory
singleton_factory <- function() {
    instance <- NULL
    function() {
        if (is.null(instance)) {
            instance <<- Singleton$new()
        }
        return(instance)
    }
}

# Usage
get_singleton <- singleton_factory()
singleton1 <- get_singleton()
singleton2 <- get_singleton()

print(paste("singleton1 == singleton2:", identical(singleton1, singleton2)))

singleton1$set("key", "value")
print(paste("singleton2 get:", singleton2$get("key")))

# Alternative using environment
SingletonEnv <- new.env()
SingletonEnv$instance <- NULL

get_singleton_env <- function() {
    if (is.null(SingletonEnv$instance)) {
        SingletonEnv$instance <- Singleton$new()
    }
    return(SingletonEnv$instance)
}

singleton3 <- get_singleton_env()
singleton4 <- get_singleton_env()
print(paste("singleton3 == singleton4:", identical(singleton3, singleton4)))

# Factory pattern
# Factory function
create_user <- function(type, name) {
    if (type == "admin") {
        return(list(name = name, type = "admin"))
    } else if (type == "guest") {
        return(list(name = name, type = "guest"))
    } else {
        return(list(name = name, type = "regular"))
    }
}

# Using S3 classes
User <- function(name, type) {
    obj <- list(name = name, type = type)
    class(obj) <- c(type, "User")
    return(obj)
}

Admin <- function(name) {
    obj <- User(name, "admin")
    return(obj)
}

Guest <- function(name) {
    obj <- User(name, "guest")
    return(obj)
}

RegularUser <- function(name) {
    obj <- User(name, "regular")
    return(obj)
}

# Factory class
UserFactory <- R6::R6Class("UserFactory",
    public = list(
        create = function(type, name) {
            if (type == "admin") {
                return(Admin(name))
            } else if (type == "guest") {
                return(Guest(name))
            } else {
                return(RegularUser(name))
            }
        },
        
        create_admin = function(name) {
            return(Admin(name))
        },
        
        create_guest = function(name) {
            return(Guest(name))
        },
        
        create_regular = function(name) {
            return(RegularUser(name))
        }
    )
)

# Usage
factory <- UserFactory$new()
user1 <- factory$create("admin", "Alice")
user2 <- factory$create("guest", "Bob")
user3 <- factory$create("regular", "Charlie")

print(paste(user1$name, "is", user1$type))
print(paste(user2$name, "is", user2$type))
print(paste(user3$name, "is", user3$type))

# Strategy pattern
# Payment strategies
credit_card_strategy <- function(amount) {
    print(paste("Paid", amount, "with Credit Card"))
}

paypal_strategy <- function(amount) {
    print(paste("Paid", amount, "with PayPal"))
}

crypto_strategy <- function(amount) {
    print(paste("Paid", amount, "with Crypto"))
}

# Strategy context
PaymentContext <- R6::R6Class("PaymentContext",
    public = list(
        strategy = NULL,
        
        initialize = function(strategy) {
            self$strategy <- strategy
        },
        
        set_strategy = function(strategy) {
            self$strategy <- strategy
        },
        
        execute_payment = function(amount) {
            self$strategy(amount)
        }
    )
)

# With discount decorator
discount_decorator <- function(strategy, discount) {
    function(amount) {
        discounted <- amount * (1 - discount)
        print(paste("Applied discount of", discount * 100, "%"))
        strategy(discounted)
    }
}

# Usage
context <- PaymentContext$new(credit_card_strategy)
context$execute_payment(100.0)
context$set_strategy(paypal_strategy)
context$execute_payment(50.0)
context$set_strategy(crypto_strategy)
context$execute_payment(75.0)

discounted <- discount_decorator(paypal_strategy, 0.1)
discounted(100.0)

# Observer pattern
Observer <- R6::R6Class("Observer",
    public = list(
        name = NULL,
        
        initialize = function(name) {
            self$name <- name
        },
        
        update = function(data) {
            print(paste("Observer", self$name, "received:", data))
        }
    )
)

Subject <- R6::R6Class("Subject",
    public = list(
        observers = list(),
        
        attach = function(observer) {
            id <- length(self$observers) + 1
            self$observers[[as.character(id)]] <- observer
            return(id)
        },
        
        detach = function(observer) {
            ids <- names(self$observers)
            for (id in ids) {
                if (identical(self$observers[[id]], observer)) {
                    self$observers[[id]] <- NULL
                    break
                }
            }
        },
        
        notify = function(data) {
            for (observer in self$observers) {
                observer$update(data)
            }
        }
    )
)

ConcreteSubject <- R6::R6Class("ConcreteSubject",
    inherit = Subject,
    public = list(
        state = NULL,
        
        set_state = function(state) {
            self$state <- state
            self$notify(state)
        },
        
        get_state = function() {
            return(self$state)
        }
    )
)

DerivedObserver <- R6::R6Class("DerivedObserver",
    inherit = Observer,
    public = list(
        transform = NULL,
        
        initialize = function(name, transform) {
            super$initialize(name)
            self$transform <- transform
        },
        
        update = function(data) {
            transformed <- self$transform(data)
            print(paste("Derived observer", self$name, ":", transformed))
        }
    )
)

# Usage
subject <- ConcreteSubject$new()
observer1 <- Observer$new("1")
observer2 <- Observer$new("2")
observer3 <- DerivedObserver$new("3", function(x) toupper(x))

subject$attach(observer1)
subject$attach(observer2)
subject$attach(observer3)

print("Setting state:")
subject$set_state("Hello, World!")
subject$set_state("Another update")

subject$detach(observer1)
print("After detaching observer1:")
subject$set_state("Final state")

# Decorator pattern
Coffee <- R6::R6Class("Coffee",
    public = list(
        get_cost = function() {
            return(0.0)
        },
        get_description = function() {
            return("")
        }
    )
)

BasicCoffee <- R6::R6Class("BasicCoffee",
    inherit = Coffee,
    public = list(
        get_cost = function() {
            return(5.0)
        },
        get_description = function() {
            return("Coffee")
        }
    )
)

CoffeeDecorator <- R6::R6Class("CoffeeDecorator",
    inherit = Coffee,
    public = list(
        coffee = NULL,
        
        initialize = function(coffee) {
            self$coffee <- coffee
        },
        
        get_cost = function() {
            return(self$coffee$get_cost())
        },
        
        get_description = function() {
            return(self$coffee$get_description())
        }
    )
)

MilkDecorator <- R6::R6Class("MilkDecorator",
    inherit = CoffeeDecorator,
    public = list(
        initialize = function(coffee) {
            super$initialize(coffee)
        },
        
        get_cost = function() {
            return(self$coffee$get_cost() + 2.0)
        },
        
        get_description = function() {
            return(paste(self$coffee$get_description(), ", Milk"))
        }
    )
)

SugarDecorator <- R6::R6Class("SugarDecorator",
    inherit = CoffeeDecorator,
    public = list(
        initialize = function(coffee) {
            super$initialize(coffee)
        },
        
        get_cost = function() {
            return(self$coffee$get_cost() + 1.0)
        },
        
        get_description = function() {
            return(paste(self$coffee$get_description(), ", Sugar"))
        }
    )
)

CaramelDecorator <- R6::R6Class("CaramelDecorator",
    inherit = CoffeeDecorator,
    public = list(
        initialize = function(coffee) {
            super$initialize(coffee)
        },
        
        get_cost = function() {
            return(self$coffee$get_cost() + 2.5)
        },
        
        get_description = function() {
            return(paste(self$coffee$get_description(), ", Caramel"))
        }
    )
)

WhippedCreamDecorator <- R6::R6Class("WhippedCreamDecorator",
    inherit = CoffeeDecorator,
    public = list(
        initialize = function(coffee) {
            super$initialize(coffee)
        },
        
        get_cost = function() {
            return(self$coffee$get_cost() + 1.5)
        },
        
        get_description = function() {
            return(paste(self$coffee$get_description(), ", Whipped Cream"))
        }
    )
)

# Usage
coffee <- BasicCoffee$new()
print(paste(coffee$get_description(), "($", coffee$get_cost(), ")"))

with_milk <- MilkDecorator$new(coffee)
print(paste(with_milk$get_description(), "($", with_milk$get_cost(), ")"))

with_sugar <- SugarDecorator$new(coffee)
print(paste(with_sugar$get_description(), "($", with_sugar$get_cost(), ")"))

with_milk_sugar <- SugarDecorator$new(MilkDecorator$new(coffee))
print(paste(with_milk_sugar$get_description(), "($", with_milk_sugar$get_cost(), ")"))

fully_decorated <- CaramelDecorator$new(
    WhippedCreamDecorator$new(
        SugarDecorator$new(
            MilkDecorator$new(coffee)
        )
    )
)
print(paste(fully_decorated$get_description(), "($", fully_decorated$get_cost(), ")"))

# Command pattern
Command <- R6::R6Class("Command",
    public = list(
        execute = function() {},
        undo = function() {},
        redo = function() {}
    )
)

AddCommand <- R6::R6Class("AddCommand",
    inherit = Command,
    public = list(
        receiver = NULL,
        value = NULL,
        
        initialize = function(receiver, value) {
            self$receiver <- receiver
            self$value <- value
        },
        
        execute = function() {
            self$receiver$value <- self$receiver$value + self$value
        },
        
        undo = function() {
            self$receiver$value <- self$receiver$value - self$value
        },
        
        redo = function() {
            self$execute()
        }
    )
)

SubtractCommand <- R6::R6Class("SubtractCommand",
    inherit = Command,
    public = list(
        receiver = NULL,
        value = NULL,
        
        initialize = function(receiver, value) {
            self$receiver <- receiver
            self$value <- value
        },
        
        execute = function() {
            self$receiver$value <- self$receiver$value - self$value
        },
        
        undo = function() {
            self$receiver$value <- self$receiver$value + self$value
        },
        
        redo = function() {
            self$execute()
        }
    )
)

MacroCommand <- R6::R6Class("MacroCommand",
    inherit = Command,
    public = list(
        commands = NULL,
        
        initialize = function(commands) {
            self$commands <- commands
        },
        
        execute = function() {
            for (cmd in self$commands) {
                cmd$execute()
            }
        },
        
        undo = function() {
            for (cmd in rev(self$commands)) {
                cmd$undo()
            }
        },
        
        redo = function() {
            self$execute()
        }
    )
)

CommandHistory <- R6::R6Class("CommandHistory",
    public = list(
        history = list(),
        current = 0,
        
        execute = function(command) {
            command$execute()
            self$history <- self$history[1:self$current]
            self$history <- c(self$history, command)
            self$current <- self$current + 1
        },
        
        undo = function() {
            if (self$current > 0) {
                self$current <- self$current - 1
                self$history[[self$current + 1]]$undo()
                return(TRUE)
            }
            return(FALSE)
        },
        
        redo = function() {
            if (self$current < length(self$history)) {
                self$history[[self$current + 1]]$redo()
                self$current <- self$current + 1
                return(TRUE)
            }
            return(FALSE)
        }
    )
)

# Usage
counter <- list(value = 0)
history <- CommandHistory$new()

add5 <- AddCommand$new(counter, 5)
sub3 <- SubtractCommand$new(counter, 3)

print(paste("Initial:", counter$value))
history$execute(add5)
print(paste("After add:", counter$value))
history$execute(sub3)
print(paste("After sub:", counter$value))
history$undo()
print(paste("After undo:", counter$value))
history$redo()
print(paste("After redo:", counter$value))

macro <- MacroCommand$new(list(add5, add5, sub3))
history$execute(macro)
print(paste("After macro:", counter$value))

# Memento pattern
Memento <- R6::R6Class("Memento",
    public = list(
        state = NULL,
        
        initialize = function(state) {
            self$state <- state
        },
        
        get_state = function() {
            return(self$state)
        }
    )
)

Originator <- R6::R6Class("Originator",
    public = list(
        state = NULL,
        
        initialize = function(state) {
            self$state <- state
        },
        
        save = function() {
            return(Memento$new(self$state))
        },
        
        restore = function(memento) {
            self$state <- memento$get_state()
        },
        
        set_state = function(state) {
            self$state <- state
        },
        
        get_state = function() {
            return(self$state)
        }
    )
)

Caretaker <- R6::R6Class("Caretaker",
    public = list(
        mementos = list(),
        current = 0,
        
        save = function(memento) {
            self$mementos <- self$mementos[1:self$current]
            self$mementos <- c(self$mementos, memento)
            self$current <- self$current + 1
        },
        
        undo = function() {
            if (self$current > 0) {
                self$current <- self$current - 1
                return(self$mementos[[self$current + 1]])
            }
            return(NULL)
        },
        
        redo = function() {
            if (self$current < length(self$mementos)) {
                memento <- self$mementos[[self$current + 1]]
                self$current <- self$current + 1
                return(memento)
            }
            return(NULL)
        }
    )
)

# Usage
originator <- Originator$new(list(value = 0))
caretaker <- Caretaker$new()

caretaker$save(originator$save())
originator$set_state(list(value = 1))
caretaker$save(originator$save())
originator$set_state(list(value = 2))
caretaker$save(originator$save())
originator$set_state(list(value = 3))

print(paste("Current:", originator$get_state()$value))

memento <- caretaker$undo()
if (!is.null(memento)) {
    originator$restore(memento)
    print(paste("After undo:", originator$get_state()$value))
}

memento <- caretaker$redo()
if (!is.null(memento)) {
    originator$restore(memento)
    print(paste("After redo:", originator$get_state()$value))
}

# Mediator pattern
Mediator <- R6::R6Class("Mediator",
    public = list(
        colleagues = list(),
        
        register = function(colleague) {
            self$colleagues <- c(self$colleagues, colleague)
            colleague$set_mediator(self)
        },
        
        send = function(message, sender) {
            for (colleague in self$colleagues) {
                if (!identical(colleague, sender)) {
                    colleague$receive(message)
                }
            }
        }
    )
)

Colleague <- R6::R6Class("Colleague",
    public = list(
        name = NULL,
        mediator = NULL,
        
        initialize = function(name) {
            self$name <- name
        },
        
        set_mediator = function(mediator) {
            self$mediator <- mediator
        },
        
        send = function(message) {
            self$mediator$send(message, self)
        },
        
        receive = function(message) {
            print(paste(self$name, "received:", message))
        }
    )
)

StatefulColleague <- R6::R6Class("StatefulColleague",
    inherit = Colleague,
    public = list(
        state = NULL,
        
        initialize = function(name, state) {
            super$initialize(name)
            self$state <- state
        },
        
        receive = function(message) {
            print(paste(self$name, "(state", self$state, ") received:", message))
        },
        
        set_state = function(state) {
            self$state <- state
        }
    )
)

# Usage
mediator <- Mediator$new()
alice <- Colleague$new("Alice")
bob <- Colleague$new("Bob")
charlie <- Colleague$new("Charlie")

mediator$register(alice)
mediator$register(bob)
mediator$register(charlie)

print("Sending messages:")
alice$send("Hello everyone!")
bob$send("Meeting at 3pm")

mediator2 <- Mediator$new()
alice2 <- StatefulColleague$new("Alice", 0)
bob2 <- StatefulColleague$new("Bob", 1)

mediator2$register(alice2)
mediator2$register(bob2)
alice2$send("Custom message for stateful colleagues")

# Chain of Responsibility
Handler <- R6::R6Class("Handler",
    public = list(
        next_handler = NULL,
        
        set_next = function(handler) {
            self$next_handler <- handler
            return(handler)
        },
        
        handle = function(request) {
            if (!is.null(self$next_handler)) {
                return(self$next_handler$handle(request))
            }
            return(TRUE)
        }
    )
)

AuthHandler <- R6::R6Class("AuthHandler",
    inherit = Handler,
    public = list(
        handle = function(request) {
            if (!is.null(request$token)) {
                print("Authentication passed")
                return(super$handle(request))
            }
            print("Authentication failed")
            return(FALSE)
        }
    )
)

LoggerHandler <- R6::R6Class("LoggerHandler",
    inherit = Handler,
    public = list(
        handle = function(request) {
            url <- request$url %||% "unknown"
            print(paste("Logging request:", url))
            return(super$handle(request))
        }
    )
)

ValidationHandler <- R6::R6Class("ValidationHandler",
    inherit = Handler,
    public = list(
        handle = function(request) {
            if (!is.null(request$data)) {
                print("Validation passed")
                return(super$handle(request))
            }
            print("Validation failed")
            return(FALSE)
        }
    )
)

RateLimitHandler <- R6::R6Class("RateLimitHandler",
    inherit = Handler,
    public = list(
        last_call = 0,
        limit = 5,
        
        handle = function(request) {
            now <- Sys.time()
            if (as.numeric(difftime(now, self$last_call, units = "secs")) >= self$limit) {
                self$last_call <- now
                print("Rate limit passed")
                return(super$handle(request))
            }
            print("Rate limit exceeded")
            return(FALSE)
        }
    )
)

# Usage
auth <- AuthHandler$new()
logger <- LoggerHandler$new()
validator <- ValidationHandler$new()
rate_limiter <- RateLimitHandler$new()

auth$set_next(logger)$set_next(validator)$set_next(rate_limiter)

request <- list(token = "valid", url = "/api", data = "payload")
print("Processing valid request:")
auth$handle(request)

request2 <- list(url = "/public")
print("Processing invalid request:")
auth$handle(request2)

# State pattern
State <- R6::R6Class("State",
    public = list(
        handle = function(context) {}
    )
)

ReadyState <- R6::R6Class("ReadyState",
    inherit = State,
    public = list(
        handle = function(context) {
            print("Ready: Waiting for input")
            context$set_state(ProcessingState$new())
        }
    )
)

ProcessingState <- R6::R6Class("ProcessingState",
    inherit = State,
    public = list(
        handle = function(context) {
            print("Processing: Working on task")
            context$set_state(CompletedState$new())
        }
    )
)

CompletedState <- R6::R6Class("CompletedState",
    inherit = State,
    public = list(
        handle = function(context) {
            print("Completed: Task finished")
            context$set_state(ReadyState$new())
        }
    )
)

ErrorState <- R6::R6Class("ErrorState",
    inherit = State,
    public = list(
        handle = function(context) {
            print("Error: Something went wrong")
            context$set_state(ReadyState$new())
        }
    )
)

Context <- R6::R6Class("Context",
    public = list(
        state = NULL,
        data = list(),
        
        initialize = function(state) {
            self$state <- state
        },
        
        set_state = function(state) {
            self$state <- state
        },
        
        request = function() {
            self$state$handle(self)
        },
        
        set_data = function(key, value) {
            self$data[[key]] <- value
        },
        
        get_data = function(key) {
            return(self$data[[key]])
        }
    )
)

StatefulContext <- R6::R6Class("StatefulContext",
    inherit = Context,
    public = list(
        request = function() {
            self$state$handle(self)
            self$set_data("last_state", class(self$state)[1])
        }
    )
)

# Usage
context <- Context$new(ReadyState$new())
for (i in 1:5) {
    print(paste("Step", i + 1, ":"))
    context$request()
}

print("With data:")
context2 <- StatefulContext$new(ReadyState$new())
for (i in 1:5) {
    context2$set_data("step", i + 1)
    context2$request()
    print(paste("Data:", context2$get_data("last_state")))
}

# Proxy pattern
RealSubject <- R6::R6Class("RealSubject",
    public = list(
        request = function() {
            return("RealSubject: Handling request")
        }
    )
)

Proxy <- R6::R6Class("Proxy",
    public = list(
        real_subject = NULL,
        
        request = function() {
            if (is.null(self$real_subject)) {
                print("Proxy: Creating real subject")
                self$real_subject <- RealSubject$new()
            }
            print("Proxy: Using cached real subject")
            return(self$real_subject$request())
        }
    )
)

LoggingProxy <- R6::R6Class("LoggingProxy",
    public = list(
        subject = NULL,
        
        initialize = function(subject) {
            self$subject <- subject
        },
        
        request = function() {
            print("Logging: Request started")
            result <- self$subject$request()
            print("Logging: Request completed")
            return(result)
        }
    )
)

AuthProxy <- R6::R6Class("AuthProxy",
    public = list(
        subject = NULL,
        user = NULL,
        
        initialize = function(subject, user) {
            self$subject <- subject
            self$user <- user
        },
        
        request = function() {
            if (self$authenticate()) {
                print("Auth: Access granted")
                return(self$subject$request())
            }
            print("Auth: Access denied")
            return("Unauthorized")
        },
        
        authenticate = function() {
            return(self$user == "admin")
        }
    )
)

# Usage
proxy <- Proxy$new()
print(proxy$request())
print(proxy$request())

real <- RealSubject$new()
logging_proxy <- LoggingProxy$new(real)
print(logging_proxy$request())

auth_proxy <- AuthProxy$new(real, "admin")
print(auth_proxy$request())

auth_proxy2 <- AuthProxy$new(real, "guest")
print(auth_proxy2$request())

# Flyweight pattern
Flyweight <- R6::R6Class("Flyweight",
    public = list(
        shared_state = NULL,
        
        initialize = function(shared_state) {
            self$shared_state <- shared_state
        },
        
        operation = function(unique_state) {
            return(paste("Shared:", self$shared_state, ", Unique:", unique_state))
        }
    )
)

FlyweightFactory <- R6::R6Class("FlyweightFactory",
    public = list(
        flyweights = list(),
        
        get_flyweight = function(shared_state) {
            if (is.null(self$flyweights[[shared_state]])) {
                self$flyweights[[shared_state]] <- Flyweight$new(shared_state)
            }
            return(self$flyweights[[shared_state]])
        },
        
        get_count = function() {
            return(length(self$flyweights))
        }
    )
)

# Usage
factory <- FlyweightFactory$new()
fw1 <- factory$get_flyweight("state1")
fw2 <- factory$get_flyweight("state1")
fw3 <- factory$get_flyweight("state2")

print(paste("fw1 and fw2 are same:", identical(fw1, fw2)))
print(paste("fw1 and fw3 are same:", identical(fw1, fw3)))

print(fw1$operation("unique1"))
print(fw2$operation("unique2"))
print(fw3$operation("unique3"))

print(paste("Number of flyweights:", factory$get_count()))

# Bridge pattern
Implementation <- R6::R6Class("Implementation",
    public = list(
        operation = function() {
            return("")
        }
    )
)

ConcreteImplementationA <- R6::R6Class("ConcreteImplementationA",
    inherit = Implementation,
    public = list(
        operation = function() {
            return("ConcreteImplementationA: Operation")
        }
    )
)

ConcreteImplementationB <- R6::R6Class("ConcreteImplementationB",
    inherit = Implementation,
    public = list(
        operation = function() {
            return("ConcreteImplementationB: Operation")
        }
    )
)

Abstraction <- R6::R6Class("Abstraction",
    public = list(
        implementation = NULL,
        
        initialize = function(implementation) {
            self$implementation <- implementation
        },
        
        operation = function() {
            return(self$implementation$operation())
        }
    )
)

ExtendedAbstraction <- R6::R6Class("ExtendedAbstraction",
    inherit = Abstraction,
    public = list(
        operation = function() {
            return(paste("ExtendedAbstraction:", self$implementation$operation()))
        }
    )
)

AlternativeAbstraction <- R6::R6Class("AlternativeAbstraction",
    inherit = Abstraction,
    public = list(
        operation = function() {
            return(paste("AlternativeAbstraction:", self$implementation$operation()))
        }
    )
)

# Usage
implA <- ConcreteImplementationA$new()
implB <- ConcreteImplementationB$new()

abstraction1 <- ExtendedAbstraction$new(implA)
abstraction2 <- ExtendedAbstraction$new(implB)
abstraction3 <- AlternativeAbstraction$new(implA)

print(abstraction1$operation())
print(abstraction2$operation())
print(abstraction3$operation())

# Adapter pattern
Target <- R6::R6Class("Target",
    public = list(
        request = function() {
            return("Target: Request")
        }
    )
)

Adaptee <- R6::R6Class("Adaptee",
    public = list(
        specific_request = function() {
            return("Adaptee: Specific Request")
        }
    )
)

Adapter <- R6::R6Class("Adapter",
    inherit = Target,
    public = list(
        adaptee = NULL,
        
        initialize = function(adaptee) {
            self$adaptee <- adaptee
        },
        
        request = function() {
            return(self$adaptee$specific_request())
        }
    )
)

LoggingAdapter <- R6::R6Class("LoggingAdapter",
    inherit = Adapter,
    public = list(
        request = function() {
            print("Adapter: Logging request")
            return(self$adaptee$specific_request())
        }
    )
)

# Usage
target <- Target$new()
adaptee <- Adaptee$new()
adapter <- Adapter$new(adaptee)

print(target$request())
print(adapter$request())

logging_adapter <- LoggingAdapter$new(adaptee)
print(logging_adapter$request())

# Facade pattern
SubsystemA <- R6::R6Class("SubsystemA",
    public = list(
        operation_a = function() {
            return("SubsystemA: Operation")
        }
    )
)

SubsystemB <- R6::R6Class("SubsystemB",
    public = list(
        operation_b = function() {
            return("SubsystemB: Operation")
        }
    )
)

SubsystemC <- R6::R6Class("SubsystemC",
    public = list(
        operation_c = function() {
            return("SubsystemC: Operation")
        }
    )
)

Facade <- R6::R6Class("Facade",
    public = list(
        subsystem_a = NULL,
        subsystem_b = NULL,
        subsystem_c = NULL,
        
        initialize = function() {
            self$subsystem_a <- SubsystemA$new()
            self$subsystem_b <- SubsystemB$new()
            self$subsystem_c <- SubsystemC$new()
        },
        
        simple_operation = function() {
            return(self$subsystem_a$operation_a())
        },
        
        complex_operation = function() {
            return(paste(
                self$subsystem_a$operation_a(),
                self$subsystem_b$operation_b(),
                self$subsystem_c$operation_c(),
                sep = "
"
            ))
        }
    )
)

# Usage
facade <- Facade$new()
print("Simple operation:")
print(facade$simple_operation())
print("Complex operation:")
print(facade$complex_operation())

# Composite pattern
Component <- R6::R6Class("Component",
    public = list(
        name = NULL,
        
        initialize = function(name) {
            self$name <- name
        },
        
        operation = function() {
            return("")
        },
        
        add = function(component) {
            stop("Cannot add to leaf")
        },
        
        remove = function(component) {
            stop("Cannot remove from leaf")
        },
        
        get_children = function() {
            return(list())
        }
    )
)

Leaf <- R6::R6Class("Leaf",
    inherit = Component,
    public = list(
        operation = function() {
            return(paste("Leaf", self$name, ": Operation"))
        }
    )
)

Composite <- R6::R6Class("Composite",
    inherit = Component,
    public = list(
        children = list(),
        
        operation = function() {
            result <- paste("Composite", self$name, ": Operation
")
            for (child in self$children) {
                result <- paste(result, child$operation(), "
")
            }
            return(result)
        },
        
        add = function(component) {
            self$children <- c(self$children, component)
        },
        
        remove = function(component) {
            self$children <- self$children[!sapply(self$children, function(x) identical(x, component))]
        },
        
        get_children = function() {
            return(self$children)
        },
        
        count_leaves = function() {
            count <- 0
            for (child in self$children) {
                if (inherits(child, "Leaf")) {
                    count <- count + 1
                } else {
                    count <- count + child$count_leaves()
                }
            }
            return(count)
        }
    )
)

# Usage
leaf1 <- Leaf$new("A")
leaf2 <- Leaf$new("B")
leaf3 <- Leaf$new("C")
leaf4 <- Leaf$new("D")

composite1 <- Composite$new("Comp1")
composite1$add(leaf1)
composite1$add(leaf2)

composite2 <- Composite$new("Comp2")
composite2$add(leaf3)
composite2$add(composite1)

root <- Composite$new("Root")
root$add(leaf4)
root$add(composite2)

print(root$operation())
print(paste("Number of leaves:", root$count_leaves()))

# Visitor pattern
Element <- R6::R6Class("Element",
    public = list(
        data = NULL,
        
        initialize = function(data) {
            self$data <- data
        },
        
        accept = function(visitor) {
            return("")
        }
    )
)

ElementA <- R6::R6Class("ElementA",
    inherit = Element,
    public = list(
        accept = function(visitor) {
            return(visitor$visit_a(self))
        }
    )
)

ElementB <- R6::R6Class("ElementB",
    inherit = Element,
    public = list(
        accept = function(visitor) {
            return(visitor$visit_b(self))
        }
    )
)

Visitor <- R6::R6Class("Visitor",
    public = list(
        visit_a = function(element) {
            return("")
        },
        visit_b = function(element) {
            return("")
        }
    )
)

ConcreteVisitor <- R6::R6Class("ConcreteVisitor",
    inherit = Visitor,
    public = list(
        visit_a = function(element) {
            return(paste("Visiting ElementA:", element$data))
        },
        visit_b = function(element) {
            return(paste("Visiting ElementB:", element$data))
        }
    )
)

CountingVisitor <- R6::R6Class("CountingVisitor",
    inherit = Visitor,
    public = list(
        count_a = 0,
        count_b = 0,
        
        visit_a = function(element) {
            self$count_a <- self$count_a + 1
            return(paste("Visiting ElementA (", self$count_a, "):", element$data))
        },
        visit_b = function(element) {
            self$count_b <- self$count_b + 1
            return(paste("Visiting ElementB (", self$count_b, "):", element$data))
        }
    )
)

ExtendedVisitor <- R6::R6Class("ExtendedVisitor",
    inherit = Visitor,
    public = list(
        visit_a = function(element) {
            return(paste("Extended:", element$data, "(A)"))
        },
        visit_b = function(element) {
            return(paste("Extended:", element$data, "(B)"))
        }
    )
)

# Usage
elements <- list(
    ElementA$new("Hello"),
    ElementB$new("World"),
    ElementA$new("R"),
    ElementB$new("Visitor")
)

visitor <- ConcreteVisitor$new()
counting_visitor <- CountingVisitor$new()
extended_visitor <- ExtendedVisitor$new()

print("Using standard visitor:")
for (element in elements) {
    print(element$accept(visitor))
}

print("Using counting visitor:")
for (element in elements) {
    print(element$accept(counting_visitor))
}
print(paste("Counts: A=", counting_visitor$count_a, ", B=", counting_visitor$count_b))

print("Using extended visitor:")
for (element in elements) {
    print(element$accept(extended_visitor))
}

# Iterator pattern
Iterator <- R6::R6Class("Iterator",
    public = list(
        collection = NULL,
        position = 0,
        
        initialize = function(collection) {
            self$collection <- collection
        },
        
        current = function() {
            if (self$position < length(self$collection)) {
                return(self$collection[[self$position + 1]])
            }
            return(NULL)
        },
        
        key = function() {
            return(self$position)
        },
        
        next = function() {
            self$position <- self$position + 1
        },
        
        rewind = function() {
            self$position <- 0
        },
        
        valid = function() {
            return(self$position < length(self$collection))
        }
    )
)

ReverseIterator <- R6::R6Class("ReverseIterator",
    inherit = Iterator,
    public = list(
        initialize = function(collection) {
            super$initialize(collection)
            self$position <- length(collection) - 1
        },
        
        next = function() {
            self$position <- self$position - 1
        },
        
        rewind = function() {
            self$position <- length(self$collection) - 1
        },
        
        valid = function() {
            return(self$position >= 0)
        }
    )
)

FilteredIterator <- R6::R6Class("FilteredIterator",
    inherit = Iterator,
    public = list(
        predicate = NULL,
        
        initialize = function(collection, predicate) {
            filtered <- collection[sapply(collection, predicate)]
            super$initialize(filtered)
            self$predicate <- predicate
        }
    )
)

SkipIterator <- R6::R6Class("SkipIterator",
    inherit = Iterator,
    public = list(
        initialize = function(collection, n) {
            if (n < length(collection)) {
                super$initialize(collection[(n + 1):length(collection)])
            } else {
                super$initialize(list())
            }
        }
    )
)

# Usage
collection <- list("A", "B", "C", "D", "E")
iterator <- Iterator$new(collection)

print("Forward iteration:")
while (iterator$valid()) {
    print(iterator$current())
    iterator$next()
}

reverse_iterator <- ReverseIterator$new(collection)
print("Reverse iteration:")
while (reverse_iterator$valid()) {
    print(reverse_iterator$current())
    reverse_iterator$next()
}

filtered_iterator <- FilteredIterator$new(collection, function(x) nchar(x) <= 1)
print("Filtered iteration:")
while (filtered_iterator$valid()) {
    print(filtered_iterator$current())
    filtered_iterator$next()
}

# Template Method pattern
Template <- R6::R6Class("Template",
    public = list(
        template_method = function() {
            print(self$step1())
            print(self$step2())
            print(self$step3())
        },
        
        step1 = function() {
            return("")
        },
        step2 = function() {
            return("")
        },
        step3 = function() {
            return("")
        }
    )
)

DefaultTemplate <- R6::R6Class("DefaultTemplate",
    inherit = Template,
    public = list(
        step1 = function() { return("Step 1") },
        step2 = function() { return("Step 2") },
        step3 = function() { return("Step 3") }
    )
)

LoggingTemplate <- R6::R6Class("LoggingTemplate",
    inherit = Template,
    public = list(
        inner_template = NULL,
        
        initialize = function(template) {
            self$inner_template <- template
        },
        
        step1 = function() {
            result <- self$inner_template$step1()
            print(paste("Logging:", result))
            return(result)
        },
        step2 = function() {
            result <- self$inner_template$step2()
            print(paste("Logging:", result))
            return(result)
        },
        step3 = function() {
            result <- self$inner_template$step3()
            print(paste("Logging:", result))
            return(result)
        }
    )
)

DataProcessingTemplate <- R6::R6Class("DataProcessingTemplate",
    inherit = Template,
    public = list(
        data = NULL,
        
        initialize = function(data) {
            self$data <- data
        },
        
        step1 = function() {
            return(paste("Processing data:", self$data, "- Step 1"))
        },
        step2 = function() {
            return(paste("Processing data:", self$data, "- Step 2"))
        },
        step3 = function() {
            return(paste("Processing data:", self$data, "- Step 3"))
        }
    )
)

# Usage
print("Using default template:")
default <- DefaultTemplate$new()
default$template_method()

print("Using logging template:")
logging <- LoggingTemplate$new(default)
logging$template_method()

print("Using data processing template:")
data_template <- DataProcessingTemplate$new("example")
data_template$template_method()

# Builder pattern
Product <- R6::R6Class("Product",
    public = list(
        parts = list(),
        
        add_part = function(part) {
            self$parts <- c(self$parts, part)
        },
        
        list_parts = function() {
            print(paste(self$parts, collapse = ", "))
        }
    )
)

Builder <- R6::R6Class("Builder",
    public = list(
        product = NULL,
        
        initialize = function() {
            self$reset()
        },
        
        reset = function() {
            self$product <- Product$new()
        },
        
        build_step_a = function() {
            self$product$add_part("Part A")
        },
        
        build_step_b = function() {
            self$product$add_part("Part B")
        },
        
        build_step_c = function() {
            self$product$add_part("Part C")
        },
        
        get_result = function() {
            result <- self$product
            self$reset()
            return(result)
        }
    )
)

Director <- R6::R6Class("Director",
    public = list(
        builder = NULL,
        
        initialize = function(builder) {
            self$builder <- builder
        },
        
        build_minimal = function() {
            self$builder$build_step_a()
        },
        
        build_full = function() {
            self$builder$build_step_a()
            self$builder$build_step_b()
            self$builder$build_step_c()
        },
        
        build_custom = function(steps) {
            self$builder$reset()
            for (step in steps) {
                if (step == "A") self$builder$build_step_a()
                else if (step == "B") self$builder$build_step_b()
                else if (step == "C") self$builder$build_step_c()
            }
        }
    )
)

# Usage
builder <- Builder$new()
director <- Director$new(builder)

print("Minimal product:")
director$build_minimal()
builder$get_result()$list_parts()

print("Full product:")
director$build_full()
builder$get_result()$list_parts()

print("Custom product:")
builder$build_step_c()
builder$build_step_a()
builder$get_result()$list_parts()

print("Director custom:")
director$build_custom(c("C", "A", "B"))
builder$get_result()$list_parts()

# Prototype pattern
Prototype <- R6::R6Class("Prototype",
    public = list(
        data = NULL,
        
        initialize = function(data) {
            self$data <- data
        },
        
        clone = function() {
            return(Prototype$new(self$data))
        },
        
        deep_clone = function() {
            return(Prototype$new(self$deep_copy(self$data)))
        },
        
        deep_copy = function(value) {
            if (is.list(value)) {
                result <- list()
                for (name in names(value)) {
                    result[[name]] <- self$deep_copy(value[[name]])
                }
                return(result)
            } else {
                return(value)
            }
        }
    )
)

MutablePrototype <- R6::R6Class("MutablePrototype",
    inherit = Prototype,
    public = list(
        set_data = function(data) {
            self$data <- data
        }
    )
)

# Usage
original <- Prototype$new(list(name = "Original", value = 42))
copy <- original$clone()
deep_copy <- original$deep_clone()

print(paste("Original:", jsonlite::toJSON(original$data)))
print(paste("Copy:", jsonlite::toJSON(copy$data)))
print(paste("Deep copy:", jsonlite::toJSON(deep_copy$data)))

mutable <- MutablePrototype$new(c(1, 2, 3))
print(paste("Original data:", paste(mutable$data, collapse = ", ")))
mutable$set_data(c(4, 5, 6))
print(paste("Modified data:", paste(mutable$data, collapse = ", ")))

cloned_mutable <- mutable$clone()
print(paste("Clone data:", paste(cloned_mutable$data, collapse = ", ")))