-
Notifications
You must be signed in to change notification settings - Fork 2
/
max_confirm_backup.R
117 lines (100 loc) · 4.94 KB
/
max_confirm_backup.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
#' maximally_confirm_behavior
#'
#' Identify the behavior that would maximally confirm the identities of actor
#' and object pairing
#'
#' @param actor lowercase string corresponding to the actor identity
#' @param beh lowercase string corresponding to the behavior term
#' @param object lowercase string corresponding to the object identity
#' @param dictionary_key a string corresponding to the dictionary from actdata you are using for cultural EPA measurements
#' @param 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
#' @param eq_df if you select "user supplied" for equation, this parameter should
#' be your equation dataframe, which (should have been reshaped by the
#' reshape_new_equation function prior)
#'
#' @return 3 digit EPA indicating the optimal behavior
#' @export
#'
#' @examples
maximally_confirm_behavior <- function(act, beh, obj,
dictionary_key,
gender,
equation_key,
eq_df = NULL){
#get dictionaries
d <- actdata::epa_subset(dataset = dictionary_key, gender = gender)
#get equation
if(equation_key == "user_supplied"){
eq <- eq_df
} else {
eq <- get_equation(name = equation_key, type = "impressionabo", g = gender)
}
a <- d %>%
dplyr::filter(term == act & component == "identity") %>%
dplyr::mutate(element = "A")
o <- d %>%
dplyr::filter(term == obj & component == "identity") %>%
dplyr::mutate(element = "O")
ao_epa <- rbind(a, o) %>%
select(term, element, E, P, A) %>%
pivot_longer(cols = E:A, names_to = "dimension",
values_to = "fundamental_sentiment") %>%
arrange(element)
i_actor <- eq %>%
mutate(i = case_when(A == "000" & O == "000" ~ 1,
A == "100" & O == "000" ~ ao_epa$fundamental_sentiment[1],
A == "010" & O == "000" ~ ao_epa$fundamental_sentiment[2],
A == "001" & O == "000"~ ao_epa$fundamental_sentiment[3],
A == "000" & O == "100" ~ ao_epa$fundamental_sentiment[4],
A == "000" & O == "010" ~ ao_epa$fundamental_sentiment[5],
A == "000" & O == "001" ~ ao_epa$fundamental_sentiment[6],
A == "100" & O == "100"~ ao_epa$fundamental_sentiment[1]*ao_epa$fundamental_sentiment[4],
A == "100" & O == "010" ~ ao_epa$fundamental_sentiment[1]*ao_epa$fundamental_sentiment[5],
A == "100" & O == "001" ~ ao_epa$fundamental_sentiment[1]*ao_epa$fundamental_sentiment[6],
A == "010" & O == "100" ~ ao_epa$fundamental_sentiment[2]*ao_epa$fundamental_sentiment[4],
A == "010" & O == "010" ~ ao_epa$fundamental_sentiment[2]*ao_epa$fundamental_sentiment[5],
A == "010" & O == "001" ~ ao_epa$fundamental_sentiment[2]*ao_epa$fundamental_sentiment[6],
A == "001" & O == "100" ~ ao_epa$fundamental_sentiment[3]*ao_epa$fundamental_sentiment[4],
A == "001" & O == "010" ~ ao_epa$fundamental_sentiment[3]*ao_epa$fundamental_sentiment[5],
A == "001" & O == "001" ~ ao_epa$fundamental_sentiment[3]*ao_epa$fundamental_sentiment[6])) %>%
select(i)
f_s_i <- c(ao_epa$fundamental_sentiment[1],
ao_epa$fundamental_sentiment[2],
ao_epa$fundamental_sentiment[3],
1, 1, 1,
ao_epa$fundamental_sentiment[4],
ao_epa$fundamental_sentiment[5],
ao_epa$fundamental_sentiment[6])
#save as a vector
i_actor <- c(as.vector(f_s_i), as.vector(i_actor$i))
#make into a matrix with that on the diagonal
mat_i_actor <- matrix(0, length(i_actor), length(i_actor))
diag(mat_i_actor) <- i_actor
#make a behavior selection matrix
b_s <- create_select_mat("behavior", gender = gender,
equation_key = equation_key,
eq_df)
#now which terms do not have behavior in them
i_s <- matrix(data = rep(1, length(i_actor)), nrow = length(i_actor))
i_3 <- as.matrix(c(1, 1, 1))
g <- i_s - b_s %*% i_3
g <- as.vector(g)
#h contains identity matrix + coefficients of equations
h <- construct_h_matrix(equation_key = equation_key,
gender = gender)
#term 1 of equation
term1 <- t(b_s) %*% mat_i_actor %*% h %*% mat_i_actor %*% b_s
term1 <- solve(term1)
term1 <- -1*term1
#term 2 of the equation
term2 <- t(b_s) %*% mat_i_actor %*% h %*% mat_i_actor %*% g
#final solution
sol <- term1 %*% term2
#put into nicer format
opt_behavior_actor <- tibble(opt_E = sol[1],
opt_P = sol[2],
opt_A = sol[3],
term = "actor")
return(opt_behavior_actor)
}