[R] kronecker(... , make.dimnames=TRUE)

From: Robin Hankin <r.hankin_at_noc.soton.ac.uk>
Date: Thu 08 Dec 2005 - 21:42:55 EST


Hi

I'm using kronecker() with a matrix and a vector. I'm interested in the column names that kronecker() returns:

> a <- matrix(1:9,3,3)
> rownames(a) <- letters[1:3]
> colnames(a) <- LETTERS[1:3]
> b <- c(x=1,y=2)
> kronecker(a,b,make.dimnames=TRUE)

  1. B: C: a:x 1 4 7 a:y 2 8 14 b:x 2 5 8 b:y 4 10 16 c:x 3 6 9 c:y 6 12 18
    >

The column names are undesirable for me as I don't want the extra colon.

The following code is a version of kronecker() that does not exhibit this behaviour.
It tests nchar() of the dimnames and sets the separator to ":" or "" depending
on the existence of a nontrivial string.

"kronecker" <-

   function (X, Y, FUN = "*", make.dimnames = FALSE, ...) {

   X <- as.array(X)
   Y <- as.array(Y)
   if (make.dimnames) {

     dnx <- dimnames(X)
     dny <- dimnames(Y)

   }
   dX <- dim(X)
   dY <- dim(Y)
   ld <- length(dX) - length(dY)
   if (ld < 0)
     dX <- dim(X) <- c(dX, rep.int(1, -ld))
   else if (ld > 0)
     dY <- dim(Y) <- c(dY, rep.int(1, ld))
   opobj <- outer(X, Y, FUN, ...)
   dp <- as.vector(t(matrix(1:(2 * length(dX)), ncol = 2)[,
                                                  2:1]))
   opobj <- aperm(opobj, dp)
   dim(opobj) <- dX * dY
   if (make.dimnames && !(is.null(dnx) && is.null(dny))) {
     if (is.null(dnx))
       dnx <- vector("list", length(dX))
     else if (ld < 0)
       dnx <- c(dnx, vector("list", -ld))
     tmp <- which(sapply(dnx, is.null))
     dnx[tmp] <- lapply(tmp, function(i) rep.int("", dX[i]))
     if (is.null(dny))
       dny <- vector("list", length(dY))
     else if (ld > 0)
       dny <- c(dny, vector("list", ld))
     tmp <- which(sapply(dny, is.null))
     dny[tmp] <- lapply(tmp, function(i) rep.int("", dY[i]))
     k <- length(dim(opobj))
     dno <- vector("list", k)
     for (i in 1:k) {
#  !!!!!   !!!!!  NEW TEXT STARTS  !!!!!!
       if(any(nchar(dnx[[i]])>0) & any(nchar(dny[[i]])>0)){
         sepchar <- ":"
       } else {
         sepchar <- ""
       }
       tmp <- outer(dnx[[i]], dny[[i]], FUN = "paste", sep = sepchar)
#  !!!! NEW TEXT ENDS !!!!!
#      tmp <- outer(dnx[[i]], dny[[i]], FUN = "paste", sep = ":")
       dno[[i]] <- as.vector(t(tmp))
     }
     dimnames(opobj) <- dno

   }
   opobj
}

Then

> kronecker(a,b,make=T)

      A B C

a:x  1  4  7
a:y  4 16 28
b:x  2  5  8
b:y  8 20 32
c:x  3  6  9
c:y 12 24 36

>

as desired.

comments anyone?

--
Robin Hankin
Uncertainty Analyst
National Oceanography Centre, Southampton
European Way, Southampton SO14 3ZH, UK
  tel  023-8059-7743

______________________________________________
R-help@stat.math.ethz.ch mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide! http://www.R-project.org/posting-guide.html
Received on Thu Dec 08 21:50:43 2005

This archive was generated by hypermail 2.1.8 : Fri 03 Mar 2006 - 03:41:34 EST