-
Notifications
You must be signed in to change notification settings - Fork 2
/
optimal_behavior.R
181 lines (146 loc) · 9.03 KB
/
optimal_behavior.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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
#' Calculate the Optimal Behavior for the Actor following an Event
#'
#' @param d data that has been reshaped by the reshape_events_df function
#' @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 3 digit EPA indicating the optimal behavior
#'
#' @export
#'
#' @examples
#'
#' opt_behavior_example <- tibble::tibble(actor = "teenager", behavior = "beam_at",object = "friend")
#' opt_behavior_df <- reshape_events_df(df = opt_behavior_example, df_format = "wide", dictionary_key = "indiana2003", dictionary_gender = "male")
#' opt_b <- optimal_behavior(d = opt_behavior_df, equation_key = "nc1978", equation_gender = "male")
#'
#'
#'
optimal_behavior <- function(d,
equation_key = NULL,
equation_gender = NULL,
eq_df = NULL,
...) {
#get the equation
eq <- get_equation(name = equation_key,
g = equation_gender,
eq_df = eq_df,
type = "impressionabo")
#calculate the transient impression
element_def <- transient_impression(d = d,
equation_key = equation_key,
equation_gender = equation_gender,
eq_df = eq_df)
#select fundamental sentiment terms related to behavior
element_def <- element_def %>%
dplyr::mutate(f_s_b = if_else(element == "behavior",
estimate, 1))
#select transient impression terms related to behavior
z_b <- eq %>%
dplyr::mutate(z_b = dplyr::case_when(B == "000" ~ 1,
B == "100" ~ element_def$trans_imp[4],
B == "010" ~ element_def$trans_imp[5],
B == "001" ~ element_def$trans_imp[6])) %>%
dplyr::select(z_b)
#save as a vector
z_b <- c(as.vector(element_def$f_s_b), as.vector(z_b$z_b))
#now get the non-behavior terms from each
element_def <- element_def %>%
dplyr::mutate(f_s_i = if_else(element != "behavior",
estimate, 1))
####ACTOR
i_actor <- eq %>%
dplyr::mutate(i = dplyr::case_when(A == "000" & O == "000" ~ 1,
A == "100" & O == "000" ~ element_def$trans_imp[1],
A == "010" & O == "000" ~ element_def$trans_imp[2],
A == "001" & O == "000"~ element_def$trans_imp[3],
A == "000" & O == "100" ~ element_def$trans_imp[7],
A == "000" & O == "010" ~ element_def$trans_imp[8],
A == "000" & O == "001" ~ element_def$trans_imp[9],
A == "100" & O == "100"~ element_def$trans_imp[1]*element_def$trans_imp[7],
A == "100" & O == "010" ~ element_def$trans_imp[1]*element_def$trans_imp[8],
A == "100" & O == "001" ~ element_def$trans_imp[1]*element_def$trans_imp[9],
A == "010" & O == "100" ~ element_def$trans_imp[2]*element_def$trans_imp[7],
A == "010" & O == "010" ~ element_def$trans_imp[2]*element_def$trans_imp[8],
A == "010" & O == "001" ~ element_def$trans_imp[2]*element_def$trans_imp[9],
A == "001" & O == "100" ~ element_def$trans_imp[3]*element_def$trans_imp[7],
A == "001" & O == "010" ~ element_def$trans_imp[3]*element_def$trans_imp[8],
A == "001" & O == "001" ~ element_def$trans_imp[3]*element_def$trans_imp[9])) %>%
dplyr::select(i)
#save as a vector
i_actor <- c(as.vector(element_def$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", eq)
#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(eq)
#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::tibble(opt_E = sol[1],
opt_P = sol[2],
opt_A = sol[3],
term = "actor")
#####OBJECT
ob_fsi <- c(element_def$f_s_i[7:9], 1, 1, 1, element_def$f_s_i[1:3])
i <- eq %>%
dplyr::mutate(i = dplyr::case_when(A == "000" & O == "000" ~ 1,
A == "100" & O == "000" ~ element_def$trans_imp[7],
A == "010" & O == "000" ~ element_def$trans_imp[8],
A == "001" & O == "000"~ element_def$trans_imp[9],
A == "000" & O == "100" ~ element_def$trans_imp[1],
A == "000" & O == "010" ~ element_def$trans_imp[2],
A == "000" & O == "001" ~ element_def$trans_imp[3],
A == "100" & O == "100"~ element_def$trans_imp[7]*element_def$trans_imp[1],
A == "100" & O == "010" ~ element_def$trans_imp[7]*element_def$trans_imp[2],
A == "100" & O == "001" ~ element_def$trans_imp[7]*element_def$trans_imp[3],
A == "010" & O == "100" ~ element_def$trans_imp[8]*element_def$trans_imp[1],
A == "010" & O == "010" ~ element_def$trans_imp[8]*element_def$trans_imp[2],
A == "010" & O == "001" ~ element_def$trans_imp[8]*element_def$trans_imp[3],
A == "001" & O == "100" ~ element_def$trans_imp[9]*element_def$trans_imp[1],
A == "001" & O == "010" ~ element_def$trans_imp[9]*element_def$trans_imp[2],
A == "001" & O == "001" ~ element_def$trans_imp[9]*element_def$trans_imp[3])) %>%
dplyr::select(i)
#save as a vector
i <- c(as.vector(ob_fsi), as.vector(i$i))
#make into a matrix with that on the diagonal
mat_i <- matrix(0, length(i), length(i))
diag(mat_i) <- i
#make a behavior selection matrix
b_s <- create_select_mat("behavior", eq)
#now which terms do not have behavior in them
i_s <- matrix(data = rep(1, length(i)), nrow = length(i))
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(eq)
#term 1 of equation
term1 <- t(b_s) %*% mat_i %*% h %*% mat_i %*% b_s
term1 <- solve(term1)
term1 <- -1*term1
#term 2 of the equation
term2 <- t(b_s) %*% mat_i %*% h %*% mat_i %*% g
#final solution
sol <- term1 %*% term2
#put into nicer format
opt_behavior_object <- tibble::tibble(opt_E = sol[1],
opt_P = sol[2],
opt_A = sol[3],
term = "object")
final <- rbind(opt_behavior_actor, opt_behavior_object)
return(final)
}