Applied R Analytics

Statistical Computing in R

Seven method families, from regression through linear programming, with holdout metrics and decision takeaways.

Regression Classification Trees Text Cluster Viz LP

Portfolio demonstrations use synthetic or public-style data. Open a family, then a problem for notebook-style code.

Method families

Fourteen problems in seven groups

Skim by family. One featured problem starts open; everything else stays closed until you need it.

Reg Regression 3 problems · lm · holdout R²

Featured Wine price from climate & age Holdout R² ≈ 0.79

Start univariate (AGST), add harvest/winter rain, drop collinear age/population terms, validate on holdout R².

lmcorpredictSSE/SST

# Skill demo — wine pricing (synthetic pattern)
wine <- read.csv("wine_demo.csv")
m1 <- lm(Price ~ AGST, data = wine)
m4 <- lm(Price ~ AGST + HarvestRain + WinterRain + Age, data = wine)
summary(m4)

test <- read.csv("wine_holdout.csv")
pred <- predict(m4, newdata = test)
sse <- sum((test$Price - pred)^2)
sst <- sum((test$Price - mean(wine$Price))^2)
1 - sse / sst   # out-of-sample R-squared

~0.83Train adj. R² (full model)

~0.79Holdout R²

AGSTStrongest positive driver

RainHarvest rain negative

Decision takeaway

Growing-season temperature and rainfall dominate price; population proxies add little once age is present. Prefer a sparse, interpretable model for forecasting vintages.

Wins from run differential R²(W~RD) ≈ 0.88

Engineer RD = RS − RA; confirm linearity with scatter; regress wins on RD; then model runs scored/allowed via OBP & SLG.

subsetlmplot

bb <- subset(baseball, Year < 2002)
bb$RD <- bb$RS - bb$RA
wins <- lm(W ~ RD, data = bb)
runs <- lm(RS ~ OBP + SLG, data = bb)   # BA often redundant
summary(wins); summary(runs)

~0.88R² wins vs RD

OBPOutweighs BA for RS

Decision takeaway

Run differential tightly tracks wins; on-base and slugging explain offense better than batting average alone: a classic “process metric” lesson.

NBA points from box-score rates RMSE ≪ mean PTS

Cross-tab wins vs playoffs; model PTS on attempts/assists/rebounds; prune insignificant terms; report RMSE and OOS R².

lmRMSEstepwise prune

nba$PTSdiff <- nba$PTS - nba$oppPTS
pts <- lm(PTS ~ X2PA + X3PA + FTA + AST + ORB + STL, data = nba)
sse <- sum(pts$residuals^2)
rmse <- sqrt(sse / nrow(nba))
pred <- predict(pts, newdata = nba_test)
oos_r2 <- 1 - sum((pred - nba_test$PTS)^2) /
              sum((mean(nba$PTS) - nba_test$PTS)^2)

Decision takeaway

Shot volume and creation stats dominate; defensive rebounds / turnovers often drop out. Always pair R² with RMSE against the scale of mean points.

Cls Classification 3 problems · glm · ROC / AUC

Detect poor healthcare quality Threshold tradeoff clear

Baseline majority class; stratified split; glm(binomial) on visits & narcotics; sweep thresholds for sensitivity/specificity; ROC.

glmsample.splitROCR

library(caTools); library(ROCR)
set.seed(88)
spl <- sample.split(quality$PoorCare, 0.75)
train <- subset(quality, spl); test <- subset(quality, !spl)
fit <- glm(PoorCare ~ OfficeVisits + Narcotics,
           data = train, family = binomial)
p <- predict(fit, type = "response")
table(train$PoorCare, p > 0.5)
perf <- performance(prediction(p, train$PoorCare), "tpr", "fpr")

~75%Baseline (good care)

0.2-0.7Threshold sweep

Decision takeaway

Lower thresholds catch more poor-care cases (higher sensitivity) at the cost of false alarms. Pick the operating point from business cost, not 0.5 by default.

10-year CHD risk (Framingham) AUC ≫ chance

Full-feature glm; confusion matrix vs baseline; emphasize AUC for rare positive class rather than raw accuracy.

glmAUCconfusion

set.seed(1000)
spl <- sample.split(fram$TenYearCHD, 0.65)
train <- subset(fram, spl); test <- subset(fram, !spl)
mod <- glm(TenYearCHD ~ ., data = train, family = binomial)
phat <- predict(mod, newdata = test, type = "response")
table(test$TenYearCHD, phat > 0.5)
auc <- as.numeric(
  performance(prediction(phat, test$TenYearCHD), "auc")@y.values)

Decision takeaway

Accuracy near baseline can hide weak rare-event detection; AUC and calibrated risk scores matter more for screening policy.

State election outcome from polls Beats smart baseline

Impute missing polls (mice); smart baseline via sign(Rasmussen); logistic on PropR / SurveyUSA / DiffCount; temporal train/test.

miceglmsign()

library(mice)
simple <- polling[c("Rasmussen", "SurveyUSA", "PropR", "DiffCount")]
imp <- complete(mice(simple, printFlag = FALSE))
Train <- subset(polling, Year %in% c(2004, 2008))
Test  <- subset(polling, Year == 2012)
mod <- glm(Republican ~ SurveyUSA + DiffCount,
           data = Train, family = binomial)
pred <- predict(mod, newdata = Test, type = "response")

Decision takeaway

Imputation fills gaps in incomplete poll panels; a two-variable logistic model can beat a sign-based poll baseline while staying inspectable.

Tree Trees 3 problems · CART · RF · loss

Predict SCOTUS reverse decisions RF > CART accuracy

Interpretable CART first; RF for lift; caret CV to tune cp; compare accuracy and ROC.

rpartrandomForestcaret CV

library(rpart); library(randomForest); library(caret)
tree <- rpart(Reverse ~ Circuit + Issue + Petitioner +
              Respondent + LowerCourt + Unconst,
              data = Train, method = "class", minbucket = 25)
rf <- randomForest(as.factor(Reverse) ~ ., data = Train,
                    ntree = 200, nodesize = 25)
ctrl <- trainControl(method = "cv", number = 10)
train(Reverse ~ ., data = Train, method = "rpart",
      trControl = ctrl, tuneGrid = expand.grid(.cp = seq(0.01, 0.5, 0.01)))

~66%CART test accuracy

~70%RF test accuracy

Decision takeaway

LowerCourt direction is a dominant split. Forests add accuracy; pruned CART remains the story for stakeholders.

Predict healthcare cost buckets Lower penalty error

Baseline = last year’s bucket; define asymmetric penalty matrix; CART with parms$loss to minimize expensive mistakes.

rpartloss matrixpenalty error

pen <- matrix(c(0,1,2,3,4,
                 2,0,1,2,3,
                 4,2,0,1,2,
                 6,4,2,0,1,
                 8,6,4,2,0), nrow = 5, byrow = TRUE)
tree <- rpart(bucket2009 ~ age + diabetes + heart.failure +
              bucket2008 + reimbursement2008,
              data = train, method = "class", cp = 5e-5,
              parms = list(loss = pen))
pred <- predict(tree, test, type = "class")
sum(as.matrix(table(test$bucket2009, pred)) * pen) / nrow(test)

Decision takeaway

Accuracy can rise while penalty falls if the loss matrix pushes the tree away from under-predicting high-cost patients. Align the objective with dollars.

Boston housing value by location Tree captures non-linearity

Map LAT/LON patterns; compare linear MEDV~LAT+LON with spatial CART; then full-feature LM vs tree SSE on holdout.

rpartlmSSEprp

lin <- lm(MEDV ~ LAT + LON + CRIM + RM + NOX + DIS, data = train)
cart <- rpart(MEDV ~ LAT + LON + CRIM + RM + NOX + DIS, data = train)
sse_lin  <- sum((predict(lin, test)  - test$MEDV)^2)
sse_cart <- sum((predict(cart, test) - test$MEDV)^2)

Decision takeaway

Geography is piecewise, not linear; trees partition space into interpretable value zones when OLS underfits spatial structure.

Text Text 1 problem · tm · DTM

Negative tweet classification Sparse bag-of-words works

Label from sentiment score; tm pipeline (lower, stopwords, stem); sparse DTM; classify with CART/RF.

tmDTMremoveSparseTerms

library(tm)
tweets$Negative <- as.factor(tweets$Avg <= -1)
corp <- Corpus(VectorSource(tweets$Tweet))
corp <- tm_map(corp, content_transformer(tolower))
corp <- tm_map(corp, removePunctuation)
corp <- tm_map(corp, removeWords, c("apple", stopwords("english")))
corp <- tm_map(corp, stemDocument)
dtm <- removeSparseTerms(DocumentTermMatrix(corp), 0.995)
X <- as.data.frame(as.matrix(dtm))

Decision takeaway

Aggressive sparsity control turns noisy tweets into a manageable feature matrix; brand tokens often dominate unless removed upstream.

Clus Cluster 2 problems · hclust · kmeans

Cluster movies by genre flags Genre-coherent groups

Euclidean distance on genre indicators; Ward linkage; cutree; profile clusters with tapply means; recommend within cluster.

disthclustcutreetapply

d <- dist(movies[, genre_cols], method = "euclidean")
hc <- hclust(d, method = "ward.D")
g <- cutree(hc, k = 10)
tapply(movies$Action, g, mean)
tapply(movies$Romance, g, mean)
# nearest neighbors = same cluster titles

Decision takeaway

Clusters recover “action-thriller,” “romance-comedy,” etc. without labels: a lightweight recommender seed before collaborative filtering.

Segment MRI intensity pixels Tissue / lesion contrast

Vectorize image matrix; hierarchical fails at scale; k-means with fixed k; map clusters back to image; transfer centers to tumor scan.

kmeansimage()flexclust

mat <- as.matrix(healthy)
vec <- as.vector(mat)
set.seed(1)
km <- kmeans(vec, centers = 5, iter.max = 1000)
cl <- km$cluster
dim(cl) <- dim(mat)
image(cl, axes = FALSE, col = hcl.colors(5))

Decision takeaway

When pairwise distance matrices explode, switch to k-means; transferring healthy centers to a tumor image highlights anomalous regions.

Viz Viz 1 problem · ggplot2

Crime timing heatmaps (ggplot2) Night / Fri peaks

Parse timestamps; aggregate weekday x hour; ordered factors; geom_line then geom_tile heatmap; separate weekend patterns.

ggplot2strptimegeom_tile

library(ggplot2)
mvt$Date <- strptime(mvt$Date, "%m/%d/%y %H:%M")
mvt$Weekday <- weekdays(mvt$Date)
mvt$Hour <- mvt$Date$hour
dh <- as.data.frame(table(mvt$Weekday, mvt$Hour))
ggplot(dh, aes(Hour, Var1, fill = Freq)) +
  geom_tile() +
  scale_fill_gradient(low = "white", high = "#0062D6")

Decision takeaway

Heatmaps surface patrol-relevant peaks (late evening, Friday) faster than tables - visualization as an analysis product, not decoration.

LP LP 1 problem · lpSolveAPI

Airline seat revenue management Obj ~ $77.4k (2-var)

Decision vars = regular/discount seats; capacity & demand constraints; maximize fare x seats via lpSolveAPI; extend to connecting itineraries.

lpSolveAPImake.lpsolve

library(lpSolveAPI)
lp <- make.lp(3, 2)   # capacity + 2 demand caps
set.column(lp, 1, c(1, 1, 0))
set.column(lp, 2, c(1, 0, 1))
set.constr.type(lp, rep("<=", 3))
set.rhs(lp, c(166, 100, 150))
set.objfn(lp, c(617, 238))
lp.control(lp, sense = "max")
solve(lp)
get.objective(lp); get.variables(lp)  # 100 regular, 66 discount

$77,4082-variable optimum

$120,514Connecting network

Decision takeaway

Protecting high-fare seats under capacity is an optimization problem, not a heuristic. Dual values reveal the shadow price of each seat.

Selected results

Illustrative outcome charts

Representative patterns from the catalog. Synthetic data for portfolio storytelling.

Wine model · fitted vs actual

Holdout-style scatter for a sparse climate model.

ROC operating points

Sensitivity vs 1 − specificity across thresholds (quality-care pattern).