R/digraph.R

In ncarchedi/iMatchIt: An interactive wrapper for the MatchIt R package

newDigraph <- function(question){
  root <- list(name="root", parentnames=NULL, relationship=NULL, 
               children=list(), question=question)
  list(root=root)
}

addNode <- function(digraph, nodename, parentnames, relationship, question, ruleout){
  # Create the new node
  node <- list(name=nodename, parentname=parentnames, relationship=relationship, 
               children=list(), question=question, ruleout=ruleout)
  # Add the new node to its parents' children
  for(parentname in parentnames){
    digraph[[parentname]][["children"]][[relationship]] <- nodename
  }
  # Add the new node to the digraph
  digraph[[nodename]] <- node
  # Return the augmented digraph. (Copy on modify rules mean the original digraph won't be changed.)
  return(digraph)
}

runDigraph <- function(digraph, e){
  # Define all possible methods up front
  e$methods_list <- yaml.load_file(system.file("methods.yaml", 
                                               package="iMatchIt"))
  # Assign matchit models
  assign_matchit_models(e)
  # Start at root node
  node <- digraph[["root"]]
  # Begin navigating the decision tree
  while(length(node[["children"]]) > 0){
    # Print pretty separator
    separate()
    
    # Print diagnostics for testing purposes only
    print_diag(node, e)
    
    # Print boxplot of options
    make_boxplot(e)
    
    # Execute any code that needs to be excecuted at node
    if(!is.null(node[["runcode"]])) {
      do.call(node[["runcode"]], list(e))
    }
    
    # Get children of current node
    children <- node[["children"]]
    
    # Present new question and choices
    pretty_out(node[["question"]])
    choice <- select.list(choices=names(children), graphics=FALSE)
    # Navigate to new node
    node <- digraph[[children[[choice]]]]
  }
  # Print final "ruled out" and "remaining" lists for testing purposes
  print_diag(node, e)
  # Print the final node's "question" (which is actually a recommendation)
  pretty_out(node[["question"]])
  # Return final model to user
  pretty_out("Which of the remaining models would you like to explore further?")
  mods_rem <- sapply(e$methods_list, `[[`, "name")
  final_mod <- select.list(mods_rem, graphics=FALSE)
  mod_ind <- which(mods_rem == final_mod)
  assign("myMod", getModels(e)[[mod_ind]], globalenv())
  pretty_out("I've created a variable in your workspace called `myMod`, which contains a complete copy of the model you selected.", skip_after=TRUE)
  # Return invisibly
  invisible()
}

#' Write digraph to file using YAML format
#' 
#' @importFrom yaml as.yaml
#' @param digraph Name of digraph object
#' @param file File path for output (.yaml extension)
#' @export
write_digraph <- function(digraph, file) {
  writeLines(as.yaml(digraph), file)
}

#' Read digraph from file using YAML format
#' 
#' @importFrom yaml yaml.load_file
#' @param file File to read from (.yaml extension)
#' @export
read_digraph <- function(file) {
  yaml.load_file(file)
}