inst/doc/NNSvignette_07_Clustering_and_Regression.R

In NNS: Nonlinear Nonparametric Statistics

## ----setup, include=FALSE, message=FALSE--------------------------------------
knitr::opts_chunk$set(echo = TRUE)
library(NNS)
options(mc.cores = 1)
RcppParallel::setThreadOptions(numThreads = 1)
Sys.setenv("OMP_THREAD_LIMIT" = 1)

## ----setup2, message=FALSE, warning=FALSE-------------------------------------
library(NNS)
require(knitr)
require(rgl)

## ----linear-------------------------------------------------------------------
x = seq(-5, 5, .05); y = x ^ 3

for(i in 1 : 4){NNS.part(x, y, order = i, Voronoi = TRUE, obs.req = 0)}

## ----x part,results='hide'----------------------------------------------------
for(i in 1 : 4){NNS.part(x, y, order = i, type = "XONLY", Voronoi = TRUE)}

## ----res2, echo=FALSE---------------------------------------------------------
NNS.part(x,y,order = 4, type = "XONLY")

## ----depreg},results='hide'---------------------------------------------------
for(i in 1 : 3){NNS.part(x, y, order = i, obs.req = 0, Voronoi = TRUE, type = "XONLY") ; NNS.reg(x, y, order = i, ncores = 1)}

## ----nonlinear,fig.width=5,fig.height=3,fig.align = "center"------------------
NNS.reg(x, y, ncores = 1)

## ----nonlinear multi,fig.width=5,fig.height=3,fig.align = "center"------------
f = function(x, y) x ^ 3 + 3 * y - y ^ 3 - 3 * x
y = x ; z <- expand.grid(x, y)
g = f(z[ , 1], z[ , 2])
NNS.reg(z, g, order = "max", plot = FALSE, ncores = 1)

## ----nonlinear_class,fig.width=5,fig.height=3,fig.align = "center", message = FALSE----
NNS.reg(iris[ , 1 : 4], iris[ , 5], dim.red.method = "cor", location = "topleft", ncores = 1)$equation

## ----nonlinear_class2,fig.width=5,fig.height=3,fig.align = "center", message = FALSE, echo=FALSE----
a = NNS.reg(iris[ , 1 : 4], iris[ , 5], dim.red.method = "cor", location = "topleft", ncores = 1, plot = FALSE)$equation

## ----nonlinear class threshold,fig.width=5,fig.height=3,fig.align = "center"----
NNS.reg(iris[ , 1 : 4], iris[ , 5], dim.red.method = "cor", threshold = .75, location = "topleft", ncores = 1)$equation

## ----nonlinear class threshold 2,fig.width=5,fig.height=3,fig.align = "center", echo=FALSE----
a = NNS.reg(iris[ , 1 : 4], iris[ , 5], dim.red.method = "cor", threshold = .75, location = "topleft", ncores = 1, plot = FALSE)$equation

## ----final,fig.width=5,fig.height=3,fig.align = "center"----------------------
NNS.reg(iris[ , 1 : 4], iris[ , 5], dim.red.method = "cor", threshold = .75, point.est = iris[1 : 10, 1 : 4], location = "topleft", ncores = 1)$Point.est

## ----class,fig.width=5,fig.height=3,fig.align = "center", message=FALSE-------
NNS.reg(iris[ , 1 : 4], iris[ , 5], type = "CLASS", point.est = iris[1 : 10, 1 : 4], location = "topleft", ncores = 1)$Point.est

## ----stack,fig.width=5,fig.height=3,fig.align = "center", message=FALSE, eval=FALSE----
# NNS.stack(IVs.train = iris[ , 1 : 4],
#           DV.train = iris[ , 5],
#           IVs.test = iris[1 : 10, 1 : 4],
#           dim.red.method = "cor",
#           obj.fn = expression( mean(round(predicted) == actual) ),
#           objective = "max", type = "CLASS",
#           folds = 1, ncores = 1)

## ----stackevalres, eval = FALSE-----------------------------------------------
# Method 2 fold 1/1: generating 4 cumulative projections
# Method 2 fold 1/1: evaluating 4 unique candidates
# Method 2 fold 1/1 complete
# Current dimension count = 1 | OOF eval(obj.fn) = 0.944444 | Iterations remaining = 3
# Current dimension count = 2 | OOF eval(obj.fn) = 0.972222 | Iterations remaining = 2
# Current dimension count = 3 | OOF eval(obj.fn) = 0.944444 | Iterations remaining = 1
# Current dimension count = 4 | OOF eval(obj.fn) = 0.916667 | Iterations remaining = 0
# Method 1 fold 1/1: preparing fold design
# Method 1 fold 1/1: building partitions
# RPM rows = 29; validation rows = 36
#   small candidates = 1...12
#   early stopping at k = 4
#   limit candidate = all (k = 29), score = 0.333333
# Best Method 1 candidate: k = 2, score = 0.972222
# Generating final estimates
# $OBJfn.reg
#         2
# 0.9722222
# 
# $NNS.reg.n.best
# [1] 2
# 
# $probability.threshold
# [1] 0.48
# 
# $OBJfn.dim.red
# [1] 0.9722222
# 
# $NNS.dim.red.threshold
# [1] 0.9354305
# 
# $reg
#  [1] 1 1 1 1 1 1 1 1 1 1
# 
# $reg.pred.int
# NULL
# 
# $dim.red
#  [1] 1 1 1 1 1 1 1 1 1 1
# 
# $dim.red.pred.int
# NULL
# 
# $stack
#  [1] 1 1 1 1 1 1 1 1 1 1
# 
# $pred.int
# NULL
# 
# $weights
#     reg dim.red
#     0.5     0.5
# 
# $class.levels
# [1] "setosa"     "versicolor" "virginica"

## ----stack2, message = FALSE,fig.width=5,fig.height=3,fig.align = "center",results='hide', eval = FALSE----
# set.seed(123)
# x = rnorm(100); y = rnorm(100)
# 
# nns.params = NNS.stack(IVs.train = cbind(x, x),
#                         DV.train = y,
#                         method = 1, ncores = 1)

## ----stack2optim, echo = FALSE------------------------------------------------
set.seed(123)
x = rnorm(100); y = rnorm(100)

nns.params = list()
nns.params$NNS.reg.n.best = 100

## ----stack2res, fig.width=5,fig.height=3,fig.align = "center",results='hide'----
NNS.reg(cbind(x, x), y, 
        n.best = nns.params$NNS.reg.n.best,
        point.est = cbind(x, x), 
        residual.plot = TRUE,  
        ncores = 1, confidence.interval = .95)

## ----smooth, fig.width=5,fig.height=3,fig.align = "center",results='hide'-----
NNS.reg(x, y, smooth = TRUE)

## ----uniimpute, eval=FALSE----------------------------------------------------
# set.seed(123)
# 
# # Univariate predictor with nonlinear signal
# n <- 400
# x <- sort(runif(n, -3, 3))
# y <- sin(x) + 0.2 * x^2 + rnorm(n, 0, 0.25)
# 
# # Induce ~25% MCAR missingness in y
# miss <- rbinom(n, 1, 0.25) == 1
# y_mis <- y
# y_mis[miss] <- NA
# 
# # ---- Increasing dimensions trick ----
# # Duplicate x so the distance operates in a 2D space: cbind(x, x).
# # This sharpens nearest-neighbor selection even in a nominally univariate setting.
# x2_train <- cbind(x[!miss], x[!miss])
# x2_miss  <- cbind(x[miss],  x[miss])
# 
# # 1-NN donor imputation with NNS.reg
# y_hat_uni <- NNS::NNS.reg(
#   x         = x2_train,             # predictors (duplicated x)
#   y         = y[!miss],             # observed responses
#   point.est = x2_miss,              # rows to impute
#   order     = "max",                # dependence-maximizing order
#   n.best    = 1,                    # 1-NN donor
#   plot      = FALSE
# )$Point.est
# 
# # Fill back
# y_completed_uni <- y_mis
# y_completed_uni[miss] <- y_hat_uni
# 
# # Plot observed vs imputed (NNS 1-NN)
# plot(x, y, pch = 1, col = "steelblue", cex = 1.5, lwd = 2,
#      xlab = "x", ylab = "y", main = "NNS 1-NN Imputation")
# points(x[miss], y_hat_uni, col = "red", pch = 15, cex = 1.3)
# 
# legend("topleft",
#        legend = c("Observed", "Imputed (NNS 1-NN)"),
#        col    = c("steelblue", "red"),
#        pch    = c(1, 15),
#        pt.lwd = c(2, NA),
#        bty    = "n")

## ----multiimpute, eval=FALSE--------------------------------------------------
# set.seed(123)
# 
# # Multivariate predictors with nonlinear & interaction structure
# n <- 800
# X <- cbind(
#   x1 = rnorm(n),
#   x2 = runif(n, -2, 2),
#   x3 = rnorm(n, 0, 1)
# )
# 
# f <- function(x1, x2, x3) 1.1*x1 - 0.8*x2 + 0.5*x3 + 0.6*x1*x2 - 0.4*x2*x3 + 0.3*sin(1.3*x1)
# y <- f(X[,1], X[,2], X[,3]) + rnorm(n, 0, 0.4)
# 
# # Induce ~30% MCAR missingness in y
# miss <- rbinom(n, 1, 0.30) == 1
# y_mis <- y
# y_mis[miss] <- NA
# 
# # Training (observed) vs rows to impute
# X_obs <- X[!miss, , drop = FALSE]
# y_obs <- y[!miss]
# X_mis <- X[ miss, , drop = FALSE]
# 
# # 1-NN donor imputation with NNS.reg
# y_hat_mv <- NNS::NNS.reg(
#   x         = X_obs,     # all observed predictors
#   y         = y_obs,     # observed responses
#   point.est = X_mis,     # rows to impute
#   order     = "max",     # dependence-maximizing order
#   n.best    = 1,         # 1-NN donor
#   plot      = FALSE
# )$Point.est
# 
# # Completed vector
# y_completed_mv <- y_mis
# y_completed_mv[miss] <- y_hat_mv
# 
# # Plot observed vs imputed (multivariate, NNS 1-NN)
# plot(seq_along(y), y,
#      pch = 1, col = "steelblue", cex = 1.5, lwd = 2,
#      xlab = "Observation index", ylab = "y",
#      main = "NNS 1-NN Multivariate Imputation")
# 
# # Overlay imputed values
# points(which(miss), y_hat_mv, pch = 15, col = "red", cex = 1.2)
# 
# # Legend
# legend("topleft",
#        legend = c("Observed", "Imputed (NNS 1-NN)"),
#        col    = c("steelblue", "red"),
#        pch    = c(1, 15),
#        pt.lwd = c(2, NA),
#        bty    = "n")