https://github.com/cran/kohonen
Raw File
Tip revision: 91ea74af6d7aed45cf27b5823332563358651062 authored by Ron Wehrens on 05 January 2007, 00:00:00 UTC
version 2.0.1
Tip revision: 91ea74a
xyf.R
### Version 2.0: codeYs are no longer returned, but codes are a list
### with two elements: X and Y.

"xyf" <- function(data, Y, grid = somgrid(), rlen = 100,
                  alpha = c(0.05, 0.01),
                  radius = quantile(nhbrdist, 0.67) * c(1, -1),
                  xweight = 0.5, contin = !(all(rowSums(Y) == 1)),
                  toroidal = FALSE, n.hood, keep.data = TRUE)
{
  if (!is.numeric(data))
    stop("Argument data should be numeric")
  data <- as.matrix(data)
  
  nd <- nrow(data)
  nx <- ncol(data)

  if (is.vector(Y)) Y <- matrix(Y, ncol=1)
  ny <- ncol(Y)
  
  ng <- nrow(grid$pts)
  xdists <- ydists <- rep(0, ng)  

  starters <- sample(1:nd, ng, replace = FALSE)
  init <- data[starters, , drop = FALSE]
  codes <- init
  if (!contin) {
    ## rescale to .25 - .75 in order to make class transitions easier
    codeYs <- 0.5 + 0.5*(Y[starters,] - 0.5)
  } else {
    codeYs <- Y[starters,]
  }

  if (missing(n.hood)) {
    n.hood <- switch(grid$topo,
                     hexagonal = "circular",
                     rectangular = "square")
  } else {
    n.hood <- match.arg(n.hood, c("circular", "square"))
  }
  grid$n.hood <- n.hood
  nhbrdist <- unit.distances(grid, toroidal)

  if (length(radius) == 1)
    radius <- sort(radius * c(1, -1), decreasing = TRUE)

  changes <- rep(0, rlen*2)

  if (contin) {
    res <- .C("XYF_Eucl",
              data = as.double(data),
              Ys = as.double(Y),
              codes = as.double(codes),
              codeYs = as.double(codeYs),
              nhbrdist = as.double(nhbrdist),
              alpha = as.double(alpha),
              radii = as.double(radius),
              xweight = as.double(xweight),
              changes = as.double(changes),
              xdists = as.double(xdists),
              ydists = as.double(ydists),
              n = as.integer(nd),
              px = as.integer(nx),
              py = as.integer(ny),
              ncodes = as.integer(ng),
              rlen = as.integer(rlen),
              PACKAGE = "kohonen")
  } else {
    res <- .C("XYF_Tani",
              data = as.double(data),
              Ys = as.double(Y),
              codes = as.double(codes),
              codeYs = as.double(codeYs),
              nhbrdist = as.double(nhbrdist),
              alpha = as.double(alpha),
              radius = as.double(radius),
              xweight = as.double(xweight),
              changes = as.double(changes),
              xdists = as.double(xdists),
              ydists = as.double(ydists),
              n = as.integer(nd),
              px = as.integer(nx),
              py = as.integer(ny),
              ncodes = as.integer(ng),
              rlen = as.integer(rlen),
              PACKAGE = "kohonen")
  }

  changes <- matrix(res$changes, ncol=2)
  colnames(changes) <- c("X", "Y")
  codes <- list(X = matrix(res$codes, nrow(init), ncol(init)),
                Y = matrix(res$codeYs, ng, ny))
  colnames(codes$Y) <- colnames(Y)

  if (keep.data) {
    mapping <- map.kohonen(list(codes = codes),
                           newdata = data,
                           whatmap = 1)
    
    structure(list(data = data, Y = Y, contin = contin,
                   grid = grid, codes = codes,
                   changes = changes, alpha = alpha,
                   radius = radius, toroidal = toroidal,
                   unit.classif = mapping$unit.classif,
                   distances = mapping$distances, method="xyf"),
              class = "kohonen")
  } else {
    structure(list(contin = contin, grid = grid, codes = codes,
                   changes = changes, alpha = alpha,
                   radius = radius, toroidal = toroidal, method="xyf"), 
              class = "kohonen")
  }
}

back to top