Commit 2f982f4a authored by pbac's avatar pbac
Browse files

multiplier issue fixed

parent d51c07a0
#' Depth of a list
#'
#' Returns the depth of a list
#' @title Depth of a list
#' @param this list
#' @return integer
depth <- function(this) ifelse(is.list(this), 1L + max(sapply(this, depth)), 0L)
#' Flattens list in a single list of data.frames
#'
#' Flattens list. Can maybe be made better. It might end up copying data in
#' memory!? It might change the order of the elements.
#' @title Flattens list
#' @param x List to flatten.
#' @return A flatten list
flattenlist <- function(x){
(n <- depth(x))
if(n == 2){
# Its fine
return(x)
}else if(n ==3){
unlist(x, recursive=FALSE)
}else{
morelists <- sapply(x, function(xprime) class(xprime)[1]=="list")
out <- c(x[!morelists], unlist(x[morelists], recursive=FALSE))
if(sum(morelists)){
Recall(out)
}else{
return(out)
}
}
}
......@@ -212,11 +212,11 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
if(class(L)[1]=="data.frame"){ return(list(L)) }
if(class(L)[1]!="list"){ stop(pst("The value returned from evaluating: ",input$expr,", was not a matrix, data.frame or a list of them."))}
if(class(L[[1]])[1]=="matrix"){ return(lapply(L, function(mat){ return(as.data.frame(mat)) })) }
return(L)
return(flattenlist(L))
})
# Put together in one data.list
L <- structure(do.call(c, L), class="data.list")
#
# Make it a data.list with no subsubelements (it's maybe not a data.list, since it miss "t", however to take subsets etc., it must be a data.list)
L <- flattenlist(L)
class(L) <- "data.list"
return(L)
},
#----------------------------------------------------------------
......
......@@ -49,35 +49,39 @@
#' @export
"%**%" <- function(x, y) {
if( is.null(dim(y)) ){
## y is not matrix like
lapply(x, function(xx) {
xx * y
})
# If any of them is a list: do recursive calls
if( class(x)[1] == "list" ){
return(flattenlist(lapply(x, "%**%", y=y)))
}else if(class(y)[1] == "list"){
return(flattenlist(lapply(y, "%**%", y=x)))
}
# Do the multiplication
# If either is just a vector
if(is.null(dim(x)) | is.null(dim(y))){
return(x * y)
}else{
## y is matrix like
lapply(x, function(xx) {
## Check if different horizon k columns
colmatch <- TRUE
if (ncol(xx) != ncol(y)) {
colmatch <- FALSE
}else if(any(nams(xx) != nams(y))){
colmatch <- FALSE
}
if(!colmatch){
## Not same columns, take only the k in both
nms <- nams(xx)[nams(xx) %in% nams(y)]
xx <- xx[, nms]
y <- y[, nms]
}
## Now multiply
val <- xx * y
## Must be data.frame
if( is.null(dim(val)) ){
val <- data.frame(val)
nams(val) <- nms
}
return(val)
})
# Both are matrices
# Check if they have different horizon k columns
colmatch <- TRUE
if (ncol(x) != ncol(y)) {
colmatch <- FALSE
}else if(any(nams(x) != nams(y))){
colmatch <- FALSE
}
if(!colmatch){
# Not same columns, take only the k in both
nms <- nams(x)[nams(x) %in% nams(y)]
x <- x[, nms]
y <- y[, nms]
}
# Now multiply
val <- x * y
# Must be data.frame
if( is.null(dim(val)) ){
val <- data.frame(val)
nams(val) <- nms
}
return(val)
}
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment