kernels.r

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

  if(is.matrix(y))
    {
      n2 <- dim(y)[1]
      if(is.vector(z))
        {
          if(!length(z) == n2) stop("vector z length must be equal to y rows")
          z <- matrix(z,n2,1)
        }
      if(!dim(z)[1]==n2)
        stop("z length must equal y rows")
      res <- matrix(rep(0,dim(z)[2]*n), ncol = dim(z)[2])
 
       if(nblocks > 0)
        for(i in 1:nblocks)
          {
            upperl = upperl + blocksize
            res[lowerl:upperl,] <- ((scale*x[lowerl:upperl,]%*%t(y) + offset)^degree)%*%z
            lowerl <- upperl + 1
          }
      if(lowerl <= n)
        res[lowerl:n,] <- ((scale*x[lowerl:n,]%*%t(y) + offset)^degree)%*%z
    }
  return(res)
} 
setMethod("kernelMult",signature(kernel="polykernel", x="matrix"),kernelMult.polykernel)


kernelMult.tanhkernel <- function(kernel, x, y=NULL, z, blocksize = 256)
{
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must be a matrix or a vector")
  scale <- kpar(kernel)$scale
  offset <- kpar(kernel)$offset
  n <- dim(x)[1]
  m <- dim(x)[2]
  nblocks <- floor(n/blocksize)
  lowerl <- 1
  upperl <- 0
 

  if (is.null(y))
    {
      if(is.vector(z))
        {
          if(!length(z) == n) stop("vector z length must be equal to x rows")
          z <- matrix(z,n,1)
        }
      if(!dim(z)[1]==n)
        stop("z rows must equal x rows")
      res <- matrix(rep(0,dim(z)[2]*n), ncol = dim(z)[2])
      if(nblocks > 0)
        for(i in 1:nblocks)
          {
            upperl = upperl + blocksize
            res[lowerl:upperl,] <- tanh(scale*x[lowerl:upperl,]%*%t(x) + offset) %*% z
            lowerl <- upperl + 1
          }
      if(lowerl <= n)
        res[lowerl:n,] <- tanh(scale*x[lowerl:n,]%*%t(x) +offset)%*%z
    }
  if(is.matrix(y))
    {
      n2 <- dim(y)[1]
      if(is.vector(z))
        {
          if(!length(z) == n2) stop("vector z length must be equal to y rows")
          z <- matrix(z,n2,1)
        }
      if(!dim(z)[1]==n2)
        stop("z length must equal y rows")
      res <- matrix(rep(0,dim(z)[2]*n), ncol = dim(z)[2])
 
       if(nblocks > 0)
        for(i in 1:nblocks)
          {
            upperl = upperl + blocksize
            res[lowerl:upperl,] <- tanh(scale*x[lowerl:upperl,]%*%t(y) + offset)%*%z
            lowerl <- upperl + 1
          }
      if(lowerl <= n)
        res[lowerl:n,] <- tanh(scale*x[lowerl:n,]%*%t(y) + offset)%*%z
    }
  return(res)
} 
setMethod("kernelMult",signature(kernel="tanhkernel", x="matrix"),kernelMult.tanhkernel)


kernelMult.vanillakernel <- function(kernel, x, y=NULL, z, blocksize = 256)
{
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must be a matrix or a vector")
  n <- dim(x)[1]
  m <- dim(x)[2]
  nblocks <- floor(n/blocksize)
  lowerl <- 1
  upperl <- 0
 

  if (is.null(y))
    {
      if(is.vector(z))
        {
          if(!length(z) == n) stop("vector z length must be equal to x rows")
          z <- matrix(z,n,1)
        }
      if(!dim(z)[1]==n)
        stop("z rows must equal x rows")
      res <- t(crossprod((x%*%z),t(a)))
    }
  if(is.matrix(y))
    {
      n2 <- dim(y)[1]
      if(is.vector(z))
        {
          if(!length(z) == n2) stop("vector z length must be equal to y rows")
          z <- matrix(z,n2,1)
        }
      if(!dim(z)[1]==n2)
        stop("z length must equal y rows")
      res <- t(crossprod((y%*%z),t(x)))
    }
  return(res)
} 
setMethod("kernelMult",signature(kernel="vanillakernel", x="matrix"),kernelMult.vanillakernel)

# kernelPol returns the scalar product of x y componentwise with polarities
# of z and k 

kernelPol <- function(kernel, x, y=NULL, z, k=NULL)
{
  if(!is.matrix(x)) stop("x must be a matrix")
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must ba a matrix or a vector")
  n <- nrow(x)
   if(is.vector(z))
      {
        if(!length(z)==n) stop("vector z length must be equal to x rows")
        z<-matrix(z,n,1)
      }
  if(!dim(z)[1]==n)
    stop("z must have the length equal to x colums")
  res1 <- matrix(rep(0,n*n), ncol = n)
  if (is.null(y))
    {
      for(i in 1:n)
        {
          for(j in 1:n)
            {
              res1[i,j] <- kernel(x[i,],x[j,])*z[j]*z[i]
      }
    }
  }
  if (is.matrix(x) && is.matrix(y)){
    m <- dim(y)[1]
    if(is.null(k)) stop("k not specified!")
    if(is.vector(k))
      {
        if(!length(k)==m) stop("vector k length must be equal to x rows")
        k<-as.matrix(k,n,1)
      }
    if(!dim(x)[2]==dim(y)[2])
      stop("matrixes must have the same number of columns")
    if(!dim(z)[2]==dim(k)[2])
      stop("z and k vectors must have the same number of columns")
    if(!dim(x)[1]==dim(z)[1])
      stop("z and x must have the same number of rows")
    if(!dim(y)[1]==dim(k)[1])
      stop("y and k must have the same number of rows")
    
    for(i in 1:n)
      {
        for(j in 1:m)
          {
            res1[i,j] <- kernel(x[i,],y[j,])*z[i]*k[j]
          }
      }
  }
  return(res1)
}

setGeneric("kernelPol", function(kernel, x, y=NULL, z, k = NULL) standardGeneric("kernelPol"))


kernelPol.rbfkernel <- function(kernel, x, y=NULL, z, k=NULL)
{
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix or NULL")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must be a matrix or a vector")
  if(!is.matrix(k)&&!is.vector(k)&&!is.null(k)) stop("k must be a matrix or a vector")
  sigma <- kpar(kernel)$sigma
  n <- dim(x)[1]
  dota <- rowSums(x*x)/2
  if(is.vector(z))
    {
      if(!length(z)==n) stop("vector z length must be equal to x rows")
      z<-matrix(z,n,1)
    }
  if(!dim(z)[1]==n)
    stop("z must have the length equal to x colums")
  if (is.null(y))
    {
      if(is.matrix(z)&&!dim(z)[1]==n)
       stop("z must have size equal to x colums")
      res <- crossprod(t(x))
      for (i in 1:n)
        res[i,] <- z[i,]*(exp(2*sigma*(res[i,] - dota - rep(dota[i],n)))*z)
      return(res)
    }
  if (is.matrix(y))
    {
      if(is.null(k)) stop("k not specified!")
      m <- dim(y)[1]
      if(!dim(k)[1]==m)
        stop("k must have equal rows to y")
      if(is.vector(k))
        {
          if(!length(k)==m) stop("vector k length must be equal to x rows")
          k<-matrix(k,n,1)
        }
      if(!dim(x)[2]==dim(y)[2])
        stop("matrixes must have the same number of columns")
      dotb <- rowSums(y*y)/2
      res <- x%*%t(y)
      for( i in 1:m)#2*sigma or sigma
        res[,i]<- k[i,]*(exp(2*sigma*(res[,i] - dota - rep(dotb[i],n)))*z)
      return(res)
    }
}
setMethod("kernelPol",signature(kernel="rbfkernel", x="matrix"),kernelPol.rbfkernel)

kernelPol.polykernel <- function(kernel, x, y=NULL, z, k=NULL)
{
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix or NULL")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must be a matrix or a vector")
  if(!is.matrix(k)&&!is.vector(k)&&!is.null(k)) stop("k must be a matrix or a vector")
  degree <- kpar(kernel)$degree
  scale <- kpar(kernl)$scale
  offset <- kpar(kernel)$offset
  n <- dim(x)[1]
  if(is.vector(z))
    {
      if(!length(z)==n) stop("vector z length must be equal to x rows")
      z<-matrix(z,n,1)
    }
  if(!dim(z)[1]==n)
    stop("z must have the length equal to x colums")
  if (is.null(y))
    {
      if(is.matrix(z)&&!dim(z)[1]==n)
       stop("z must have size equal to x colums")
      for (i in 1:n)
        res <- z*(((scale*crossprod(t(x))+offset)^degree)*z)
      return(res)
    }
  if (is.matrix(y))
    {
      if(is.null(k)) stop("k not specified!")
      m <- dim(y)[1]
      if(!dim(k)[1]==m)
        stop("k must have equal rows to y")
      if(is.vector(k))
        {
          if(!length(k)==m) stop("vector k length must be equal to x rows")
          k<-matrix(k,n,1)
        }
      if(!dim(x)[2]==dim(y)[2])
        stop("matrixes must have the same number of columns")
      for( i in 1:m)#2*sigma or sigma
        res<- k*(((scale*x%*%t(y) + offset)^degree)*z)
      return(res)
    }
}
setMethod("kernelPol",signature(kernel="polykernel", x="matrix"),kernelPol.polykernel)


kernelPol.tanhkernel <- function(kernel, x, y=NULL, z, k=NULL)
{
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix or NULL")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must be a matrix or a vector")
  if(!is.matrix(k)&&!is.vector(k)&&!is.null(k)) stop("k must be a matrix or a vector")
  scale <- kpar(kernel)$scale
  offset <- kpar(kernel)$offset
  n <- dim(x)[1]
  if(is.vector(z))
    {
      if(!length(z)==n) stop("vector z length must be equal to x rows")
      z<-matrix(z,n,1)
    }
  if(!dim(z)[1]==n)
    stop("z must have the length equal to x colums")
  if (is.null(y))
    {
      if(is.matrix(z)&&!dim(z)[1]==n)
       stop("z must have size equal to x colums")
      for (i in 1:n)
        res <- z*(tanh(scale*crossprod(t(x))+offset)*z)
      return(res)
    }
  if (is.matrix(y))
    {
      if(is.null(k)) stop("k not specified!")
      m <- dim(y)[1]
      if(!dim(k)[1]==m)
        stop("k must have equal rows to y")
      if(is.vector(k))
        {
          if(!length(k)==m) stop("vector k length must be equal to x rows")
          k<-matrix(k,n,1)
        }
      if(!dim(x)[2]==dim(y)[2])
        stop("matrixes must have the same number of columns")
      for( i in 1:m)#2*sigma or sigma
        res<- k*(tanh(scale*x%*%t(y) + offset)*z)
      return(res)
    }
}
setMethod("kernelPol",signature(kernel="tanhkernel", x="matrix"),kernelPol.tanhkernel)


kernelPol.vanillakernel <- function(kernel, x, y=NULL, z, k=NULL)
{
  if(!is.matrix(y)&&!is.null(y)) stop("y must be a matrix or NULL")
  if(!is.matrix(z)&&!is.vector(z)) stop("z must be a matrix or a vector")
  if(!is.matrix(k)&&!is.vector(k)&&!is.null(k)) stop("k must be a matrix or a vector")
  sigma <- kpar(kernel)$sigma
  n <- dim(x)[1]
  if(is.vector(z))
    {
      if(!length(z)==n) stop("vector z length must be equal to x rows")
      z<-matrix(z,n,1)
    }
  if(!dim(z)[1]==n)
    stop("z must have the length equal to x colums")
  if (is.null(y))
    {
      if(is.matrix(z)&&!dim(z)[1]==n)
       stop("z must have size equal to x colums")
      for (i in 1:n)
        res <- z*(crossprod(t(x))*z)
      return(res)
    }
  if (is.matrix(y))
    {
      if(is.null(k)) stop("k not specified!")
      m <- dim(y)[1]
      if(!dim(k)[1]==m)
        stop("k must have equal rows to y")
      if(is.vector(k))
        {
          if(!length(k)==m) stop("vector k length must be equal to x rows")
          k<-matrix(k,n,1)
        }
      if(!dim(x)[2]==dim(y)[2])
        stop("matrixes must have the same number of columns")
      for( i in 1:m)
        res<- k*(x%*%t(y)*z)
      return(res)
    }
}
setMethod("kernelPol",signature(kernel="vanillakernel", x="matrix"),kernelPol.vanillakernel)

setMethod("show","kernel",
          function(object)
          {
            switch(class(object),
                   "rbfkernel" = cat(paste("Gaussian Radial Basis kernel function.", "\n","Hyperparameter :" ,"sigma = ", kpar(object)$sigma,"\n")),
                   "tanhkernel" = cat(paste("Hyperbolic Tangent kernel function.", "\n","Hyperparameters :","scale = ", kpar(object)$scale," offset = ", kpar(object)$offset,"\n")),
                   "polykernel" = cat(paste("Polynomial kernel function.", "\n","Hyperparameters :","degree = ",kpar(object)$degree," scale = ", kpar(object)$scale," offset = ", kpar(object)$offset,"\n")),
                   "vanillakernel" = cat(paste("Linear (vanilla) kernel function.", "\n"))
                     )
                 })