#' MultiRowHierarchyComputations
#'
#' Showing computations behind the scenes in HierarchyCompute
#'
#' @param a a
#' @param drop0 see code
#' @param ind see code
#' @param doStack Stacked output when TRUE
#' @param valueName Parameter to Stack
#' @param indName Parameter to Stack
#'
#' @return Data frame where the "weights in weighted sum" is named as sign. Firs row (before stacking) contains the "results".
#' @export
#'
#' @examples
#' # Data and hierarchies used in the examples
#' x <- SSBtoolsData("sprt_emp") # Employment in sport in thousand persons from Eurostat database
#' geoHier <- SSBtoolsData("sprt_emp_geoHier")
#' ageHier <- SSBtoolsData("sprt_emp_ageHier")
#'
#' # Create rowSelect
#' rowSelect = data.frame(geo = "Europe", age = c("Y15-64", "Y15-29"), year="2015")
#'
#' # Create input
#' a <- HierarchyCompute(x, list(age = ageHier, geo = geoHier, year = "rowFactor"), "ths_per", rowSelect = rowSelect, output = "matrixComponents")
#'
#' MultiRowHierarchyComputations(a)
#'
MultiRowHierarchyComputations <- function(a, drop0 = TRUE, valueName = "values", indName = "ind", ind = NULL) {
if (NCOL(a$valueMatrix) != 1)
stop("Only single col in valueMatrix allowed (no colFactor).")
dataDummyHierarchy <- rbind(0,t(as.matrix(a$dataDummyHierarchy)))
valueMatrix <-
rbind(t(as.matrix(Mult(a$dataDummyHierarchy, a$valueMatrix))), #rbind(t(as.matrix(a$dataDummyHierarchy %*% a$valueMatrix)),
matrix(a$valueMatrix,nrow=NROW(a$valueMatrix),ncol=NROW(a$dataDummyHierarchy)))
rownames(valueMatrix ) = NULL
if(is.null(ind))
ind = MatrixPaste(a$toCrossCode,sep=".")
#nonZero <- rowSums(abs(valueMatrix)) > 0 & abs(dataDummyHierarchy) > 0
fromCrossCode = a$fromCrossCode[c(1,seq_len(NROW(a$fromCrossCode))), ]
rownames(fromCrossCode) = NULL
z <- cbind(fromCrossCode, sign = as.vector(dataDummyHierarchy),
valueName7yw4h7k3 = as.vector(valueMatrix),
indName7yw4h7k3 = rep(ind,each=NROW(valueMatrix)))
toCode = rep(FALSE, NROW(valueMatrix))
toCode[1] = TRUE
toCode = rep(toCode, NCOL(valueMatrix))
z[toCode, names(fromCrossCode)] = a$toCrossCode[ , names(fromCrossCode)]
names(z)[names(z)=="valueName7yw4h7k3"] = valueName
names(z)[names(z)=="indName7yw4h7k3"] = indName
if(drop0)
z = z[!(!toCode & z$sign==0) , ]
z
}
if(FALSE){
library(Kostra)
a=KostraData("kostraRegnskapDataPen")
arter = "AGD65" #rep(c("AGD9","AGID1","AGI14","AGD32","AGD65", "800", "AG20"),2)
kontoklasser= "D" #c("D","D","D","D","D","D", "I","I","I","D","I","D","I","D")
perioder = "2015" #c(rep("2015",7),rep("2016",7) )
regnskapsomfang = "A" #c("A","A","A","B","A","B","B" ,"B","A","A","B","A","A","A")
funksjoner= "FG2" #c(rep("FG2",7),"120","800","FG4","FG2","FG2","800","FG2")
regioner = "0301" #unique(a$data$region)
zBI <-
KostraRegnskapBeregningInput(a$data, a$funksjonshierarki, a$artshierarki, a$data_saer, a$artshierarki_nettinger,a$artshierarki_nettinger_kasse,
formler = a$formler,
perioder = perioder,
arter = arter,
funksjoner= funksjoner,
kontoklasser= kontoklasser,
regioner = regioner,
regnskapsomfang = regnskapsomfang)
zBH <-
KostraRegnskapBeregningHierarki(a$data, a$funksjonshierarki, a$artshierarki, a$data_saer, a$artshierarki_nettinger,a$artshierarki_nettinger_kasse,
formler = a$formler,
perioder = perioder,
arter = arter,
funksjoner= funksjoner,
kontoklasser= kontoklasser,
regioner = regioner,
regnskapsomfang = regnskapsomfang)
zBHI <-
KostraRegnskap(a$data, a$funksjonshierarki, a$artshierarki, a$data_saer, a$artshierarki_nettinger,a$artshierarki_nettinger_kasse,
formler = a$formler,
perioder = perioder,
arter = arter,
funksjoner= funksjoner,
kontoklasser= kontoklasser,
regioner = regioner,
regnskapsomfang = regnskapsomfang,
output = "beregningHierarkiInput")
beregnetHierarki = zBHI[[1]]
krMC = zBHI[[2]]
RowMC = function(a, row){
a$toCrossCode = a$toCrossCode[row, ,drop=FALSE]
a$dataDummyHierarchy = a$dataDummyHierarchy[row, ,drop=FALSE]
a
}
LagBeregningInputRow = function(a1, a2, a3, a4, periode, row){
LagBeregningInput(a1= RowMC(a1,row), a2= RowMC(a2,row), a3= RowMC(a3,row), a4= RowMC(a4,row), periode=periode)
}
LagBeregningInputRowkrMC = function(krMC, periode, row){
LagBeregningInputRow(krMC$a1, krMC$a2, krMC$a3, krMC$a4, periode, row)
}
krBI = LagBeregningInputRowkrMC(krMC, periode, 1)
factorType = factor(beregnetHierarki_type)
integerType <- as.integer(factorType)
fromMatrix <- matrix("", dim(rgBH$groups)[1], max(integerType))
colnames(fromMatrix) <- levels(factorType)
fromMatrix[cbind(rgBH$idx, integerType)] <- beregnetHierarki$from
return(LagBeregningInput(a1=a1,a2=a2,a3=a3,a4=a4, periode=periode))
beregnetHierarki_type = CharacterReCode(beregnetHierarki$type_from, c("Input_Kasse", "Input_Saer"), c("Kasse", "Saer"))
beregnetHierarki =
SelectAndRename(beregnetHierarki,
oldNames= c("periode", "region", "kontoklasse_from", "funksjon_from", "art_from", "from", "sign", "type_from", "belop"),
newNames= c("periode", "region", "kontoklasse", "funksjon", "art", "from", "sign", "type", "belop"))
rgBH =RowGroups(beregnetHierarki[,c("kontoklasse", "funksjon", "art")], returnGroups = TRUE, returnGroupsId = FALSE)
krBH = KostraRegnskap(a$data, a$funksjonshierarki, a$artshierarki, a$data_saer,
a$artshierarki_nettinger, a$artshierarki_nettinger_kasse,
kombinasjoner = rgBH$groups,
regioner = unique(beregnetHierarki$region))
#output = outp,
#printData = FALSE, autoNetting = FALSE, lag0300 = FALSE, fixRegionkode = FALSE, fixArtkode = FALSE, fixFunksjonkode = FALSE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.