R/parse_specification.R

In matthewjdenny/CCAS: Communication Content and Network Structure

parse_specification <- function(formula,
                                possible_structural_terms,
                                possible_covariate_terms,
                                possible_network_terms,
                                terms_to_parse){

    # parse the formula
    rhs <- paste0(deparse(formula[[3]]), collapse = "")  # rhs of formula
    rhs <- gsub("\\s+", "", rhs)  # get rid of redundant spaces
    rhs <- strsplit(rhs, "\\+")[[1]]  # parse separate formula elements
    parsed_rhs <- vector (length = length(rhs), mode = "list")
    rhs_term_names <- rep("", length(rhs))

    # parse the actual formula terms
    for (i in 1:length(rhs)){
        parsed_rhs[[i]] <- parse_formula_term(rhs[i],
                                              possible_structural_terms,
                                              possible_covariate_terms,
                                              possible_network_terms)
        rhs_term_names[i] <- parsed_rhs[[i]]$term
    }

    # if we are parsing the structural terms out of the formula
    if(terms_to_parse == "structural"){

        lhs <- deparse(formula[[2]])  # name of the response variable
        ComNet <- dynGet(as.character(lhs),
                         ifnotfound = get(as.character(lhs)))

        if (class(ComNet) != "ComNet") {
            stop("the response variable must be of class ComNet, as generated by the prepare_covariates() function...")
        }

        # record the length of the parsed RHS and see if it changes. If it does
        # not, this will indicate that there are no network/covariate terms
        # included in the specification
        spec_len <- length(rhs_term_names)

        # remove all node level covariate terms
        remove <- which(rhs_term_names %in% possible_covariate_terms)
        if (length(remove) > 0){
            rhs_term_names <- rhs_term_names[-remove]
            parsed_rhs <- parsed_rhs[-remove]
        }
        remove <- which(rhs_term_names %in% possible_network_terms)
        if (length(remove) > 0){
            rhs_term_names <- rhs_term_names[-remove]
            parsed_rhs <- parsed_rhs[-remove]
        }
        # check that the names of the statistics match those that are possible
        possible <- 1:length(rhs_term_names)
        actual <- which(rhs_term_names %in% possible_structural_terms)
        if (length(possible) != length(actual)) {
            stop(paste("the specified structural term",
                       possible_structural_terms[setdiff(possible, actual)],
                       "is not an available statistic.", sep = " "))
        }

        if (length(rhs_term_names) != 1) {
            stop( "You must specify one and only one of 'euclidean' or 'bilinear' terms.")
        }

        # now determine whether there are other terms
        using_covariates <- FALSE
        if (length(rhs_term_names) != spec_len) {
            using_covariates <- TRUE
        }

        return(list(type = parsed_rhs[[1]]$term,
                    d = parsed_rhs[[1]]$d,
                    ComNet = ComNet,
                    using_covariates = using_covariates))
    }

    # get all of the covariate terms
    if(terms_to_parse == "covariate"){
        # if we are parsing covariate terms out of the formula
        remove <- which(rhs_term_names %in% possible_structural_terms)
        if (length(remove) > 0){
            rhs_term_names <- rhs_term_names[-remove]
            parsed_rhs <- parsed_rhs[-remove]
        }
        remove <- which(rhs_term_names %in% possible_network_terms)
        if (length(remove) > 0){
            rhs_term_names <- rhs_term_names[-remove]
            parsed_rhs <- parsed_rhs[-remove]
        }
        return(parsed_rhs)
    }

    # get all of the network terms
    if(terms_to_parse == "network"){
        # if we are parsing covariate terms out of the formula
        remove <- which(rhs_term_names %in% possible_structural_terms)
        if (length(remove) > 0){
            rhs_term_names <- rhs_term_names[-remove]
            parsed_rhs <- parsed_rhs[-remove]
        }
        remove <- which(rhs_term_names %in% possible_covariate_terms)
        if (length(remove) > 0){
            rhs_term_names <- rhs_term_names[-remove]
            parsed_rhs <- parsed_rhs[-remove]
        }
        return(parsed_rhs)
    }
}