CODEWITHSUNDEEP
rfunctional-programming
ricardo
ricardo

Reputation: 8435

susbtitution of values inside lapply

Is it possible to perform substitution inside an lapply (or similar) function?

I frequently have cases where depending on some key I wish to transform some elements of a data.frame / xts object.

At the moment, i do this using a for loop -- as follows: 

set.seed(1)
dx2 <- dx <- xts(data.frame(uni = runif(10), 
                     nrm = rnorm(10),
                     uni2 = runif(10) - 0.5, 
                     nrm2 = rnorm(10) - 0.5), 
                 order.by = Sys.Date() + 1:10)

key_dx <- data.frame(dd = sample(index(dx), 4), 
                     repTest = sample(c(TRUE, FALSE), 4, rep=TRUE), 
                     colNum = 1:4, 
                     refNum = c(3,4,1,2))

for (i in 1:nrow(key_dx)) {
    if(key_dx$repTest[i]) {
        dx[key_dx$dd[i], key_dx$colNum[i]] <- 100 + dx[key_dx$dd[i], key_dx$refNum[i]]^2
    }
}

This feels like the kind thing that i ought to be able to do using an *apply function.

It would certainly make it more readable -- however i cannot fathom how to test and assign within one.

Is it possible? If so, how might i do this?

Upvotes: 1

Views: 81

Answers (2)

Troy
Troy

Reputation: 8691

You could also use plyr (neater than working with lapply() results):

require(plyr)

origframe<-data.frame(dd=index(dx),dx)              # original data
editframe<-merge(key_dx,origframe,by="dd")          # merge wiyh key_dx to bring
                                                    # conditional data into the rows
editframe<-editframe[editframe$repTest,]            # only test TRUE

editframe<-adply(editframe,1,function(x){           # modify subset rows in adply call
  x[as.numeric(x["colNum"])+4]<-100 +               # +4 adusts col index
    as.numeric(x[as.numeric(x["refNum"])+4])^2      # +4 adusts col index
  return(x)
})[,c(1,5:ncol(editframe))]

updatedframe<-rbind(editframe,origframe[origframe$dd%notin%editframe$dd,])

# then back to ts
dx2<-xts(updatedframe[,c("uni","nrm","uni2","nrm2")],order.by=updatedframe$dd)

Upvotes: 1

shadow
shadow

Reputation: 22313

The main issue is to return the changed rows seperately and then rbind them to the rows that didn't need to change. I think this is actually more difficult to read than your loop version. 

do.call(rbind, # rbind all rows 
        # only consider rows with repTest=TRUE
        c(lapply(which(key_dx$repTest), function(i) {
            # change rows
            dx[key_dx$dd[i], key_dx$colNum[i]] <- 
              100 + dx[key_dx$dd[i], key_dx$refNum[i]]^2
            # return the changed row
            dx[key_dx$dd[i], ]  
          }), 
          # return all rows that didn't change
          list(dx[!index(dx) %in% key_dx$dd[key_dx$repTest], ]) 
        ))

Upvotes: 1

Related Questions