flowchart TD A["Shiny Application Server"] --> B["Connection Pool Manager"] B --> C["Database Connections"] C --> D["PostgreSQL"] C --> E["MySQL/MariaDB"] C --> F["SQL Server"] C --> G["SQLite"] H["Application Layers"] --> I["Presentation Layer (UI)"] H --> J["Business Logic Layer"] H --> K["Data Access Layer"] H --> L["Database Layer"] M["Security Components"] --> N["Authentication"] M --> O["Authorization"] M --> P["Encryption"] M --> Q["Audit Logging"] R["Performance Features"] --> S["Connection Pooling"] R --> T["Query Optimization"] R --> U["Caching Strategies"] R --> V["Transaction Management"] style A fill:#e1f5fe style H fill:#f3e5f5 style M fill:#e8f5e8 style R fill:#fff3e0
Key Takeaways
- Enterprise Data Architecture: Database integration transforms Shiny applications from static analysis tools into dynamic, data-driven platforms that serve entire organizations
- Scalable Performance: Connection pooling and optimized query patterns enable applications that handle thousands of concurrent users while maintaining responsive performance
- Data Security Excellence: Proper authentication, parameterized queries, and encryption ensure enterprise-grade security that meets compliance requirements and protects sensitive information
- Persistent State Management: Database-backed applications maintain user preferences, session data, and application state across sessions, creating professional user experiences
- Real-Time Data Integration: Live database connections enable applications that reflect current business conditions and support collaborative workflows with immediate data synchronization
Introduction
Database connectivity represents the evolution from standalone analytical applications to enterprise-grade systems that integrate seamlessly with organizational data infrastructure. While file-based Shiny applications work well for individual analysis, professional applications require persistent data storage, user management, audit trails, and real-time synchronization with business systems that only database integration can provide.
This comprehensive guide covers the complete spectrum of database integration, from basic connection patterns to sophisticated enterprise architectures with connection pooling, transaction management, and security implementations. You’ll master the techniques that enable Shiny applications to serve as front-ends for complex business systems while maintaining the analytical power and development efficiency that makes Shiny superior for data-driven applications.
The database integration patterns you’ll learn bridge the gap between analytical prototypes and production business systems, enabling applications that scale from departmental tools to organization-wide platforms while providing the data persistence, security, and performance characteristics required for mission-critical business applications.
Understanding Database Integration Architecture
Database-connected Shiny applications create a multi-tier architecture where the application server manages user interactions while database systems handle data persistence, concurrent access control, and business logic enforcement.
Core Database Integration Concepts
Connection Management: Efficient database connections through pooling and lifecycle management that support concurrent users while minimizing resource usage.
Data Access Patterns: Structured approaches to database operations that ensure data integrity, performance, and maintainability across complex applications.
Security Implementation: Comprehensive security measures including authentication, authorization, SQL injection prevention, and data encryption.
Transaction Control: Proper transaction management that ensures data consistency and enables complex business operations with rollback capabilities.
Foundation Database Connections
Basic Database Connection Patterns
Start with fundamental connection patterns that demonstrate secure, efficient database integration:
library(shiny)
library(DBI)
library(RPostgreSQL) # or RMySQL, RSQLite, etc.
library(pool)
library(dplyr)
library(dbplyr)
# Database configuration management
<- function() {
create_database_config
# Environment-based configuration
<- list(
config
# Development configuration
development = list(
driver = "PostgreSQL",
host = Sys.getenv("DB_HOST", "localhost"),
port = as.integer(Sys.getenv("DB_PORT", "5432")),
dbname = Sys.getenv("DB_NAME", "shiny_dev"),
user = Sys.getenv("DB_USER", "shiny_user"),
password = Sys.getenv("DB_PASSWORD", ""),
# Pool configuration
minSize = 1,
maxSize = 5,
idleTimeout = 60000,
validationQuery = "SELECT 1"
),
# Production configuration
production = list(
driver = "PostgreSQL",
host = Sys.getenv("PROD_DB_HOST"),
port = as.integer(Sys.getenv("PROD_DB_PORT", "5432")),
dbname = Sys.getenv("PROD_DB_NAME"),
user = Sys.getenv("PROD_DB_USER"),
password = Sys.getenv("PROD_DB_PASSWORD"),
# Production pool settings
minSize = 2,
maxSize = 20,
idleTimeout = 300000,
validationQuery = "SELECT 1",
# SSL configuration for production
sslmode = "require"
)
)
# Get environment
<- Sys.getenv("SHINY_ENV", "development")
env
if(!env %in% names(config)) {
stop("Unknown environment: ", env)
}
return(config[[env]])
}
# Secure connection pool creation
<- function(config = NULL) {
create_connection_pool
if(is.null(config)) {
<- create_database_config()
config
}
# Validate required configuration
<- c("host", "dbname", "user", "password")
required_fields
<- required_fields[!required_fields %in% names(config)]
missing_fields
if(length(missing_fields) > 0) {
stop("Missing required database configuration: ", paste(missing_fields, collapse = ", "))
}
tryCatch({
# Create connection pool
<- pool::dbPool(
pool drv = RPostgreSQL::PostgreSQL(),
host = config$host,
port = config$port %||% 5432,
dbname = config$dbname,
user = config$user,
password = config$password,
# Pool configuration
minSize = config$minSize %||% 1,
maxSize = config$maxSize %||% 5,
idleTimeout = config$idleTimeout %||% 60000,
validationQuery = config$validationQuery %||% "SELECT 1"
)
# Test connection
<- "SELECT current_timestamp as server_time, version() as server_version"
test_query <- pool::dbGetQuery(pool, test_query)
test_result
cat("Database connection established successfully\n")
cat("Server time:", as.character(test_result$server_time), "\n")
cat("Server version:", substr(test_result$server_version, 1, 50), "...\n")
return(pool)
error = function(e) {
},
cat("Database connection failed:", e$message, "\n")
# Provide helpful debugging information
cat("Connection details:\n")
cat(" Host:", config$host, "\n")
cat(" Port:", config$port %||% 5432, "\n")
cat(" Database:", config$dbname, "\n")
cat(" User:", config$user, "\n")
stop("Failed to create database connection pool: ", e$message)
})
}
# Basic CRUD operations
<- function(pool) {
create_database_operations
list(
# Create operations
insert_user = function(username, email, role = "user") {
<- "
query INSERT INTO users (username, email, role, created_at)
VALUES ($1, $2, $3, CURRENT_TIMESTAMP)
RETURNING user_id, username, email, role, created_at
"
tryCatch({
<- pool::dbGetQuery(
result
pool, query, params = list(username, email, role)
)
return(list(success = TRUE, data = result))
error = function(e) {
},
return(list(success = FALSE, error = e$message))
})
},
# Read operations
get_user = function(user_id) {
<- "
query SELECT user_id, username, email, role, created_at, last_login
FROM users
WHERE user_id = $1
"
<- pool::dbGetQuery(pool, query, params = list(user_id))
result
if(nrow(result) == 0) {
return(NULL)
}
return(result[1, ])
},
get_users = function(limit = 50, offset = 0, role_filter = NULL) {
<- "
base_query SELECT user_id, username, email, role, created_at, last_login
FROM users
"
<- c()
conditions <- list()
params
if(!is.null(role_filter)) {
<- c(conditions, "role = $" %+% (length(params) + 1))
conditions <- append(params, role_filter)
params
}
if(length(conditions) > 0) {
<- paste(base_query, "WHERE", paste(conditions, collapse = " AND "))
base_query
}
<- paste(
query
base_query,"ORDER BY created_at DESC",
"LIMIT $" %+% (length(params) + 1),
"OFFSET $" %+% (length(params) + 2)
)
<- append(params, list(limit, offset))
params
<- pool::dbGetQuery(pool, query, params = params)
result
return(result)
},
# Update operations
update_user = function(user_id, username = NULL, email = NULL, role = NULL) {
<- c()
updates <- list()
params
if(!is.null(username)) {
<- c(updates, "username = $" %+% (length(params) + 1))
updates <- append(params, username)
params
}
if(!is.null(email)) {
<- c(updates, "email = $" %+% (length(params) + 1))
updates <- append(params, email)
params
}
if(!is.null(role)) {
<- c(updates, "role = $" %+% (length(params) + 1))
updates <- append(params, role)
params
}
if(length(updates) == 0) {
return(list(success = FALSE, error = "No updates specified"))
}
<- paste(
query "UPDATE users SET",
paste(updates, collapse = ", "),
", updated_at = CURRENT_TIMESTAMP",
"WHERE user_id = $" %+% (length(params) + 1),
"RETURNING user_id, username, email, role, updated_at"
)
<- append(params, user_id)
params
tryCatch({
<- pool::dbGetQuery(pool, query, params = params)
result
if(nrow(result) == 0) {
return(list(success = FALSE, error = "User not found"))
}
return(list(success = TRUE, data = result[1, ]))
error = function(e) {
},
return(list(success = FALSE, error = e$message))
})
},
# Delete operations
delete_user = function(user_id) {
<- "
query DELETE FROM users
WHERE user_id = $1
RETURNING user_id, username
"
tryCatch({
<- pool::dbGetQuery(pool, query, params = list(user_id))
result
if(nrow(result) == 0) {
return(list(success = FALSE, error = "User not found"))
}
return(list(success = TRUE, message = paste("User", result$username, "deleted")))
error = function(e) {
},
return(list(success = FALSE, error = e$message))
})
},
# Authentication operations
authenticate_user = function(username, password_hash) {
<- "
query SELECT user_id, username, email, role, active
FROM users
WHERE username = $1 AND password_hash = $2 AND active = TRUE
"
<- pool::dbGetQuery(
result
pool, query, params = list(username, password_hash)
)
if(nrow(result) == 0) {
return(NULL)
}
# Update last login
<- "
update_query UPDATE users
SET last_login = CURRENT_TIMESTAMP
WHERE user_id = $1
"
::dbExecute(pool, update_query, params = list(result$user_id))
pool
return(result[1, ])
},
# Activity logging
log_activity = function(user_id, action, details = NULL) {
<- "
query INSERT INTO activity_log (user_id, action, details, timestamp)
VALUES ($1, $2, $3, CURRENT_TIMESTAMP)
"
tryCatch({
::dbExecute(
pool
pool, query,params = list(user_id, action, details)
)
return(TRUE)
error = function(e) {
},
cat("Failed to log activity:", e$message, "\n")
return(FALSE)
})
}
)
}
# Helper functions
`%||%` <- function(x, y) if(is.null(x)) y else x
`%+%` <- function(x, y) paste0(x, y)
Database Schema Creation
# Database schema setup for Shiny applications
<- function(pool) {
create_application_schema
# Users table
<- "
users_schema CREATE TABLE IF NOT EXISTS users (
user_id SERIAL PRIMARY KEY,
username VARCHAR(50) UNIQUE NOT NULL,
email VARCHAR(255) UNIQUE NOT NULL,
password_hash VARCHAR(255) NOT NULL,
role VARCHAR(20) DEFAULT 'user' CHECK (role IN ('admin', 'user', 'viewer')),
active BOOLEAN DEFAULT TRUE,
created_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
updated_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
last_login TIMESTAMP WITH TIME ZONE
);
CREATE INDEX IF NOT EXISTS idx_users_username ON users(username);
CREATE INDEX IF NOT EXISTS idx_users_email ON users(email);
CREATE INDEX IF NOT EXISTS idx_users_role ON users(role);
"
# Sessions table for user session management
<- "
sessions_schema CREATE TABLE IF NOT EXISTS user_sessions (
session_id VARCHAR(255) PRIMARY KEY,
user_id INTEGER REFERENCES users(user_id) ON DELETE CASCADE,
created_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
expires_at TIMESTAMP WITH TIME ZONE NOT NULL,
ip_address INET,
user_agent TEXT,
active BOOLEAN DEFAULT TRUE
);
CREATE INDEX IF NOT EXISTS idx_sessions_user_id ON user_sessions(user_id);
CREATE INDEX IF NOT EXISTS idx_sessions_expires_at ON user_sessions(expires_at);
"
# Activity log table
<- "
activity_log_schema CREATE TABLE IF NOT EXISTS activity_log (
log_id SERIAL PRIMARY KEY,
user_id INTEGER REFERENCES users(user_id) ON DELETE SET NULL,
session_id VARCHAR(255),
action VARCHAR(100) NOT NULL,
details JSONB,
timestamp TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
ip_address INET
);
CREATE INDEX IF NOT EXISTS idx_activity_log_user_id ON activity_log(user_id);
CREATE INDEX IF NOT EXISTS idx_activity_log_timestamp ON activity_log(timestamp);
CREATE INDEX IF NOT EXISTS idx_activity_log_action ON activity_log(action);
"
# Application data table (example)
<- "
app_data_schema CREATE TABLE IF NOT EXISTS application_data (
data_id SERIAL PRIMARY KEY,
user_id INTEGER REFERENCES users(user_id) ON DELETE CASCADE,
data_name VARCHAR(255) NOT NULL,
data_content JSONB NOT NULL,
data_type VARCHAR(50) DEFAULT 'general',
is_public BOOLEAN DEFAULT FALSE,
created_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
updated_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
CONSTRAINT unique_user_data_name UNIQUE(user_id, data_name)
);
CREATE INDEX IF NOT EXISTS idx_app_data_user_id ON application_data(user_id);
CREATE INDEX IF NOT EXISTS idx_app_data_type ON application_data(data_type);
CREATE INDEX IF NOT EXISTS idx_app_data_public ON application_data(is_public);
"
# User preferences table
<- "
preferences_schema CREATE TABLE IF NOT EXISTS user_preferences (
preference_id SERIAL PRIMARY KEY,
user_id INTEGER REFERENCES users(user_id) ON DELETE CASCADE,
preference_key VARCHAR(100) NOT NULL,
preference_value JSONB NOT NULL,
created_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
updated_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP,
CONSTRAINT unique_user_preference UNIQUE(user_id, preference_key)
);
CREATE INDEX IF NOT EXISTS idx_preferences_user_id ON user_preferences(user_id);
CREATE INDEX IF NOT EXISTS idx_preferences_key ON user_preferences(preference_key);
"
# Execute schema creation
<- list(
schemas "users" = users_schema,
"sessions" = sessions_schema,
"activity_log" = activity_log_schema,
"application_data" = app_data_schema,
"preferences" = preferences_schema
)
tryCatch({
for(schema_name in names(schemas)) {
cat("Creating schema:", schema_name, "\n")
::dbExecute(pool, schemas[[schema_name]])
pool
cat("✓ Schema", schema_name, "created successfully\n")
}
cat("All database schemas created successfully\n")
return(TRUE)
error = function(e) {
},
cat("Error creating database schema:", e$message, "\n")
return(FALSE)
}) }
Advanced Database Operations with Transactions
# Transaction management for complex operations
<- function(pool) {
create_transaction_manager
list(
# Execute multiple operations in a transaction
execute_transaction = function(operations) {
<- pool::poolCheckout(pool)
conn
tryCatch({
# Begin transaction
::dbBegin(conn)
DBI
<- list()
results
# Execute each operation
for(i in seq_along(operations)) {
<- operations[[i]]
operation
if(is.function(operation)) {
<- operation(conn)
result else if(is.list(operation) && !is.null(operation$query)) {
} <- DBI::dbGetQuery(
result
conn, $query,
operationparams = operation$params %||% list()
)else {
} stop("Invalid operation format")
}
<- result
results[[i]]
}
# Commit transaction
::dbCommit(conn)
DBI
return(list(success = TRUE, results = results))
error = function(e) {
},
# Rollback on error
::dbRollback(conn)
DBI
return(list(success = FALSE, error = e$message))
finally = {
},
::poolReturn(conn)
pool
})
},
# Create user with initial data
create_user_with_data = function(username, email, password_hash,
initial_data = NULL, preferences = NULL) {
<- list(
operations
# Insert user
function(conn) {
<- "
query INSERT INTO users (username, email, password_hash)
VALUES ($1, $2, $3)
RETURNING user_id
"
<- DBI::dbGetQuery(
result
conn, query,params = list(username, email, password_hash)
)
return(result$user_id[1])
},
# Insert initial data if provided
if(!is.null(initial_data)) {
function(conn) {
<- results[[1]] # Get user_id from previous operation
user_id
<- "
query INSERT INTO application_data (user_id, data_name, data_content, data_type)
VALUES ($1, $2, $3, $4)
"
::dbExecute(
DBI
conn, query,params = list(
user_id,$name,
initial_data::toJSON(initial_data$content),
jsonlite$type %||% "initial"
initial_data
)
)
return(TRUE)
}
},
# Insert preferences if provided
if(!is.null(preferences)) {
function(conn) {
<- results[[1]]
user_id
for(pref_key in names(preferences)) {
<- "
query INSERT INTO user_preferences (user_id, preference_key, preference_value)
VALUES ($1, $2, $3)
"
::dbExecute(
DBI
conn, query,params = list(
user_id,
pref_key,::toJSON(preferences[[pref_key]])
jsonlite
)
)
}
return(TRUE)
}
}
)
# Remove NULL operations
<- operations[!sapply(operations, is.null)]
operations
return(self$execute_transaction(operations))
},
# Bulk data operations
bulk_insert = function(table_name, data_frame, chunk_size = 1000) {
if(nrow(data_frame) == 0) {
return(list(success = TRUE, rows_affected = 0))
}
<- pool::poolCheckout(pool)
conn
tryCatch({
::dbBegin(conn)
DBI
<- 0
total_rows
# Process in chunks
for(i in seq(1, nrow(data_frame), by = chunk_size)) {
<- min(i + chunk_size - 1, nrow(data_frame))
end_idx <- data_frame[i:end_idx, ]
chunk
# Use dbWriteTable for efficient bulk insert
::dbWriteTable(
DBI
conn,
table_name,
chunk, append = TRUE,
row.names = FALSE
)
<- total_rows + nrow(chunk)
total_rows
cat("Inserted", total_rows, "of", nrow(data_frame), "rows\n")
}
::dbCommit(conn)
DBI
return(list(success = TRUE, rows_affected = total_rows))
error = function(e) {
},
::dbRollback(conn)
DBIreturn(list(success = FALSE, error = e$message))
finally = {
},
::poolReturn(conn)
pool
})
}
) }
Production Database Integration Patterns
Complete Database-Driven Application
# Complete Shiny application with database integration
<- function() {
create_database_driven_app
# Initialize database connection
<- create_database_config()
db_config <- create_connection_pool(db_config)
db_pool <- create_database_operations(db_pool)
db_ops <- create_transaction_manager(db_pool)
tx_manager
# Initialize database schema
<- create_application_schema(db_pool)
schema_created
if(!schema_created) {
stop("Failed to create database schema")
}
<- fluidPanel(
ui
titlePanel("Database-Driven Shiny Application"),
# Navigation
navbarPage(
"Data Management System",
# User Management Tab
tabPanel("User Management",
fluidRow(
column(4,
wellPanel(
h4("<i class='bi bi-person-plus-fill'></i> Add New User"),
textInput("new_username", "Username:",
placeholder = "Enter username"),
textInput("new_email", "Email:",
placeholder = "user@example.com"),
selectInput("new_role", "Role:",
choices = c("User" = "user",
"Admin" = "admin",
"Viewer" = "viewer"),
selected = "user"),
passwordInput("new_password", "Password:",
placeholder = "Enter password"),
br(),
actionButton("create_user", "Create User",
class = "btn-primary",
style = "width: 100%;"),
br(), br(),
div(id = "user_creation_status")
)
),
column(8,
wellPanel(
h4("<i class='bi bi-people-fill'></i> User Directory"),
fluidRow(
column(6,
selectInput("role_filter", "Filter by Role:",
choices = c("All Roles" = "",
"Admin" = "admin",
"User" = "user",
"Viewer" = "viewer"),
selected = "")
),
column(6,
div(style = "margin-top: 25px;",
actionButton("refresh_users", "Refresh",
class = "btn-info")
)
)
),
::dataTableOutput("users_table")
DT
)
)
)
),
# Data Management Tab
tabPanel("Data Management",
fluidRow(
column(6,
wellPanel(
h4("<i class='bi bi-database-fill-add'></i> Save Data"),
textInput("data_name", "Data Name:",
placeholder = "Enter data name"),
selectInput("data_type", "Data Type:",
choices = c("Analysis" = "analysis",
"Report" = "report",
"Dataset" = "dataset",
"Configuration" = "config")),
textAreaInput("data_content", "Data Content (JSON):",
rows = 8,
placeholder = '{"key": "value", "number": 123}'),
checkboxInput("is_public", "Make Public", FALSE),
br(),
actionButton("save_data", "Save Data",
class = "btn-success",
style = "width: 100%;")
)
),
column(6,
wellPanel(
h4("<i class='bi bi-database-fill-gear'></i> Saved Data"),
selectInput("data_type_filter", "Filter by Type:",
choices = c("All Types" = "",
"Analysis" = "analysis",
"Report" = "report",
"Dataset" = "dataset",
"Configuration" = "config")),
br(),
::dataTableOutput("saved_data_table"),
DT
br(),
fluidRow(
column(6,
actionButton("load_selected_data", "Load Selected",
class = "btn-info")
),
column(6,
actionButton("delete_selected_data", "Delete Selected",
class = "btn-danger")
)
)
)
)
),
fluidRow(
column(12,
wellPanel(
h4("<i class='bi bi-code-square'></i> Loaded Data Preview"),
div(id = "loaded_data_preview",
div(class = "alert alert-info",
"Select and load data to see preview here.")
)
)
)
)
),
# Analytics Tab
tabPanel("Analytics",
fluidRow(
column(4,
wellPanel(
h4("<i class='bi bi-graph-up'></i> Analytics Settings"),
selectInput("analytics_data_source", "Data Source:",
choices = c()),
selectInput("analysis_type", "Analysis Type:",
choices = c("Summary Statistics" = "summary",
"Time Series" = "timeseries",
"Correlation" = "correlation",
"Distribution" = "distribution")),
conditionalPanel(
condition = "input.analysis_type == 'timeseries'",
dateRangeInput("date_range", "Date Range:",
start = Sys.Date() - 30,
end = Sys.Date())
),
conditionalPanel(
condition = "input.analysis_type == 'correlation'",
numericInput("correlation_threshold", "Correlation Threshold:",
value = 0.5, min = 0, max = 1, step = 0.1)
),
br(),
actionButton("run_analysis", "Run Analysis",
class = "btn-primary",
style = "width: 100%;"),
br(), br(),
checkboxInput("save_analysis_results", "Save Results", FALSE)
)
),
column(8,
tabsetPanel(
tabPanel("Results",
verbatimTextOutput("analysis_results")
),
tabPanel("Visualization",
plotOutput("analysis_plot", height = "500px")
),
tabPanel("Export",
wellPanel(
h5("Export Options"),
fluidRow(
column(6,
downloadButton("download_results_csv", "Download CSV",
class = "btn-info")
),
column(6,
downloadButton("download_plot_png", "Download Plot",
class = "btn-info")
)
)
)
)
)
)
)
),
# Activity Log Tab
tabPanel("Activity Log",
fluidRow(
column(12,
wellPanel(
h4("<i class='bi bi-journal-text'></i> System Activity Log"),
fluidRow(
column(3,
dateInput("log_start_date", "Start Date:",
value = Sys.Date() - 7)
),
column(3,
dateInput("log_end_date", "End Date:",
value = Sys.Date())
),
column(3,
selectInput("log_action_filter", "Action Filter:",
choices = c("All Actions" = "",
"Login" = "login",
"Create" = "create",
"Update" = "update",
"Delete" = "delete",
"Analysis" = "analysis"))
),
column(3,
div(style = "margin-top: 25px;",
actionButton("refresh_log", "Refresh Log",
class = "btn-info")
)
)
),
br(),
::dataTableOutput("activity_log_table")
DT
)
)
)
),
# System Status Tab
tabPanel("System Status",
fluidRow(
column(6,
wellPanel(
h4("<i class='bi bi-database-check'></i> Database Status"),
verbatimTextOutput("database_status")
),
wellPanel(
h4("<i class='bi bi-speedometer2'></i> Performance Metrics"),
verbatimTextOutput("performance_metrics")
)
),
column(6,
wellPanel(
h4("<i class='bi bi-gear-fill'></i> System Configuration"),
verbatimTextOutput("system_config")
),
wellPanel(
h4("<i class='bi bi-tools'></i> Database Tools"),
actionButton("test_connection", "Test Connection",
class = "btn-info"),
br(), br(),
actionButton("cleanup_sessions", "Cleanup Old Sessions",
class = "btn-warning"),
br(), br(),
actionButton("vacuum_database", "Optimize Database",
class = "btn-secondary"),
br(), br(),
div(id = "db_tools_output")
)
)
)
)
)
)
<- function(input, output, session) {
server
# Reactive values for application state
<- reactiveValues(
app_state current_user = NULL,
saved_data = data.frame(),
analysis_results = NULL,
activity_log = data.frame()
)
# Session initialization
observe({
# Log session start
$log_activity(
db_opsuser_id = 1, # Default user for demo
action = "session_start",
details = jsonlite::toJSON(list(
session_id = session$token,
user_agent = session$clientData$url_hostname
))
)
})
# User Management Functions
# Create new user
observeEvent(input$create_user, {
req(input$new_username, input$new_email, input$new_password)
# Simple password hashing (use proper hashing in production)
<- digest::digest(input$new_password, algo = "sha256")
password_hash
<- db_ops$insert_user(
result username = input$new_username,
email = input$new_email,
role = input$new_role
)
if(result$success) {
showNotification("User created successfully!", type = "success")
# Clear form
updateTextInput(session, "new_username", value = "")
updateTextInput(session, "new_email", value = "")
updateTextInput(session, "new_password", value = "")
# Refresh users table
refresh_users_table()
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "create_user",
details = jsonlite::toJSON(list(
created_username = input$new_username,
created_role = input$new_role
))
)
else {
} showNotification(paste("Error creating user:", result$error),
type = "error")
}
})
# Users table
$users_table <- DT::renderDataTable({
output
<- if(input$role_filter == "") NULL else input$role_filter
role_filter
<- db_ops$get_users(role_filter = role_filter)
users_data
if(nrow(users_data) == 0) {
return(data.frame("No users found" = character(0)))
}
# Format data for display
<- users_data %>%
display_data mutate(
created_at = format(created_at, "%Y-%m-%d %H:%M"),
last_login = ifelse(is.na(last_login), "Never",
format(last_login, "%Y-%m-%d %H:%M"))
%>%
) select(user_id, username, email, role, created_at, last_login)
::datatable(
DT
display_data,options = list(
pageLength = 15,
scrollX = TRUE,
dom = 'Bfrtip',
buttons = c('copy', 'csv')
),extensions = 'Buttons',
selection = 'single',
rownames = FALSE,
colnames = c("ID", "Username", "Email", "Role", "Created", "Last Login")
)
})
# Refresh users table
<- function() {
refresh_users_table $users_table <- DT::renderDataTable({
output# Re-render users table
})
}
observeEvent(input$refresh_users, {
refresh_users_table()
})
# Data Management Functions
# Save data
observeEvent(input$save_data, {
req(input$data_name, input$data_content)
# Validate JSON
tryCatch({
<- jsonlite::fromJSON(input$data_content)
json_content
# Save to database
<- "
query INSERT INTO application_data (user_id, data_name, data_content, data_type, is_public)
VALUES ($1, $2, $3, $4, $5)
ON CONFLICT (user_id, data_name)
DO UPDATE SET
data_content = EXCLUDED.data_content,
data_type = EXCLUDED.data_type,
is_public = EXCLUDED.is_public,
updated_at = CURRENT_TIMESTAMP
"
::dbExecute(
pool
db_pool, query,params = list(
1, # Default user ID
$data_name,
input$data_content,
input$data_type,
input$is_public
input
)
)
showNotification("Data saved successfully!", type = "success")
# Refresh saved data table
refresh_saved_data_table()
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "save_data",
details = jsonlite::toJSON(list(
data_name = input$data_name,
data_type = input$data_type
))
)
error = function(e) {
}, showNotification(paste("Error saving data:", e$message), type = "error")
})
})
# Saved data table
$saved_data_table <- DT::renderDataTable({
output
<- "
query SELECT data_id, data_name, data_type, is_public, created_at, updated_at
FROM application_data
WHERE user_id = $1
"
if(input$data_type_filter != "") {
<- paste(query, "AND data_type = $2")
query <- list(1, input$data_type_filter)
params else {
} <- list(1)
params
}
<- paste(query, "ORDER BY updated_at DESC")
query
<- pool::dbGetQuery(db_pool, query, params = params)
saved_data
if(nrow(saved_data) == 0) {
return(data.frame("No saved data" = character(0)))
}
# Format for display
<- saved_data %>%
display_data mutate(
created_at = format(created_at, "%Y-%m-%d %H:%M"),
updated_at = format(updated_at, "%Y-%m-%d %H:%M"),
is_public = ifelse(is_public, "Yes", "No")
)
::datatable(
DT
display_data,options = list(
pageLength = 10,
scrollX = TRUE
),selection = 'single',
rownames = FALSE,
colnames = c("ID", "Name", "Type", "Public", "Created", "Updated")
)
})
<- function() {
refresh_saved_data_table # Force refresh of saved data table
$saved_data_table <- DT::renderDataTable({
output# Re-render logic here
})
}
# Load selected data
observeEvent(input$load_selected_data, {
req(input$saved_data_table_rows_selected)
<- input$saved_data_table_rows_selected
selected_row
# Get data details
<- "
query SELECT data_name, data_content, data_type
FROM application_data
WHERE user_id = $1
ORDER BY updated_at DESC
LIMIT 1 OFFSET $2
"
<- pool::dbGetQuery(
data_details
db_pool, query,params = list(1, selected_row - 1)
)
if(nrow(data_details) > 0) {
# Display loaded data
$loaded_data_preview <- renderUI({
output
div(
h5(paste("Loaded:", data_details$data_name)),
h6(paste("Type:", data_details$data_type)),
pre(
style = "background: #f8f9fa; padding: 15px; border-radius: 5px;",
::prettify(data_details$data_content)
jsonlite
)
)
})
showNotification("Data loaded successfully!", type = "success")
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "load_data",
details = jsonlite::toJSON(list(
data_name = data_details$data_name
))
)
}
})
# Delete selected data
observeEvent(input$delete_selected_data, {
req(input$saved_data_table_rows_selected)
<- input$saved_data_table_rows_selected
selected_row
# Get data ID
<- "
query SELECT data_id, data_name
FROM application_data
WHERE user_id = $1
ORDER BY updated_at DESC
LIMIT 1 OFFSET $2
"
<- pool::dbGetQuery(
data_info
db_pool, query,params = list(1, selected_row - 1)
)
if(nrow(data_info) > 0) {
# Confirm deletion
showModal(modalDialog(
title = "Confirm Deletion",
paste("Are you sure you want to delete:", data_info$data_name, "?"),
footer = tagList(
modalButton("Cancel"),
actionButton("confirm_delete", "Delete", class = "btn-danger")
)
))
# Store data ID for confirmation
$delete_data_id <- data_info$data_id
app_state$delete_data_name <- data_info$data_name
app_state
}
})
# Confirm deletion
observeEvent(input$confirm_delete, {
req(app_state$delete_data_id)
<- "DELETE FROM application_data WHERE data_id = $1"
query
::dbExecute(db_pool, query, params = list(app_state$delete_data_id))
pool
showNotification("Data deleted successfully!", type = "success")
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "delete_data",
details = jsonlite::toJSON(list(
data_name = app_state$delete_data_name
))
)
# Refresh table
refresh_saved_data_table()
# Close modal
removeModal()
# Clear loaded data preview
$loaded_data_preview <- renderUI({
outputdiv(class = "alert alert-info",
"Select and load data to see preview here.")
})
})
# Analytics Functions
# Update data source choices
observe({
<- "
query SELECT DISTINCT data_name
FROM application_data
WHERE user_id = $1 AND data_type IN ('dataset', 'analysis')
ORDER BY data_name
"
<- pool::dbGetQuery(db_pool, query, params = list(1))
data_sources
<- setNames(data_sources$data_name, data_sources$data_name)
choices
updateSelectInput(session, "analytics_data_source",
choices = c("Select data source..." = "", choices))
})
# Run analysis
observeEvent(input$run_analysis, {
req(input$analytics_data_source, input$analysis_type)
# Get data
<- "
query SELECT data_content
FROM application_data
WHERE user_id = $1 AND data_name = $2
"
<- pool::dbGetQuery(
data_result
db_pool, query,params = list(1, input$analytics_data_source)
)
if(nrow(data_result) == 0) {
showNotification("Selected data not found!", type = "error")
return()
}
tryCatch({
# Parse JSON data
<- jsonlite::fromJSON(data_result$data_content)
analysis_data
# Perform analysis based on type
<- switch(
analysis_result $analysis_type,
input
"summary" = {
if(is.data.frame(analysis_data)) {
summary(analysis_data)
else {
} "Data is not in tabular format for summary statistics"
}
},
"correlation" = {
if(is.data.frame(analysis_data)) {
<- sapply(analysis_data, is.numeric)
numeric_cols if(sum(numeric_cols) >= 2) {
cor(analysis_data[numeric_cols], use = "complete.obs")
else {
} "Insufficient numeric columns for correlation analysis"
}else {
} "Data is not in tabular format for correlation analysis"
}
},
"distribution" = {
if(is.data.frame(analysis_data)) {
<- analysis_data[sapply(analysis_data, is.numeric)]
numeric_cols if(ncol(numeric_cols) > 0) {
lapply(numeric_cols, function(x) {
list(
mean = mean(x, na.rm = TRUE),
median = median(x, na.rm = TRUE),
sd = sd(x, na.rm = TRUE),
min = min(x, na.rm = TRUE),
max = max(x, na.rm = TRUE)
)
})else {
} "No numeric columns found for distribution analysis"
}else {
} "Data is not in tabular format for distribution analysis"
}
},
"Analysis type not implemented"
)
$analysis_results <- analysis_result
app_state
# Save results if requested
if(input$save_analysis_results) {
<- paste0("analysis_", input$analysis_type, "_",
results_name format(Sys.time(), "%Y%m%d_%H%M%S"))
<- "
query INSERT INTO application_data (user_id, data_name, data_content, data_type)
VALUES ($1, $2, $3, 'analysis_result')
"
::dbExecute(
pool
db_pool, query,params = list(
1,
results_name,::toJSON(analysis_result, auto_unbox = TRUE)
jsonlite
)
)
showNotification("Analysis completed and results saved!", type = "success")
else {
} showNotification("Analysis completed!", type = "success")
}
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "analysis",
details = jsonlite::toJSON(list(
analysis_type = input$analysis_type,
data_source = input$analytics_data_source,
saved = input$save_analysis_results
))
)
error = function(e) {
}, showNotification(paste("Analysis error:", e$message), type = "error")
})
})
# Display analysis results
$analysis_results <- renderPrint({
output
if(!is.null(app_state$analysis_results)) {
cat("Analysis Results:\n")
cat("================\n\n")
if(is.matrix(app_state$analysis_results)) {
print(app_state$analysis_results)
else if(is.list(app_state$analysis_results)) {
} str(app_state$analysis_results)
else {
} print(app_state$analysis_results)
}
else {
} cat("No analysis results available.\nRun an analysis to see results here.")
}
})
# Activity Log Functions
# Activity log table
$activity_log_table <- DT::renderDataTable({
output
<- "
query SELECT al.timestamp, u.username, al.action, al.details
FROM activity_log al
LEFT JOIN users u ON al.user_id = u.user_id
WHERE al.timestamp >= $1 AND al.timestamp <= $2
"
<- list(
params as.POSIXct(paste(input$log_start_date, "00:00:00")),
as.POSIXct(paste(input$log_end_date, "23:59:59"))
)
if(input$log_action_filter != "") {
<- paste(query, "AND al.action = $3")
query <- c(params, input$log_action_filter)
params
}
<- paste(query, "ORDER BY al.timestamp DESC LIMIT 1000")
query
<- pool::dbGetQuery(db_pool, query, params = params)
activity_data
if(nrow(activity_data) == 0) {
return(data.frame("No activity found" = character(0)))
}
# Format for display
<- activity_data %>%
display_data mutate(
timestamp = format(timestamp, "%Y-%m-%d %H:%M:%S"),
username = ifelse(is.na(username), "System", username),
details = ifelse(is.na(details), "",
substr(details, 1, 100)) # Truncate long details
)
::datatable(
DT
display_data,options = list(
pageLength = 25,
scrollX = TRUE,
order = list(list(0, 'desc')) # Sort by timestamp descending
),rownames = FALSE,
colnames = c("Timestamp", "User", "Action", "Details")
)
})
observeEvent(input$refresh_log, {
# Refresh activity log
$activity_log_table <- DT::renderDataTable({
output# Re-render activity log
})
})
# System Status Functions
# Database status
$database_status <- renderPrint({
output
tryCatch({
# Connection pool status
<- pool::dbPool_info(db_pool)
pool_info
# Database version and stats
<- pool::dbGetQuery(db_pool, "
db_info SELECT
version() as db_version,
current_database() as db_name,
current_user as db_user,
inet_server_addr() as server_ip,
inet_server_port() as server_port
")
# Table counts
<- pool::dbGetQuery(db_pool, "
table_counts SELECT
(SELECT COUNT(*) FROM users) as users_count,
(SELECT COUNT(*) FROM application_data) as data_count,
(SELECT COUNT(*) FROM activity_log) as log_count,
(SELECT COUNT(*) FROM user_sessions) as session_count
")
cat("Database Connection Status:\n")
cat("==========================\n")
cat("Status: Connected ✓\n")
cat("Database:", db_info$db_name, "\n")
cat("User:", db_info$db_user, "\n")
cat("Server:", paste0(db_info$server_ip, ":", db_info$server_port), "\n\n")
cat("Connection Pool:\n")
cat("Active connections:", pool_info$active, "\n")
cat("Idle connections:", pool_info$idle, "\n")
cat("Total connections:", pool_info$total, "\n\n")
cat("Database Statistics:\n")
cat("Users:", table_counts$users_count, "\n")
cat("Data records:", table_counts$data_count, "\n")
cat("Activity logs:", table_counts$log_count, "\n")
cat("Active sessions:", table_counts$session_count, "\n")
error = function(e) {
},
cat("Database Status: ERROR\n")
cat("======================\n")
cat("Error:", e$message, "\n")
})
})
# Performance metrics
$performance_metrics <- renderPrint({
output
tryCatch({
# Query performance stats
<- pool::dbGetQuery(db_pool, "
perf_stats SELECT
pg_database_size(current_database()) as db_size_bytes,
(SELECT COUNT(*) FROM pg_stat_activity WHERE state = 'active') as active_queries,
(SELECT MAX(query_start) FROM pg_stat_activity) as last_query_time
")
# Connection timing test
<- Sys.time()
start_time ::dbGetQuery(db_pool, "SELECT 1")
pool<- as.numeric(difftime(Sys.time(), start_time, units = "secs"))
query_time
cat("Performance Metrics:\n")
cat("===================\n")
cat("Database size:", round(perf_stats$db_size_bytes / 1024 / 1024, 2), "MB\n")
cat("Active queries:", perf_stats$active_queries, "\n")
cat("Query response time:", round(query_time * 1000, 2), "ms\n")
cat("Last query:", format(perf_stats$last_query_time, "%H:%M:%S"), "\n")
error = function(e) {
},
cat("Performance Metrics: ERROR\n")
cat("=========================\n")
cat("Error:", e$message, "\n")
})
})
# System configuration
$system_config <- renderPrint({
output
cat("System Configuration:\n")
cat("====================\n")
cat("R version:", R.version.string, "\n")
cat("Shiny version:", packageVersion("shiny"), "\n")
cat("DBI version:", packageVersion("DBI"), "\n")
cat("Pool version:", packageVersion("pool"), "\n")
cat("Environment:", Sys.getenv("SHINY_ENV", "development"), "\n")
cat("Session start:", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n")
})
# Database tools
observeEvent(input$test_connection, {
<- tryCatch({
result
<- pool::dbGetQuery(db_pool, "SELECT 'Connection OK' as status, CURRENT_TIMESTAMP as test_time")
test_result
$db_tools_output <- renderUI({
outputdiv(class = "alert alert-success",
strong("Connection Test: PASSED"),
br(),
"Test time:", format(test_result$test_time, "%Y-%m-%d %H:%M:%S"))
})
error = function(e) {
},
$db_tools_output <- renderUI({
outputdiv(class = "alert alert-danger",
strong("Connection Test: FAILED"),
br(),
"Error:", e$message)
})
})
})
observeEvent(input$cleanup_sessions, {
tryCatch({
# Clean up expired sessions
<- pool::dbExecute(db_pool, "
cleanup_result DELETE FROM user_sessions
WHERE expires_at < CURRENT_TIMESTAMP OR active = FALSE
")
$db_tools_output <- renderUI({
outputdiv(class = "alert alert-info",
strong("Session Cleanup: COMPLETED"),
br(),
paste("Removed", cleanup_result, "expired sessions"))
})
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "cleanup_sessions",
details = jsonlite::toJSON(list(sessions_removed = cleanup_result))
)
error = function(e) {
},
$db_tools_output <- renderUI({
outputdiv(class = "alert alert-danger",
strong("Session Cleanup: FAILED"),
br(),
"Error:", e$message)
})
})
})
observeEvent(input$vacuum_database, {
tryCatch({
# Note: VACUUM cannot be run inside a transaction in PostgreSQL
# This is a simplified example
::dbExecute(db_pool, "ANALYZE")
pool
$db_tools_output <- renderUI({
outputdiv(class = "alert alert-success",
strong("Database Optimization: COMPLETED"),
br(),
"Database statistics updated successfully")
})
# Log activity
$log_activity(
db_opsuser_id = 1,
action = "optimize_database",
details = jsonlite::toJSON(list(operation = "analyze"))
)
error = function(e) {
},
$db_tools_output <- renderUI({
outputdiv(class = "alert alert-danger",
strong("Database Optimization: FAILED"),
br(),
"Error:", e$message)
})
})
})
# Session cleanup on disconnect
$onSessionEnded(function() {
session
# Log session end
$log_activity(
db_opsuser_id = 1,
action = "session_end",
details = jsonlite::toJSON(list(
session_id = session$token,
duration_minutes = as.numeric(difftime(Sys.time(),
$startTime,
sessionunits = "mins"))
))
)
})
}
# Cleanup function for application shutdown
onStop(function() {
cat("Closing database connection pool...\n")
::poolClose(db_pool)
poolcat("Database connections closed.\n")
})
return(list(ui = ui, server = server))
}
Common Issues and Solutions
Issue 1: Connection Pool Exhaustion
Problem: Application runs out of database connections under high load, causing errors and timeouts.
Solution:
Implement proper connection pool management and monitoring:
# Advanced connection pool configuration
<- function(config) {
create_robust_connection_pool
<- pool::dbPool(
pool drv = RPostgreSQL::PostgreSQL(),
host = config$host,
port = config$port,
dbname = config$dbname,
user = config$user,
password = config$password,
# Optimized pool settings
minSize = config$minSize %||% 2,
maxSize = config$maxSize %||% 10,
idleTimeout = 600000, # 10 minutes
validationQuery = "SELECT 1",
# Connection retry settings
onActivate = function(conn) {
# Set connection-specific parameters
::dbExecute(conn, "SET application_name = 'shiny_app'")
DBI::dbExecute(conn, "SET statement_timeout = '30s'")
DBI
},
onPassivate = function(conn) {
# Clean up connection before returning to pool
::dbExecute(conn, "RESET ALL")
DBI
}
)
# Add pool monitoring
<- function() {
pool_monitor
<- pool::dbPool_info(pool)
pool_info
# Alert if pool utilization is high
<- pool_info$active / (pool_info$active + pool_info$idle)
utilization
if(utilization > 0.8) {
warning("High database pool utilization: ", round(utilization * 100, 1), "%")
}
# Log pool statistics
cat("Pool status - Active:", pool_info$active,
"Idle:", pool_info$idle,
"Total:", pool_info$total, "\n")
}
# Schedule periodic monitoring
::later(pool_monitor, delay = 60) # Check every minute
later
return(pool)
}
Issue 2: SQL Injection Vulnerabilities
Problem: Dynamic SQL queries with user input create security vulnerabilities.
Solution:
Always use parameterized queries and input validation:
# Secure query patterns
<- function(pool) {
create_secure_query_functions
list(
# Secure search with user input
search_data = function(search_term, data_type = NULL, user_id) {
# Input validation
if(!is.character(search_term) || nchar(search_term) == 0) {
stop("Invalid search term")
}
if(nchar(search_term) > 100) {
stop("Search term too long")
}
# Sanitize search term for LIKE pattern
<- paste0("%", gsub("[%_]", "\\\\&", search_term), "%")
safe_search_term
# Build parameterized query
<- "
base_query SELECT data_id, data_name, data_type, created_at
FROM application_data
WHERE user_id = $1
AND (data_name ILIKE $2 OR data_content::text ILIKE $2)
"
<- list(user_id, safe_search_term)
params
# Add optional type filter
if(!is.null(data_type)) {
if(!data_type %in% c("analysis", "report", "dataset", "config")) {
stop("Invalid data type")
}
<- paste(base_query, "AND data_type = $3")
base_query <- append(params, data_type)
params
}
<- paste(base_query, "ORDER BY created_at DESC LIMIT 50")
query
tryCatch({
<- pool::dbGetQuery(pool, query, params = params)
result return(list(success = TRUE, data = result))
error = function(e) {
},
# Log security event
cat("Search query error:", e$message, "\n")
return(list(success = FALSE, error = "Search failed"))
})
},
# Secure dynamic filtering
filter_data = function(filters, user_id) {
# Validate filters structure
if(!is.list(filters) || length(filters) == 0) {
stop("Invalid filters")
}
# Allowed filter columns (whitelist approach)
<- c("data_type", "is_public", "created_at")
allowed_columns
<- "
base_query SELECT data_id, data_name, data_type, is_public, created_at
FROM application_data
WHERE user_id = $1
"
<- c()
conditions <- list(user_id)
params
for(filter_name in names(filters)) {
# Validate column name
if(!filter_name %in% allowed_columns) {
warning("Invalid filter column:", filter_name)
next
}
<- filters[[filter_name]]
filter_value
# Type-specific validation
if(filter_name == "data_type") {
if(!filter_value %in% c("analysis", "report", "dataset", "config")) {
warning("Invalid data_type value:", filter_value)
next
}
<- c(conditions, paste0("data_type = $", length(params) + 1))
conditions <- append(params, filter_value)
params
else if(filter_name == "is_public") {
}
if(!is.logical(filter_value)) {
warning("Invalid is_public value:", filter_value)
next
}
<- c(conditions, paste0("is_public = $", length(params) + 1))
conditions <- append(params, filter_value)
params
else if(filter_name == "created_at") {
}
if(!inherits(filter_value, "Date") && !inherits(filter_value, "POSIXct")) {
warning("Invalid created_at value:", filter_value)
next
}
<- c(conditions, paste0("created_at >= $", length(params) + 1))
conditions <- append(params, filter_value)
params
}
}
# Build final query
if(length(conditions) > 0) {
<- paste(base_query, "AND", paste(conditions, collapse = " AND "))
query else {
} <- base_query
query
}
<- paste(query, "ORDER BY created_at DESC LIMIT 100")
query
<- pool::dbGetQuery(pool, query, params = params)
result
return(result)
}
) }
Issue 3: Database Transaction Management
Problem: Complex operations fail partway through, leaving data in inconsistent state.
Solution:
Implement comprehensive transaction management:
# Robust transaction management
<- function(pool) {
create_transaction_wrapper
<- function(operations, isolation_level = "READ COMMITTED") {
execute_with_transaction
<- pool::poolCheckout(pool)
conn
tryCatch({
# Set transaction isolation level
::dbExecute(conn, paste("SET TRANSACTION ISOLATION LEVEL", isolation_level))
DBI
# Begin transaction
::dbBegin(conn)
DBI
<- list()
results
# Execute operations
for(i in seq_along(operations)) {
<- operations[[i]]
operation
# Execute operation with error context
tryCatch({
if(is.function(operation)) {
# Function-based operation
<- operation(conn)
result
else if(is.list(operation)) {
}
# Query-based operation
if(!is.null(operation$query)) {
if(!is.null(operation$params)) {
<- DBI::dbGetQuery(conn, operation$query, params = operation$params)
result else {
} <- DBI::dbGetQuery(conn, operation$query)
result
}
else if(!is.null(operation$execute)) {
}
if(!is.null(operation$params)) {
<- DBI::dbExecute(conn, operation$execute, params = operation$params)
result else {
} <- DBI::dbExecute(conn, operation$execute)
result
}
else {
} stop("Invalid operation format")
}
else {
} stop("Unsupported operation type")
}
<- result
results[[i]]
error = function(e) {
},
# Add context to error
stop(paste("Operation", i, "failed:", e$message))
})
}
# Commit transaction
::dbCommit(conn)
DBI
return(list(success = TRUE, results = results))
error = function(e) {
},
# Rollback transaction
tryCatch({
::dbRollback(conn)
DBIerror = function(rollback_error) {
}, warning("Rollback failed:", rollback_error$message)
})
return(list(success = FALSE, error = e$message))
finally = {
},
# Always return connection to pool
::poolReturn(conn)
pool
})
}
return(execute_with_transaction)
}
# Example usage of transaction wrapper
<- function(from_user_id, to_user_id, data_id, tx_manager) {
transfer_data_between_users
<- list(
operations
# Verify source user owns the data
list(
query = "
SELECT user_id FROM application_data
WHERE data_id = $1 AND user_id = $2
",
params = list(data_id, from_user_id)
),
# Create audit log entry
list(
execute = "
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'data_transfer_start', $2)
",
params = list(
from_user_id,::toJSON(list(
jsonlitedata_id = data_id,
to_user = to_user_id,
timestamp = Sys.time()
))
)
),
# Transfer ownership
list(
execute = "
UPDATE application_data
SET user_id = $1, updated_at = CURRENT_TIMESTAMP
WHERE data_id = $2
",
params = list(to_user_id, data_id)
),
# Log completion
list(
execute = "
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'data_transfer_complete', $2)
",
params = list(
to_user_id,::toJSON(list(
jsonlitedata_id = data_id,
from_user = from_user_id,
timestamp = Sys.time()
))
)
)
)
<- tx_manager(operations)
result
return(result)
}
Always use parameterized queries, implement proper authentication and authorization, encrypt sensitive data both in transit and at rest, regularly audit database access, and implement proper backup and recovery procedures for production systems.
Common Questions About Database Integration
Consider these factors when choosing a database:
PostgreSQL - Best for:
- Complex analytical queries and advanced data types
- High concurrent user loads and enterprise applications
- Applications requiring ACID compliance and data integrity
- Advanced features like JSON support and full-text search
MySQL/MariaDB - Best for:
- Web applications with moderate complexity
- Environments where MySQL expertise already exists
- Applications with high read/write ratios
- Cost-conscious deployments
SQLite - Best for:
- Development and testing environments
- Single-user or low-concurrency applications
- Embedded scenarios with minimal setup requirements
- Prototyping and proof-of-concept applications
SQL Server - Best for:
- Microsoft-centric enterprise environments
- Applications requiring integration with other Microsoft tools
- Organizations with existing SQL Server infrastructure
Choose based on your scalability needs, team expertise, infrastructure constraints, and budget considerations.
Direct Connections:
- Each operation opens/closes a database connection
- Simple but inefficient for multiple operations
- Higher latency due to connection overhead
- Not suitable for concurrent users
Connection Pooling:
- Maintains a pool of reusable connections
- Significantly better performance under load
- Supports concurrent users efficiently
- Requires proper configuration and monitoring
Implementation comparison:
# Direct connection (avoid in production)
<- function(query) {
direct_query <- DBI::dbConnect(RPostgreSQL::PostgreSQL(), ...)
conn <- DBI::dbGetQuery(conn, query)
result ::dbDisconnect(conn)
DBIreturn(result)
}
# Connection pooling (recommended)
<- function(query, pool) {
pooled_query <- pool::dbGetQuery(pool, query)
result return(result)
}
Always use connection pooling for production applications with multiple users or frequent database operations.
Implement a structured migration system:
# Database migration framework
<- function(pool) {
create_migration_system
# Create migrations table
<- function() {
setup_migrations_table
<- "
migration_table_sql CREATE TABLE IF NOT EXISTS schema_migrations (
migration_id SERIAL PRIMARY KEY,
version VARCHAR(50) UNIQUE NOT NULL,
description TEXT,
applied_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
checksum VARCHAR(64)
)
"
::dbExecute(pool, migration_table_sql)
pool
}
# Apply migration
<- function(version, description, sql_commands) {
apply_migration
# Check if already applied
<- pool::dbGetQuery(
existing
pool,"SELECT version FROM schema_migrations WHERE version = $1",
params = list(version)
)
if(nrow(existing) > 0) {
cat("Migration", version, "already applied\n")
return(TRUE)
}
# Apply migration in transaction
<- pool::poolCheckout(pool)
conn
tryCatch({
::dbBegin(conn)
DBI
# Execute migration commands
for(sql in sql_commands) {
::dbExecute(conn, sql)
DBI
}
# Record migration
::dbExecute(
DBI
conn,"INSERT INTO schema_migrations (version, description) VALUES ($1, $2)",
params = list(version, description)
)
::dbCommit(conn)
DBI
cat("Migration", version, "applied successfully\n")
return(TRUE)
error = function(e) {
},
::dbRollback(conn)
DBIstop("Migration failed: ", e$message)
finally = {
},
::poolReturn(conn)
pool
})
}
return(list(
setup = setup_migrations_table,
apply = apply_migration
))
}
# Example migration usage
<- create_migration_system(db_pool)
migration_system $setup()
migration_system
# Apply a migration
$apply(
migration_systemversion = "001_add_user_preferences",
description = "Add user preferences table",
sql_commands = c(
"CREATE TABLE user_preferences (...)",
"CREATE INDEX idx_preferences_user_id ON user_preferences(user_id)"
) )
Use comprehensive error handling patterns:
# Robust error handling wrapper
<- function(pool) {
create_error_handler
<- function(operation_name, query_function) {
safe_db_operation
tryCatch({
# Log operation start
cat("Starting operation:", operation_name, "\n")
# Execute query function
<- query_function()
result
# Log success
cat("Operation completed:", operation_name, "\n")
return(list(
success = TRUE,
data = result,
operation = operation_name,
timestamp = Sys.time()
))
error = function(e) {
},
# Categorize error types
<- if(grepl("connection", e$message, ignore.case = TRUE)) {
error_type "connection_error"
else if(grepl("syntax", e$message, ignore.case = TRUE)) {
} "sql_syntax_error"
else if(grepl("duplicate", e$message, ignore.case = TRUE)) {
} "constraint_violation"
else if(grepl("timeout", e$message, ignore.case = TRUE)) {
} "timeout_error"
else {
} "general_error"
}
# Log error with context
cat("Operation failed:", operation_name, "\n")
cat("Error type:", error_type, "\n")
cat("Error message:", e$message, "\n")
# Return structured error
return(list(
success = FALSE,
error = e$message,
error_type = error_type,
operation = operation_name,
timestamp = Sys.time()
))
})
}
return(safe_db_operation)
}
# Usage example
<- create_error_handler(db_pool)
safe_operation
<- safe_operation("user_creation", function() {
result ::dbGetQuery(
pool
db_pool,"INSERT INTO users (username, email) VALUES ($1, $2) RETURNING user_id",
params = list("newuser", "user@example.com")
)
})
if(result$success) {
cat("User created with ID:", result$data$user_id, "\n")
else {
} cat("Failed to create user:", result$error, "\n")
}
Key performance strategies include:
Query Optimization:
- Use EXPLAIN ANALYZE to understand query performance
- Create appropriate indexes for frequently queried columns
- Limit result sets with LIMIT and pagination
- Use parameterized queries to enable query plan caching
Connection Management:
- Size connection pools appropriately (typically 2-3x number of CPU cores)
- Monitor pool utilization and adjust as needed
- Use connection validation to handle stale connections
- Implement connection retry logic for temporary failures
Caching Strategies:
# Implement query result caching
<- function(ttl_seconds = 300) {
create_query_cache
<- list()
cache
<- function(query, params = NULL, pool) {
cached_query
# Create cache key
<- digest::digest(list(query = query, params = params))
cache_key
# Check cache
if(cache_key %in% names(cache)) {
<- cache[[cache_key]]
cached_entry
# Check if still valid
if(difftime(Sys.time(), cached_entry$timestamp, units = "secs") < ttl_seconds) {
return(cached_entry$result)
}
}
# Execute query
<- pool::dbGetQuery(pool, query, params = params)
result
# Cache result
<<- list(
cache[[cache_key]] result = result,
timestamp = Sys.time()
)
return(result)
}
return(cached_query)
}
Memory Management:
- Process large datasets in chunks
- Use streaming for bulk operations
- Clear unused reactive values and objects
- Monitor memory usage in production
Test Your Understanding
You’re deploying a Shiny application that expects 50 concurrent users performing database operations. What’s the recommended connection pool configuration?
<- pool::dbPool(
pool drv = RPostgreSQL::PostgreSQL(),
# ... connection parameters ...
minSize = ?,
maxSize = ?,
idleTimeout = ?
)
- minSize = 1, maxSize = 50, idleTimeout = 30000
- minSize = 5, maxSize = 15, idleTimeout = 300000
- minSize = 50, maxSize = 100, idleTimeout = 60000
- minSize = 2, maxSize = 200, idleTimeout = 600000
- Consider that not all users will be active simultaneously
- Think about database server resource limitations
- Remember that connections consume memory on both client and server
- Consider typical user behavior patterns in web applications
B) minSize = 5, maxSize = 15, idleTimeout = 300000
Reasoning:
- minSize = 5: Ensures immediate availability without cold start delays
- maxSize = 15: Typically 20-30% of concurrent users is sufficient since not all users perform database operations simultaneously
- idleTimeout = 300000 (5 minutes): Balances resource conservation with responsiveness
Why other options are problematic:
- Option A: maxSize too low for 50 concurrent users, idleTimeout too short
- Option C: Excessive connections that would overwhelm the database server
- Option D: Extremely high maxSize wastes resources, though timeout is reasonable
Additional considerations:
# Production-ready pool configuration
<- pool::dbPool(
pool drv = RPostgreSQL::PostgreSQL(),
# ... connection parameters ...
minSize = 5,
maxSize = 15,
idleTimeout = 300000, # 5 minutes
validationQuery = "SELECT 1",
# Additional production settings
onActivate = function(conn) {
::dbExecute(conn, "SET application_name = 'shiny_app'")
DBI
} )
Rule of thumb: Connection pool size should be 2-3x the number of CPU cores on your database server, adjusted for your specific usage patterns.
You need to create a search function that allows users to search through their saved data. Which implementation is secure against SQL injection?
<- function(search_term, pool) {
search_data <- paste0("SELECT * FROM data WHERE content LIKE '%", search_term, "%'")
query ::dbGetQuery(pool, query)
pool }
<- function(search_term, pool) {
search_data <- "SELECT * FROM data WHERE content LIKE $1"
query ::dbGetQuery(pool, query, params = list(paste0("%", search_term, "%")))
pool }
<- function(search_term, pool) {
search_data <- gsub("'", "''", search_term)
safe_term <- paste0("SELECT * FROM data WHERE content LIKE '%", safe_term, "%'")
query ::dbGetQuery(pool, query)
pool }
<- function(search_term, pool) {
search_data <- "SELECT * FROM data WHERE content LIKE ?"
query ::dbGetQuery(pool, query, params = list(search_term))
pool }
- Consider how user input is incorporated into the SQL query
- Think about parameterized queries vs string concatenation
- Remember that simple escaping is not sufficient protection
- Consider which approach separates SQL structure from data
B) Parameterized query with proper parameter binding
<- function(search_term, pool) {
search_data # Input validation
if (!is.character(search_term) || nchar(search_term) == 0) {
stop("Invalid search term")
}
if (nchar(search_term) > 100) {
stop("Search term too long")
}
# Parameterized query with LIKE pattern
<- "SELECT * FROM data WHERE content LIKE $1"
query
# Safely construct LIKE pattern
<- paste0("%", search_term, "%")
pattern
::dbGetQuery(pool, query, params = list(pattern))
pool }
Why this is secure:
- Uses parameterized queries (
$1
) instead of string concatenation - Database driver handles proper escaping and quoting
- SQL structure is separate from user data
- Includes input validation for additional safety
Why other options are wrong:
- Option A: Direct string concatenation - classic SQL injection vulnerability
- Option C: Manual escaping is insufficient and error-prone
- Option D: Uses
?
placeholder which may not work with all R database drivers
Enhanced secure version:
<- function(search_term, user_id, pool) {
secure_search_data
# Comprehensive input validation
if (!is.character(search_term) || nchar(search_term) == 0) {
return(list(success = FALSE, error = "Invalid search term"))
}
if (nchar(search_term) > 100) {
return(list(success = FALSE, error = "Search term too long"))
}
# Sanitize for LIKE pattern (escape special LIKE characters)
<- gsub("[%_\\\\]", "\\\\\\0", search_term)
safe_pattern <- paste0("%", safe_pattern, "%")
like_pattern
# Secure parameterized query with user authorization
<- "
query SELECT data_id, data_name, data_type, created_at
FROM application_data
WHERE user_id = $1
AND (data_name ILIKE $2 OR data_content::text ILIKE $2)
ORDER BY created_at DESC
LIMIT 50
"
tryCatch({
<- pool::dbGetQuery(
result
pool, query,params = list(user_id, like_pattern)
)
return(list(success = TRUE, data = result))
error = function(e) {
},
# Log error without exposing details to user
cat("Search error:", e$message, "\n")
return(list(success = FALSE, error = "Search failed"))
}) }
You need to implement a user registration process that creates a user record, initializes their preferences, and logs the activity. If any step fails, all changes should be rolled back. What’s the correct approach?
- Execute each operation separately and handle errors individually
- Use a database transaction to wrap all operations
- Create the user first, then handle preferences and logging separately
- Use separate database connections for each operation
- Consider data consistency requirements
- Think about what happens if an operation fails partway through
- Remember ACID properties (Atomicity, Consistency, Isolation, Durability)
- Consider the user experience if partial operations succeed
B) Use a database transaction to wrap all operations
<- function(username, email, password_hash, initial_prefs, pool) {
register_user_with_transaction
<- pool::poolCheckout(pool)
conn
tryCatch({
# Begin transaction
::dbBegin(conn)
DBI
# Step 1: Create user
<- DBI::dbGetQuery(
user_result
conn,"INSERT INTO users (username, email, password_hash) VALUES ($1, $2, $3) RETURNING user_id",
params = list(username, email, password_hash)
)
<- user_result$user_id[1]
user_id
# Step 2: Initialize preferences
for (pref_key in names(initial_prefs)) {
::dbExecute(
DBI
conn,"INSERT INTO user_preferences (user_id, preference_key, preference_value) VALUES ($1, $2, $3)",
params = list(user_id, pref_key, jsonlite::toJSON(initial_prefs[[pref_key]]))
)
}
# Step 3: Log registration activity
::dbExecute(
DBI
conn,"INSERT INTO activity_log (user_id, action, details) VALUES ($1, $2, $3)",
params = list(
user_id,"user_registration",
::toJSON(list(
jsonliteusername = username,
registration_time = Sys.time(),
preferences_count = length(initial_prefs)
))
)
)
# Commit transaction - all operations succeed together
::dbCommit(conn)
DBI
return(list(
success = TRUE,
user_id = user_id,
message = "User registered successfully"
))
error = function(e) {
},
# Rollback transaction - all operations fail together
::dbRollback(conn)
DBI
return(list(
success = FALSE,
error = paste("Registration failed:", e$message)
))
finally = {
},
# Always return connection to pool
::poolReturn(conn)
pool
}) }
Why transactions are essential:
✅ Atomicity: All operations succeed or all fail together
✅ Consistency: Database remains in valid state
✅ Isolation: Other users don’t see partial results
✅ Durability: Committed changes are permanent
Why other approaches fail:
- Option A: Risk of partial completion leaving inconsistent data
- Option C: User could exist without preferences, breaking application assumptions
- Option D: Separate connections can’t participate in same transaction
Alternative pattern for complex transactions:
# Transaction manager pattern
<- function(pool) {
create_user_registration_transaction
<- list(
operations
create_user = function(conn, username, email, password_hash) {
::dbGetQuery(
DBI
conn,"INSERT INTO users (username, email, password_hash) VALUES ($1, $2, $3) RETURNING user_id",
params = list(username, email, password_hash)
)
},
create_preferences = function(conn, user_id, preferences) {
for (key in names(preferences)) {
::dbExecute(
DBI
conn,"INSERT INTO user_preferences (user_id, preference_key, preference_value) VALUES ($1, $2, $3)",
params = list(user_id, key, jsonlite::toJSON(preferences[[key]]))
)
}return(length(preferences))
},
log_registration = function(conn, user_id, username) {
::dbExecute(
DBI
conn,"INSERT INTO activity_log (user_id, action, details) VALUES ($1, $2, $3)",
params = list(user_id, "registration", jsonlite::toJSON(list(username = username)))
)return(TRUE)
}
)
return(operations)
}
Conclusion
Database connectivity transforms Shiny applications from isolated analytical tools into integrated business systems that persist data, manage users, and coordinate workflows across entire organizations. Through mastering connection pooling, secure query patterns, transaction management, and performance optimization, you’ve gained the ability to build enterprise-grade applications that handle real-world data requirements while maintaining the analytical power that makes Shiny unique.
The database integration patterns you’ve learned provide the foundation for applications that scale from individual projects to organization-wide platforms, supporting hundreds of concurrent users while maintaining data integrity, security, and performance. This combination of R’s analytical capabilities with robust data persistence creates powerful business intelligence platforms that compete with commercial solutions while providing superior flexibility and cost-effectiveness.
Your understanding of production database patterns, security implementations, and performance optimization positions you to build mission-critical applications that organizations depend on for daily operations, strategic decision-making, and long-term data management.
Next Steps
Based on your mastery of database integration, here are the recommended paths for continuing your advanced Shiny development journey:
Immediate Next Steps (Complete These First)
- User Authentication and Security - Secure your database-connected applications with proper user management and access control
- Testing and Debugging Strategies - Implement comprehensive testing for database-driven applications including transaction testing and data integrity validation
- Practice Exercise: Build a complete multi-user application with user registration, data sharing, and audit logging using your database integration skills
Building on Your Foundation (Choose Your Path)
For Production Systems:
- Production Deployment Overview - Deploy database-connected applications with proper infrastructure and monitoring
- Production Deployment and Monitoring - Monitor database performance and application health in production environments
For Advanced Development:
- Creating Shiny Packages - Package your database integration patterns for reuse across multiple applications
- JavaScript Integration and Custom Functionality - Combine database connectivity with advanced client-side functionality
For Enterprise Applications:
- Practical Projects Series - Build complete enterprise applications that showcase all database integration techniques
- Best Practices and Code Organization - Organize complex database-driven applications for team development and maintenance
Long-term Goals (2-4 Weeks)
- Build a complete multi-tenant application with user isolation, role-based access control, and comprehensive audit trails
- Implement a real-time collaboration platform with database synchronization and conflict resolution
- Create a scalable analytics platform that handles millions of records with optimized query performance
- Develop a comprehensive backup and disaster recovery strategy for production database applications
Explore More Articles
Here are more articles from the same category to help you dive deeper into the topic.
Reuse
Citation
@online{kassambara2025,
author = {Kassambara, Alboukadel},
title = {Database {Connectivity} and {Data} {Persistence:} {Build}
{Data-Driven} {Applications}},
date = {2025-05-23},
url = {https://www.datanovia.com/learn/tools/shiny-apps/advanced-concepts/database-connections.html},
langid = {en}
}