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

[Gabor Grothendieck]

Not sure whether or not this is a good idea but note that
the techniques discussed in the recent thread:

	"Change labels of x-axes in Plot of stl() function?"

can be used here too. e.g.

library(proto)
kronecker <- function(...) {
	outer <- function(x, y, FUN, sep) {
		sepchar <- if(any(nchar(x)>0) & any(nchar(y)>0))  ":" else ""
		base::outer(x, y, FUN, sep = sepchar)
	}
	with( proto(kronecker = base:::kronecker), kronecker(...) )
}

# test
a <- structure(1:6, .Dim = 3:2, .Dimnames = list(letters[1:3], LETTERS[1:2]))
b <- c(x=1,y=2)
kronecker(a,b,make.dimnames=TRUE)

or slightly longer and somewhat awkward since it involves explicit
manipulation of environments (but with the advantage of no dependence
on another package):

kronecker <- function(...) {
	outer <- function(x, y, FUN, sep) {
		sepchar <- if(any(nchar(x)>0) & any(nchar(y)>0))  ":" else ""
		base::outer(x, y, FUN, sep = sepchar)
	}
	kronecker <- base::kronecker
	environment(kronecker) <- environment()
	kronecker(...)
}



On 12/8/05, Robin Hankin <r.hankin at noc.soton.ac.uk> wrote:
> 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)
>     A: 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 at 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
>