1#' Set edge attribute values
2#'
3#' From a graph object of class `dgr_graph`, set edge attribute values for one
4#' or more edges.
5#'
6#' @inheritParams render_graph
7#' @param edge_attr The name of the attribute to set.
8#' @param values The values to be set for the chosen attribute for the chosen
9#'   edges.
10#' @param from An optional vector of node IDs from which the edge is outgoing
11#'   for filtering list of nodes with outgoing edges in the graph.
12#' @param to An optional vector of node IDs from which the edge is incoming for
13#'   filtering list of nodes with incoming edges in the graph.
14#'
15#' @return A graph object of class `dgr_graph`.
16#'
17#' @examples
18#' # Create a simple graph
19#' ndf <-
20#'   create_node_df(
21#'     n = 4,
22#'     type = "basic",
23#'     label = TRUE,
24#'     value = c(3.5, 2.6, 9.4, 2.7))
25#'
26#' edf <-
27#'   create_edge_df(
28#'     from = c(1, 2, 3),
29#'     to = c(4, 3, 1),
30#'     rel = "leading_to")
31#'
32#' graph <-
33#'   create_graph(
34#'     nodes_df = ndf,
35#'     edges_df = edf)
36#'
37#' # Set attribute `color = "green"`
38#' # for edges `1`->`4` and `3`->`1`
39#' # in the graph
40#' graph <-
41#'   graph %>%
42#'   set_edge_attrs(
43#'     edge_attr = color,
44#'     values = "green",
45#'     from = c(1, 3),
46#'     to = c(4, 1))
47#'
48#' # Set attribute `color = "blue"`
49#' # for all edges in the graph
50#' graph <-
51#'   graph %>%
52#'   set_edge_attrs(
53#'     edge_attr = color,
54#'     values = "blue")
55#'
56#' # Set attribute `color = "pink"`
57#' # for all edges in graph outbound
58#' # from node with ID value `1`
59#' graph <-
60#'   graph %>%
61#'   set_edge_attrs(
62#'     edge_attr = color,
63#'     values = "pink",
64#'     from = 1)
65#'
66#' # Set attribute `color = "black"`
67#' # for all edges in graph inbound
68#' # to node with ID `1`
69#' graph <-
70#'   graph %>%
71#'   set_edge_attrs(
72#'     edge_attr = color,
73#'     values = "black",
74#'     to = 1)
75#'
76#' @import rlang
77#' @family Edge creation and removal
78#' @export
79set_edge_attrs <- function(graph,
80                           edge_attr,
81                           values,
82                           from = NULL,
83                           to = NULL) {
84
85  # Get the time of function start
86  time_function_start <- Sys.time()
87
88  # Get the name of the function
89  fcn_name <- get_calling_fcn()
90
91  # Get the requested `edge_attr`
92  edge_attr <-
93    rlang::enquo(edge_attr) %>% rlang::get_expr() %>% as.character()
94
95  if (edge_attr %in% c("id", "from", "to")) {
96
97    emit_error(
98      fcn_name = fcn_name,
99      reasons = "You cannot alter edge ID values or attributes associated with node IDs")
100  }
101
102  if (!is.null(from) & !is.null(to)) {
103    if (length(from) != length(to)) {
104
105      emit_error(
106        fcn_name = fcn_name,
107        reasons = "The number of values specified in `from` and `to` must be the same")
108    }
109  }
110
111  # Extract the graph's edf
112  edf <- graph$edges_df
113
114  if (length(values) != 1 &
115      length(values) != nrow(edf)) {
116
117    emit_error(
118      fcn_name = fcn_name,
119      reasons = "The length of values provided must either be 1 or that of the number of rows in the edf")
120  }
121
122  # Get the indices for the edge data frame
123  # that require modification
124  if (is.null(from) & !is.null(to)) {
125    indices <-
126      which(edf$to %in% to)
127  } else if (!is.null(from) & is.null(to)) {
128    indices <-
129      which(edf$from %in% from)
130  } else if (is.null(from) & is.null(to)) {
131    indices <- 1:nrow(edf)
132  } else {
133    indices <-
134      which((edf$from %in% from) &
135              (edf$to %in% to))
136  }
137
138  # Apply single value to all target edges
139  if (length(values) == 1) {
140
141    if (edge_attr %in% colnames(edf)) {
142
143      edf[indices,
144          which(colnames(edf) %in%
145                  edge_attr)] <- values
146    }
147
148    if (!(edge_attr %in% colnames(edf))) {
149
150      # Add a new column and map the edge attribute
151      # value to each of the indices in `edges_df`
152      edf <-
153        dplyr::mutate(
154          edf,
155          new_attr__ = ifelse(as.numeric(row.names(edf)) %in%
156                                indices, values, NA))
157
158      colnames(edf)[ncol(edf)] <- edge_attr
159    }
160  }
161
162  if (length(values) == nrow(edf)) {
163
164    if (edge_attr %in% colnames(edf)) {
165      edf[, which(colnames(edf) %in%
166                    edge_attr)] <- values
167    }
168
169    if (!(edge_attr %in% colnames(edf))) {
170      edf <-
171        cbind(edf,
172              rep(as.character(NA), nrow(edf)))
173
174      edf[, ncol(edf)] <-
175        edf[, ncol(edf)]
176
177      colnames(edf)[ncol(edf)] <- edge_attr
178
179      edf[, ncol(edf)] <- values
180    }
181  }
182
183  # Update the graph object
184  graph$edges_df = edf
185
186  # Update the `graph_log` df with an action
187  graph$graph_log <-
188    add_action_to_log(
189      graph_log = graph$graph_log,
190      version_id = nrow(graph$graph_log) + 1,
191      function_used = fcn_name,
192      time_modified = time_function_start,
193      duration = graph_function_duration(time_function_start),
194      nodes = nrow(graph$nodes_df),
195      edges = nrow(graph$edges_df))
196
197  # Write graph backup if the option is set
198  if (graph$graph_info$write_backups) {
199    save_graph_as_rds(graph = graph)
200  }
201
202  graph
203}
204