R/emis_to_dt.R

In gtfs2emis: Estimating Public Transport Emissions from General Transit Feed Specification (GTFS) Data

#' @title 
#' Convert emission estimates from list to data.table format
#' 
#' @description 
#' Read emission estimates generated by the \code{\link{emission_model}} or from
#' emission factor functions (e.g. \code{\link{ef_brazil_cetesb}}) and convert 
#' them into a `data.table` format.
#' 
#' @param emi_list list. A list of emission estimates
#' @param emi_vars character. data.frame names of 'emi_list' object attributed 
#'        to emissions or  emission factors. Default is 'emi'.
#' @param veh_vars character. data.frame names of 'emi_list' object attributed 
#'        to vehicle characteristics. Default is 'veh_type'.
#' @param pol_vars character. data.frame names of 'emi_list' object attributed 
#'        to pollutants. Default is 'pollutant'.
#' @param segment_vars character. data.frame names of 'emi_list' object 
#'        attributed to the road segments. Default is NULL.
#' @param process_vars character. data.frame names of 'emi_list' object 
#'        attributed to the emission processes. Default is 'process'.
#'        
#' @return data.table.
#' 
#' @family emission analysis

#' @examples
#' \donttest{
#'  if (requireNamespace("gtfstools", quietly=TRUE)) {
#' 
#' # read GTFS
#' gtfs_file <- system.file("extdata/bra_cur_gtfs.zip", package = "gtfs2emis")
#' gtfs <- gtfstools::read_gtfs(gtfs_file) 
#' 
#' # keep a single trip_id to speed up this example
#' gtfs_small <- gtfstools::filter_by_trip_id(gtfs, trip_id ="4451136")
#'   
#' # run transport model
#' tp_model <- transport_model(gtfs_data = gtfs_small,
#'                             min_speed = 2,
#'                             max_speed = 80,
#'                             new_speed = 20,
#'                             spatial_resolution = 100,
#'                             parallel = FALSE)
#' 
#' # Example using Brazilian emission model and fleet
#' fleet_data_ef_cetesb <- data.frame(veh_type = "BUS_URBAN_D",
#'                                    model_year = 2010:2019,
#'                                    fuel = "D",
#'                                    fleet_composition = rep(0.1,10)
#'                                    )
#'                                    
#' emi_list <- emission_model(
#'                 tp_model = tp_model,
#'                 ef_model = "ef_brazil_cetesb",
#'                 fleet_data = fleet_data_ef_cetesb,
#'                 pollutant = c("CO","PM10","CO2","CH4","NOx")
#'                 )
#' 
#' # convert emission list to data.table
#' dt <- emis_to_dt(emi_list)
#' }
#' }
#' @export
emis_to_dt <- function(emi_list, emi_vars = "emi", veh_vars = "veh_type"
                       , pol_vars = "pollutant", process_vars = "process", segment_vars = NULL){
  
  
  # emi_list = cur_local_ef
  # emi_vars = "EF"
  # veh_vars = "veh_type"
  # pol_vars = "pollutant"
  # process_vars = "process"
  # segment_vars = NULL
  # checkings -----
  checkmate::assert_list(emi_list, null.ok = FALSE)
  # emi_vars
  checkmate::assert_vector(emi_vars,any.missing = FALSE,min.len = 1,null.ok = FALSE)
  checkmate::assert_character(emi_vars,any.missing = FALSE,min.len = 1)
  for(i in emi_vars) checkmate::assert_choice(i,names(emi_list),null.ok = FALSE)
  # veh_vars
  checkmate::assert_vector(veh_vars,any.missing = FALSE,min.len = 1,null.ok = FALSE)
  checkmate::assert_character(veh_vars,any.missing = FALSE,min.len = 1)
  for(i in veh_vars) checkmate::assert_choice(i,names(emi_list),null.ok = FALSE)
  # pol_vars
  checkmate::assert_vector(pol_vars,any.missing = FALSE,min.len = 1,null.ok = FALSE)
  checkmate::assert_character(pol_vars,any.missing = FALSE,min.len = 1)
  for(i in pol_vars) checkmate::assert_choice(i,names(emi_list),null.ok = FALSE)
  # process
  checkmate::assert_vector(process_vars,any.missing = FALSE,min.len = 1,null.ok = FALSE)
  checkmate::assert_character(process_vars,any.missing = FALSE,min.len = 1)
  for(i in process_vars) checkmate::assert_choice(i,names(emi_list),null.ok = FALSE)
  # segment_vars
  checkmate::assert_vector(segment_vars,any.missing = FALSE,min.len = 1,null.ok = TRUE)
  checkmate::assert_character(segment_vars,any.missing = FALSE,min.len = 1,null.ok = TRUE)
  for(i in segment_vars) checkmate::assert_choice(i,names(emi_list),null.ok = FALSE)
  
  # check units 
  myunits <- sapply(seq_along(emi_list[[emi_vars]]),function(i){
    units::deparse_unit(emi_list[[emi_vars]][[i]])
  })
  
  if(length(unique(myunits)) == 1){
    myunits <- myunits[1]
  }else{
    stop("Invalid units: units are not the same for all emissions columns")
  }
  
  # expand process values
  if(!is.null(pol_vars)){
    rep_pol <- lapply(pol_vars,function(i){ # i = pol_vars
      tmp_rep <- rep(emi_list[[i]],each = length(emi_list[[veh_vars[1]]]))
      #tmp_rep <- rep(emi_list[[i]],each = length(emi_list[[process_vars[1]]]))
      tmp_rep <- rep(tmp_rep,length(emi_list[[process_vars[1]]]))
    })
  }
  if(!is.null(veh_vars)){
    rep_veh <- lapply(veh_vars,function(i){ # i = veh_type
      rep(emi_list[[i]],length(emi_list[[process_vars[1]]]) * length(emi_list[[pol_vars[1]]]))
    })
  }
  if(!is.null(process_vars)){
    rep_pro <- lapply(process_vars,function(i){ # i = veh_type
      rep(emi_list[[i]],each = length(emi_list[[veh_vars[1]]]) * length(emi_list[[pol_vars[1]]]))
    })
  }
  for(i in emi_vars){ # i = "EF"
    if("units" %in% class(emi_list[[i]])){
      emi_list[[i]] <- data.table::as.data.table(emi_list[[i]])
    }
  }
  # merge------
  tmp_dt <- lapply(seq_along(emi_list[[emi_vars]]),function(i){ # i = 1
    
    # variables (emi)
    tmp_dt <- emi_list[[emi_vars]][,.SD,.SDcols = i]
    names(tmp_dt) <- emi_vars
    # variables (pol, veh)
    if(!is.null(veh_vars))     for(j in seq_along(rep_veh)) tmp_dt[,(veh_vars[j]) := rep_veh[[j]][i]]
    if(!is.null(pol_vars))     for(j in seq_along(rep_pol)) tmp_dt[,(pol_vars[j]) := rep_pol[[j]][i]]
    if(!is.null(process_vars)) for(j in seq_along(rep_pro)) tmp_dt[,(process_vars[j]) := rep_pro[[j]][i]]
    # variables (segment)
    if(!is.null(segment_vars)){
      for(j in seq_along(segment_vars)){
        tmp_dt[,(segment_vars[j]) := emi_list[[segment_vars[j]]]]
      }
    }
    return(tmp_dt)
  })
  tmp_dt <- data.table::rbindlist(tmp_dt)
  # rename
  all_vars = c(veh_vars, pol_vars,emi_vars,process_vars)
  data.table::setcolorder(tmp_dt,neworder = all_vars[!is.null(all_vars)])
  # export
  return(tmp_dt)
}