R/bayesXOutput.R

In aleksandar-spasojevic/BayesXShinyApp:

#' extracts key value pairs from 'output' directory generated by bayesX CLI
#' @note we do not export this method, is an internal method
#' @noRd
get_key_values <- function(line, data_env, ...){
  key_values <- unlist(strsplit(line, ","))
  meta <- list()
  for (pair in key_values) {
    splitted <- unlist(strsplit(pair, "="))
    # in 'key' remove leading and trailing whitespaces
    key <- unlist(gsub("^\\s+|\\s+$", "", splitted[1])); value <- splitted[2]
    meta[key] <- value
  }
  
  # if line contains 'term' we declare it as an effect
  is_effect <- grepl("term", line)
  if ( is_effect )
    class(meta) <- c("effect", class(meta))
  
  return(meta)
}


#' 'bayesXOutput' + 'effects' constructor for 'output/' files generated by bayesX CLI
#'
#' class which contains information about 'output/' files generated by
#' \code{\link{bayesX}}
#'
#' @param bayesXResult is the object generated by \code{\link{bayesX}}
#'
#' @noRd
bayesXOutput <- function(bayesXResult, ...) UseMethod("bayesXOutput")

bayesXOutput.bayesXResult <- function(bayesXResult, ...){
  
  r_file <- readLines(list.files(output_path(bayesXResult), "*.r$",
                                 full.names = TRUE))
  
  # extract information of .r file in output per line
  output_meta <- lapply(r_file, get_key_values, attr(bayesXResult, "data_env"))
  class(output_meta) <- c("bayesXOutput", "effects", class(output_meta))
  attr(output_meta, "data_env") <- attr(bayesXResult, "data_env")
  return(output_meta)
}

#' @note since user only passes the output directory, we do not know where
#' data sample is stored
#' 
#' @rdname bayesXOutput
#' 
#' @noRd
bayesXOutput.character <- function(path, ...){
  # read the .R file created in Output generated by bayesX CLI which contains
  # summary information e.g equationtypes
  r_file_path <- list.files(path, "*.r$", full.names = TRUE)
  if( length(r_file_path) == 0 )
    stop( sprintf("there is no .R file generated by bayesX in %s", path) )
  r_file <- readLines(r_file_path)
  
  # extract information of .r file in output per line
  output_meta <- lapply(r_file, get_key_values, NULL)
  
  # meta object of type 'bayesXOutput' and 'effects'!
  class(output_meta) <- c("bayesXOutput", "effects", class(output_meta))
  attr(output_meta, "data_env") <- NULL
  return(output_meta)
}


#' subscript operator for 'bayesXOutput' objects
#'
#' extracts meta information out of 'output/*.r' file generated by
#' \code{\link{bayesX}}
#'
#' @param bayesXOutput is the object generated by \code{\link{bayesXOutput}}
#'
#' @noRd
"[.bayesXOutput" <- function(bayesXOutput, i, drop = TRUE, ...){
  sapply(bayesXOutput, "[", i, drop = drop, ...)
}


#' @export
variables.bayesXOutput <- function(bayesXOutput, ...){
  variables <- lapply(bayesXOutput, function(elem){
    tryCatch(variables(elem), 
             warning = function(w) NULL, 
             error = function(e) NULL)
  }, ...)
  return( unique(unlist(variables)) )
}


#' @export
predict.effects <- function(bayesXOutput, X, ...){
  # tryCatch since some elements of bayesXOutput are not of type 'effect'. If
  # one 'elem' is not of type 'effect' we will return 'NULL' otherwise 
  # 'predict.effect' function is called
  force(X)
  effects_predicted <- do.call("c", lapply(bayesXOutput, function(elem, ...){
    tryCatch(predict(elem, X = X, ...), 
             warning = function(w) NULL,
             error = function(e) NULL)
  }, ...))
  
  class(effects_predicted) <- c("effects_predicted", class(effects_predicted))
  
  return( effects_predicted )
}


#' @export
distribution.bayesXOutput <- function(bayesXOutput, ...){
  # NOTE: for each equation type there is an distribution attribute, unnecessary
  # -> take first element valid; often all equation types of same distribution!
  for( distr in bayesXOutput["family"] ){
    if (is.null(distr))
      next
    return( .distributions[[distr]] )
  }
  
  if( is.null(distr) )
    stop( sprintf("distribution not found, add: %s", distr) )
}


#' @export density.bayesXOutput
density.bayesXOutput <- function(bayesXOutput, X, ...){
  params <- parameters(bayesXOutput, X)
  return( density(params, ...) )
}