R help - Jan 2014 - modify subset of array in list in a function

Hi,

I am trying to implement a function that would allow functional
transformations of posterior simulations (useful in posterior predictive
checks after MCMC, eg in Stan).

A posterior simulation is a list of vectors and arrays. Usually, one
uses loops to transform it, but that's error prone. I was thinking of
ending up with an interface like this (toy example):

--8<---------------cut here---------------start------------->8---
posterior <- list(a=1:3,b=matrix(4:9,nrow=3))

map_posterior(posterior, function(a,b) {
  list(d=a*sum(b))
})        # should be equivalent to list(d=posterior$a + rowSums(posterior$b))
--8<---------------cut here---------------end--------------->8---

I started coding it: I make an arglist for do.call, matching names,
then deconstruct the value and save it where it belongs. But the last
part is giving me trouble, since in R calls are by value, not reference,
so I don't end up modifying the original array in the code below (when
set_subarray is called):

--8<---------------cut here---------------start------------->8---
leading_dimension <- function(array) {
  if (is.vector(array))
    length(array)
  else
    dim(array)[1]
}

common_leading_dimension <- function(array_list) {
  ## if all leading dimensions are the same, return it, otherwise signal an
error
  length_ <- length(array_list)
  stopifnot(length_ > 0)
  ld <- leading_dimension(array_list[[1]])
  if (length_ > 1)
    for (i in 2:length_)
      stopifnot(leading_dimension(array_list[[i]])==ld)
  ld
}

subarray <- function(array, index) {
  ## equivalent to array[index, , ...]
  if (is.vector(array))
    array[index]
  else {
    rank_ <- length(dim(array))
    stopifnot(rank_ >= 1)
    do.call("[",c(list(array,index),rep(TRUE,rank_-1)))
  }
}

set_subarray <- function(value, array, index) {
  ## equivalent to array[index, , ...] <- value
  if (is.vector(array))
    array[index] <- value
  else {
    rank_ <- length(dim(array))
    stopifnot(rank_ >= 1)
    do.call("[<-",c(list(array,value,index),rep(TRUE,rank_-1)))
  }
}

map_posterior <- function(posterior,f) {
  names_ <- names(posterior)
  ld <- common_leading_dimension(posterior)
  result <- NULL
  for (index in 1:ld) {
    row_args <- Map(function(name) subarray(posterior[[name]],index),names_)
    names(row_args) <- names_
    row_result <- do.call(f,row_args)
    if (is.null(result)) {
      result <- Map(function(value) {
        dims <- if(is.vector(value)) {
          length_ <- length(value)
          if (length_ == 1)
            NULL
          else
            length_
        } else {
          dim(value)
        }
        array(NA,c(ld,dims))
      },row_result)
      names(result) <- names(row_result)
    }
    Map(function(row_result_name,row_result_value) {
      set_subarray(row_result_value,result[[row_result_name]],index)
    })
  }
  result
}
--8<---------------cut here---------------end--------------->8---

Any help or hints on how to do this would be appreciated, including
alternative approaches of doing/programming the same thing.

Best,

Tamas

> But the last
> part is giving me trouble, since in R calls are by value, not reference,
> so I don't end up modifying the original array in the code below (when
> set_subarray is called):
You can get this effect with R-like syntax by
   (a) changing set_subarray to `set_subarray<-`, putting the 'value'
argument
         at the end and calling it as 'subarray(array,index)  <-
value' and
   (b) having the function return the modified array

 Here is an untested version of your function with those changes
`subarray<-`  <- function(array, index, value) { # (a) new name and
argument list order
  ## equivalent to array[index, , ...] <- value
  if (is.vector(array))
    array[index] <- value
  else {
    rank_ <- length(dim(array))
    stopifnot(rank_ >= 1)
    do.call("[<-",c(list(array,value,index),rep(TRUE,rank_-1)))
  }
  array # (b) new return value
}

Bill Dunlap
TIBCO Software
wdunlap tibco.com

> -----Original Message-----
> From: r-help-bounces at r-project.org [mailto:r-help-bounces at
r-project.org] On Behalf
> Of Tamas Papp
> Sent: Thursday, January 23, 2014 3:51 AM
> To: r-help at r-project.org
> Subject: [R] modify subset of array in list in a function
> 
> Hi,
> 
> I am trying to implement a function that would allow functional
> transformations of posterior simulations (useful in posterior predictive
> checks after MCMC, eg in Stan).
> 
> A posterior simulation is a list of vectors and arrays. Usually, one
> uses loops to transform it, but that's error prone. I was thinking of
> ending up with an interface like this (toy example):
> 
> --8<---------------cut here---------------start------------->8---
> posterior <- list(a=1:3,b=matrix(4:9,nrow=3))
> 
> map_posterior(posterior, function(a,b) {
>   list(d=a*sum(b))
> })        # should be equivalent to list(d=posterior$a +
rowSums(posterior$b))
> --8<---------------cut here---------------end--------------->8---
> 
> I started coding it: I make an arglist for do.call, matching names,
> then deconstruct the value and save it where it belongs. But the last
> part is giving me trouble, since in R calls are by value, not reference,
> so I don't end up modifying the original array in the code below (when
> set_subarray is called):
> 
> --8<---------------cut here---------------start------------->8---
> leading_dimension <- function(array) {
>   if (is.vector(array))
>     length(array)
>   else
>     dim(array)[1]
> }
> 
> common_leading_dimension <- function(array_list) {
>   ## if all leading dimensions are the same, return it, otherwise signal an
error
>   length_ <- length(array_list)
>   stopifnot(length_ > 0)
>   ld <- leading_dimension(array_list[[1]])
>   if (length_ > 1)
>     for (i in 2:length_)
>       stopifnot(leading_dimension(array_list[[i]])==ld)
>   ld
> }
> 
> subarray <- function(array, index) {
>   ## equivalent to array[index, , ...]
>   if (is.vector(array))
>     array[index]
>   else {
>     rank_ <- length(dim(array))
>     stopifnot(rank_ >= 1)
>     do.call("[",c(list(array,index),rep(TRUE,rank_-1)))
>   }
> }
> 
> set_subarray <- function(value, array, index) {
>   ## equivalent to array[index, , ...] <- value
>   if (is.vector(array))
>     array[index] <- value
>   else {
>     rank_ <- length(dim(array))
>     stopifnot(rank_ >= 1)
>    
do.call("[<-",c(list(array,value,index),rep(TRUE,rank_-1)))
>   }
> }
> 
> map_posterior <- function(posterior,f) {
>   names_ <- names(posterior)
>   ld <- common_leading_dimension(posterior)
>   result <- NULL
>   for (index in 1:ld) {
>     row_args <- Map(function(name)
subarray(posterior[[name]],index),names_)
>     names(row_args) <- names_
>     row_result <- do.call(f,row_args)
>     if (is.null(result)) {
>       result <- Map(function(value) {
>         dims <- if(is.vector(value)) {
>           length_ <- length(value)
>           if (length_ == 1)
>             NULL
>           else
>             length_
>         } else {
>           dim(value)
>         }
>         array(NA,c(ld,dims))
>       },row_result)
>       names(result) <- names(row_result)
>     }
>     Map(function(row_result_name,row_result_value) {
>       set_subarray(row_result_value,result[[row_result_name]],index)
>     })
>   }
>   result
> }
> --8<---------------cut here---------------end--------------->8---
> 
> Any help or hints on how to do this would be appreciated, including
> alternative approaches of doing/programming the same thing.
> 
> Best,
> 
> Tamas
> 
> ______________________________________________
> R-help at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide
http://www.R-project.org/posting-guide.html
> and provide commented, minimal, self-contained, reproducible code.