sigest.r

这是核学习的一个基础软件包

setGeneric("sigest", function(x, ...) standardGeneric("sigest"))
setMethod("sigest",signature(x="formula"),
function (x, data=NULL, frac = 0.25, na.action = na.omit, scaled = TRUE){
  call <- match.call()
  m <- match.call(expand.dots = FALSE)
  if (is.matrix(eval(m$data, parent.frame())))
    m$data <- as.data.frame(data)
 ## m$... <- NULL
  m$formula <- m$x
  m$x <- NULL
  m$scaled <- NULL
  m[[1]] <- as.name("model.frame")
  m <- eval(m, parent.frame())
  Terms <- attr(m, "terms")
  attr(Terms, "intercept") <- 0
  x <- model.matrix(Terms, m)
  if (length(scaled) == 1)
    scaled <- rep(scaled, ncol(x))
  if (any(scaled)) {
    remove <- unique(c(which(labels(Terms) %in% names(attr(x, "contrasts"))),
                       which(!scaled)
                       )
                     )
    scaled <- !attr(x, "assign") %in% remove
  }
   ret <- sigest(x, scaled = scaled, frac = frac, na.action = na.action)
   return (ret)
})
setMethod("sigest",signature(x="matrix"),
function (x,
          frac = 0.25,
          scaled    = TRUE,
          na.action = na.omit)
{
    x <- na.action(x)
    
     if (length(scaled) == 1)
      scaled <- rep(scaled, ncol(x))
    if (any(scaled)) {
      co <- !apply(x[,scaled, drop = FALSE], 2, var)
      if (any(co)) {
        scaled <- rep(FALSE, ncol(x))
        warning(paste("Variable(s)",
                      paste("`",colnames(x[,scaled, drop = FALSE])[co],
                            "'", sep="", collapse=" and "),
                      "constant. Cannot scale data.")
                )
      } else {
      xtmp <- scale(x[,scaled])
      x[,scaled] <- xtmp
        }
    }
    
    m <- dim(x)[1]
    n <- floor(frac*m)

    index <- sample(1:m, n)
    temp <- x[index[1:floor(n/2)],,drop=FALSE] - x[index[(ceiling(n/2)+1):n],,drop=FALSE]
    dist <- rowSums(temp*temp)
    ds <- sort(dist[dist!=0])
    sl <- ds[ceiling(0.1*length(ds))]
    su <- ds[ceiling(0.9*length(ds))]

    srange <- 1/(exp((1/2)*log(su/sl)*(1:2))*sl)

    return(srange)
  
})