https://github.com/cran/kohonen
Tip revision: f55147dbc00e909dd2d71d60e2931790055ce14d authored by Ron Wehrens on 15 March 2017, 12:14:29 UTC
version 3.0.0
version 3.0.0
Tip revision: f55147d
map.R
"map" <- function(x, ...)
{
UseMethod("map")
}
map.kohonen <- function(x,
newdata,
whatmap = NULL,
user.weights = NULL,
maxNA.fraction = NULL, ...)
{
## ##########################################################################
## Get relevant info from kohonen object
codes <- x$codes
nlayers <- length(codes)
if (missing(newdata) & !is.null(x$data)) newdata <- x$data
if (is.matrix(newdata)) newdata <- list(newdata) ## service to the user
if (is.null(user.weights)) {
user.weights <- x$user.weights
useTrainingWeights <- TRUE
} else {
useTrainingWeights <- FALSE
}
if (length(user.weights) == 1) user.weights <- rep(1, nlayers)
if (is.null(whatmap)) whatmap <- x$whatmap
if (is.null(maxNA.fraction)) maxNA.fraction <- x$maxNA.fraction
dist.ptrs <- getDistancePointers(x$dist.fcts, maxNA.fraction = maxNA.fraction)
## ##########################################################################
## Check data
newdata <- check.data(newdata)
nachecks <- check.data.na(newdata, maxNA.fraction = maxNA.fraction)
newdata <- remove.data.na(newdata, nachecks)
## ##########################################################################
## Check whatmap
whatmap <- check.whatmap(newdata, whatmap)
if (useTrainingWeights & any(user.weights[whatmap] < 1e-8))
warning("Mapping new data using data layers not involved in training")
## ##########################################################################
## Apply whatmap
newdata <- newdata[whatmap]
dist.ptrs <- dist.ptrs[whatmap]
codes <- codes[whatmap]
user.weights.orig <- user.weights
user.weights <- user.weights[whatmap]
if (length(whatmap) == 1) {
user.weights <- 1
} else {
if (sum(user.weights >= 1e-8) == 0)
stop("Only user.weights of zero given")
}
## ##########################################################################
## Final preparations
nvars <- sapply(codes, ncol)
ncodes <- nrow(codes[[1]])
nobjects <- nrow(newdata[[1]])
nNA <- getnNA(newdata, maxNA.fraction, nobjects)
newdata <- matrix(unlist(newdata), ncol=nobjects, byrow=TRUE)
codes <- matrix(unlist(codes), ncol=ncodes, byrow=TRUE)
weights <- user.weights * x$distance.weights[whatmap]
weights <- weights / sum(weights)
## ##########################################################################
## Go!
res <- RcppMap(data = newdata,
numVars = nvars,
numNAs = nNA,
codes = codes,
weights = weights,
distanceFunctions = dist.ptrs)
if (length(nachecks[[1]]) > 0) {
unit.classif <- distances <- rep(NA, nobjects + length(nachecks[[1]]))
unit.classif[ -nachecks[[1]] ] <- res$winners + 1
distances[ -nachecks[[1]] ] <- res$unitdistances
list(unit.classif = unit.classif,
distances = distances,
whatmap = whatmap,
user.weights = user.weights.orig)
} else {
list(unit.classif = res$winners + 1,
distances = res$unitdistances,
whatmap = whatmap,
user.weights = user.weights.orig)
}
}