R/agg.sector.R

In jjpwade/ioanalysis: Input-Output Analysis

agg.sector <- function(io, sectors, newname = "newname"){
  # Preliminaries
  if(class(io) != "InputOutput") stop('io should be of "InputOutput" class. See ?as.inputoutput')
  if(missing(sectors)) stop("Please specify which sectors you wish to aggregate")
  if(missing(newname)) stop("Please specify the new name for the aggregated sectors.")
  RS_label <- io$RS_label
  # Grabbing sectors and regions
  # Regions
  regions <- unique(RS_label[, 1])
  # Sectors
  if(class(sectors) == "factor"){
    sectors <- as.character(sectors)
  }
  if(class(sectors) == "character"){
    for(k in 1:length(sectors)){
      if(!sectors[k] %in% RS_label[, 2]) stop(paste(sectors[k], "is not a sector in RS_label. Check spelling, capitalization, and punctuation."))
    }
  }
  else if(class(sectors) == "numeric" | class(sectors) == "integer"){
    sector <- unique(RS_label[, 2])
    sectors <- sector[sectors]
  }
  # Creating the aggregation matrix
  n <- dim(RS_label)[1]
  I <- diag(n)
  # Making it the right size
  for(r in 1:length(regions)){
    i <- which(RS_label[, 1] %in% regions[r] & RS_label[, 2] %in% sectors)
    if(length(i) == 0){next}
    temp <- matrix(I[i[-1], ], ncol = n)
    one <- matrix(1, ncol = dim(temp)[1], nrow = 1)
    temp <- one %*% temp
    I[i[1], ] <- I[i[1], ] + temp
  }
  # Adjusting the labels
  RS_label[which(RS_label[,2] %in% sectors[1]), 2] <- newname
  sectors <- sectors[-1]
  i <- which(RS_label[, 2] %in% sectors)
  RS_label <- RS_label[-i, ]
  S <- I[-i, ]
    # creating a new InputOuput object
  if(dim(S)[2] > 1500){
    cat("\n\n    Calculating new InputOuput object...\n\n")
  }
  n <- dim(S)[1]
  IO <- NULL
  IO$Z <- S %*% io$Z %*% t(S)
  IO$RS_label <- RS_label
  # Checking to see if the final demand is aggregated
  check <- 0
  if(dim(io$f_label)[2] == 1){
    check <- 1
  }
  if(check == 0){
    IO$f <- S %*% io$f
  } else if(check == 1){
    IO$f <- io$f
  }
  IO$f_label <- io$f_label
  if(!is.null(io$E)){
    IO$E <- S %*% io$E
    IO$E_label <- io$E_label
  }
  IO$X <- S %*% io$X
  IO$V <- io$V %*% t(S)
  IO$V_label <- io$V_label
  if(exists("io$M")){
    IO$M <- io$M %*% t(S)
    IO$M_label <- io$M_label
  }
  if(!is.null(io$fV)){
    IO$fV <- io$fV
    IO$fV_label <- io$fV_label
  }
  xhat <- matrix(1/IO$X, ncol = n, nrow = n)
  IO$A <- IO$Z * xhat
  xhat <- matrix(1/IO$X, ncol = n, nrow = n, byrow = TRUE)
  IO$B <- IO$Z * xhat
  IO$L <- leontief.inv(A = IO$A)
  IO$G <- ghosh.inv(B = IO$B)
  class(IO) <- "InputOutput"
  IO
}