R/reidentify_object.R

In ekmaloney/inteRact: Implements Affect Control Theory Equations in R

#' Function to Generate the Re-identification of the Object
#'
#' @param d a dataframe from reshape events that should be only
#' actor_modifier and actor elements or object_modifier and object elements
#' @param equation_gender either average, male, or female, depending on if you are using gendered equations
#' @param equation_key a string corresponding to the equation key from actdata
#'
#' @return dataframe with 3 columns corresponding to the EPA of optimal object identity relabel
#' @importFrom tibble tibble
#' @importFrom dplyr if_else
#' @export
#'
#' @examples
#' d <- tibble::tibble(actor = "ceo", behavior = "advise", object = "benefactor")
#' d <- reshape_events_df(df = d, df_format = "wide", dictionary_key = "usfullsurveyor2015", dictionary_gender = "average")
#' reidentify_object(d = d, equation_key= "us2010", equation_gender = "average")
reidentify_object <- function(d,
                              equation_key = NULL,
                              equation_gender = NULL,
                              eq_df = NULL,
                              ...) {

            #calculate the transient impression of the event
            trans_imp_df <- transient_impression(d = d,
                                                 equation_key = equation_key,
                                                 equation_gender = equation_gender,
                                                 eq_df = eq_df)

            #get the equation
            eq <- get_equation(name = equation_key,
                               g = equation_gender,
                               eq_df = eq_df,
                               type = "impressionabo")

            #extract terms that are not A
            i_a <- extract_terms(elem = "object",
                                 eq = eq,
                                 trans_imp_df)

            #create actor selection matrix
            a_s <- create_select_mat(term = "object",
                                     eq = eq)

            #now which terms do not have actor in them
            i_s <- matrix(data = rep(1, nrow(i_a)), nrow = nrow(i_a))
            i_3 <- as.matrix(c(1, 1, 1))
            g <- i_s - a_s %*% i_3
            g <- as.vector(g)

            #construct h matrix
            h <- construct_h_matrix(eq = eq)

            #term 1 of equation
            term1 <- t(a_s) %*% i_a %*% h %*% i_a %*% a_s
            term1 <- solve(term1)
            term1 <- -1*term1

            #term 2 of the equation
            term2 <- t(a_s) %*% i_a %*% h %*% i_a %*% g

            #final solution
            sol <- term1 %*% term2

            #put into nicer format
            obj_label <- tibble::tibble(E = sol[1],
                                  P = sol[2],
                                  A = sol[3])

            return(obj_label)
}