ensure id is chr, ensure id uniqueness

NAMESPACE

@@ -43,6 +43,10 @@ export(g6_add_plugin)
 export(g6_behaviors)
 export(g6_canvas_resize)
 export(g6_collapse_combo)
+export(g6_combos)
+export(g6_combos_ids)
+export(g6_edges)
+export(g6_edges_ids)
 export(g6_expand_combo)
 export(g6_fit_center)
 export(g6_focus_elements)
@@ -52,6 +56,8 @@ export(g6_get_nodes)
 export(g6_hide_elements)
 export(g6_igraph)
 export(g6_layout)
+export(g6_nodes)
+export(g6_nodes_ids)
 export(g6_options)
 export(g6_output)
 export(g6_plugins)
@@ -65,6 +71,7 @@ export(g6_set_edges)
 export(g6_set_nodes)
 export(g6_set_options)
 export(g6_show_elements)
+export(g6_state)
 export(g6_update_behavior)
 export(g6_update_combos)
 export(g6_update_edges)

R/g6.R

@@ -98,18 +98,12 @@ g6 <- function(
   elementId = NULL
 ) {
   # Convert data frames to lists of records
-  if (inherits(nodes, "data.frame")) {
-    nodes <- unname(split(nodes, seq(nrow(nodes))))
-    nodes <- lapply(nodes, function(node) as.list(node))
-  }
-  if (inherits(edges, "data.frame")) {
-    edges <- unname(split(edges, seq(nrow(edges))))
-    edges <- lapply(edges, function(edge) as.list(edge))
-  }
-  if (inherits(combos, "data.frame")) {
-    combos <- unname(split(combos, seq(nrow(combos))))
-    combos <- lapply(combos, function(combo) as.list(combo))
-  }
+  nodes <- process_g6_data(nodes, "node")
+  edges <- process_g6_data(edges, "edge")
+  combos <- process_g6_data(combos, "combo")
+
+  # Check that all ids are unique
+  ensure_unique_ids(get_ids())
 
   # Build properly named list of parameters to pass to widget
   x <- list(
@@ -122,9 +116,11 @@ g6 <- function(
     )
   )
 
-  # In case we need it ...
+  # Cleanup global ids for the next time the function is
+  # called
   hookFunc <- function(widget) {
-    # TBD
+    reset_ids()
+    return(widget)
   }
 
   # create widget
@@ -135,7 +131,7 @@ g6 <- function(
     height = height,
     package = "g6R",
     elementId = elementId,
-    preRenderHook = NULL
+    preRenderHook = hookFunc
   )
 }
 

R/proxy.R

@@ -34,23 +34,44 @@ g6_proxy <- function(id, session = shiny::getDefaultReactiveDomain()) {
 g6_data <- function(graph, el, action, type) {
   if (!any(class(graph) %in% "g6_proxy")) {
     stop(
-      "Can't use g6_add_* with g6 object. Only within shiny and using g6_proxy"
+      "This function only works with a g6_proxy object."
     )
   }
+
+  reset_ids()
+
   if (action != "remove") {
-    if (inherits(el, "data.frame")) {
-      el <- lapply(seq_len(nrow(el)), \(i) {
-        setNames(as.list(el[i, ]), colnames(el))
-      })
+    # UPDATE/ADD
+    if (action != "get") {
+      attr(el, "type") <- tolower(type)
+      if (inherits(el, "data.frame")) {
+        el <- df_to_list(el)
+      } else {
+        if (action != "set") {
+          el <- convert_id_to_chr(el)
+        }
+        if (action == "update") {
+          ids <- unlist(lapply(el, `[[`, "id"))
+          check_if_in_graph(ids, graph)
+        }
+      }
+      # GET
+    } else {
+      el <- as.character(el)
     }
   } else {
+    # REMOVE
     if (!is.null(el)) {
       if (length(el) == 1) {
         el <- list(el)
       }
+      check_if_in_graph(unlist(el), graph)
     }
   }
 
+  # Check that all ids are unique
+  ensure_unique_ids(get_ids())
+
   graph$session$sendCustomMessage(
     sprintf("%s_g6-data", graph$id),
     list(el = el, action = action, type = type)
@@ -400,7 +421,9 @@ g6_fit_center <- function(graph, animation = NULL) {
     stopifnot(is.list(animation))
   }
 
-  if (is.null(animation)) animation <- list()
+  if (is.null(animation)) {
+    animation <- list()
+  }
 
   graph$session$sendCustomMessage(
     sprintf("%s_g6-fit-center", graph$id),
@@ -417,6 +440,9 @@ g6_element_action <- function(graph, ids, animation = NULL, action) {
     )
   }
 
+  # Target element that exists
+  check_if_in_graph(ids, graph)
+
   graph$session$sendCustomMessage(
     sprintf("%s_g6-element-action", graph$id),
     list(ids = ids, animation = animation, action = action)
@@ -497,6 +523,9 @@ g6_combo_action <- function(graph, id, options = NULL, action) {
     )
   }
 
+  # Target element that exists
+  check_if_in_graph(id, graph)
+
   graph$session$sendCustomMessage(
     sprintf("%s_g6-combo-action", graph$id),
     list(id = id, options = options, action = action)

R/state.R

@@ -0,0 +1,100 @@
+#' Get state of g6 instance
+#'
+#' These functions query the current state of a g6 instance in a Shiny app to
+#' extract information about nodes, edges, and combos.
+#'
+#' @param graph A g6_proxy object created with \code{\link{g6_proxy}}.
+#' @export
+#' @note Only works from the server of a Shiny app.
+#' @rdname g6-state
+#' @return A list containing the state of the g6 instance,
+#' which includes nodes, edges, and combos.
+g6_state <- function(graph) {
+  if (!any(class(graph) %in% "g6_proxy")) {
+    stop(
+      "g6_state functions only work with g6_proxy object."
+    )
+  }
+  if (nchar(graph$session$ns("")) > 0) {
+    graph$id <- strsplit(graph$id, graph$session$ns(""))[[1]][2]
+  }
+  graph$session$input[[sprintf("%s-state", graph$id)]]
+}
+
+#' Get nodes state of g6 instance
+#'
+#' @export
+#' @rdname g6-state
+#' @return A list of nodes in the g6 instance.
+g6_nodes <- function(graph) {
+  state <- g6_state(graph)
+  if (is.null(state)) {
+    return(NULL)
+  }
+  state$nodes
+}
+
+#' Get nodes ids of g6 instance
+#'
+#' @export
+#' @rdname g6-state
+#' @return A vector of node ids in the g6 instance.
+g6_nodes_ids <- function(graph) {
+  nodes <- g6_nodes(graph)
+  if (is.null(nodes)) {
+    return(NULL)
+  }
+  sapply(nodes, `[[`, "id")
+}
+
+#' Get edges state of g6 instance
+#'
+#' @export
+#' @rdname g6-state
+#' @return A list of edges in the g6 instance.
+g6_edges <- function(graph) {
+  state <- g6_state(graph)
+  if (is.null(state)) {
+    return(NULL)
+  }
+  state$edges
+}
+
+#' Get edges ids of g6 instance
+#'
+#' @export
+#' @rdname g6-state
+#' @return A vector of edge ids in the g6 instance.
+g6_edges_ids <- function(graph) {
+  edges <- g6_edges(graph)
+  if (is.null(edges)) {
+    return(NULL)
+  }
+  sapply(edges, `[[`, "id")
+}
+
+#' Get combos state of g6 instance
+#'
+#' @export
+#' @rdname g6-state
+#' @return A list of combos in the g6 instance.
+g6_combos <- function(graph) {
+  state <- g6_state(graph)
+  if (is.null(state)) {
+    return(NULL)
+  }
+  state$combos
+}
+
+#' Get combo ids of g6 instance
+#'
+#' @export
+#' @rdname g6-state
+#' @return A vector of combo ids in the g6 instance.
+g6_combos_ids <- function(graph) {
+  combos <- g6_combos(graph)
+  if (is.null(combos)) {
+    return(NULL)
+  }
+  sapply(combos, `[[`, "id")
+}

R/utils.R

@@ -3,6 +3,111 @@ dropNulls <- function(x) {
   x[!vapply(x, is.null, FUN.VALUE = logical(1))]
 }
 
+g6_globals <- new.env()
+
+#' @keywords internal
+get_ids <- function() {
+  get0("ids", envir = g6_globals, inherits = FALSE)
+}
+
+#' @keywords internal
+reset_ids <- function() {
+  assign("ids", NULL, envir = g6_globals)
+}
+
+#' @keywords internal
+add_id_to_globals <- function(id) {
+  assign(
+    "ids",
+    c(get_ids(), id),
+    envir = g6_globals,
+    inherits = FALSE
+  )
+  invisible()
+}
+
+#' @keywords internal
+process_g6_data <- function(dat, type) {
+  if (!is.null(dat)) {
+    attr(dat, "type") <- type
+    if (inherits(dat, "data.frame")) {
+      dat <- df_to_list(dat)
+    } else {
+      dat <- convert_id_to_chr(dat)
+    }
+  }
+}
+
+#' @keywords internal
+df_to_list <- function(df) {
+  lst <- unname(split(df, seq(nrow(df))))
+  lapply(lst, function(row) {
+    el <- as.list(row)
+    if (attr(df, "type") == "edge") {
+      el$id <- paste(el$source, el$target, sep = "-")
+    } else {
+      el$id <- as.character(el$id)
+    }
+    add_id_to_globals(el$id)
+    el
+  })
+}
+
+#' @keywords internal
+convert_id_to_chr <- function(lst) {
+  if (attr(lst, "type") == "edge") {
+    lapply(lst, function(el) {
+      if (is.null(el[["id"]])) {
+        el[["id"]] <- paste(el[["source"]], el[["target"]], sep = "-")
+      } else {
+        if (!is.character(el[["id"]])) {
+          el[["id"]] <- as.character(el[["id"]])
+        }
+      }
+      add_id_to_globals(el[["id"]])
+      el
+    })
+  } else {
+    lapply(lst, function(el) {
+      if (!is.character(el[["id"]])) {
+        el[["id"]] <- as.character(el[["id"]])
+      }
+      add_id_to_globals(el[["id"]])
+      el
+    })
+  }
+}
+
+#' @keywords internal
+ensure_unique_ids <- function(ids) {
+  duplicated <- which(duplicated(ids))
+  if (length(duplicated)) {
+    reset_ids()
+    stop(
+      sprintf(
+        "issue in %s. Some nodes, edges or combos ids are duplicated: '%s'.",
+        deparse(sys.call(which = -2)),
+        paste(ids[duplicated], collapse = ", ")
+      )
+    )
+  }
+}
+
+#' @keywords internal
+check_if_in_graph <- function(el, graph) {
+  all_ids <- c(g6_nodes_ids(graph), g6_edges_ids(graph), g6_combos_ids(graph))
+  res <- which(!(el %in% all_ids))
+  if (length(res)) {
+    stop(
+      sprintf(
+        "issue in %s, target element(s) with id(s) '%s' not in the graph.",
+        deparse(sys.call(which = -2)),
+        paste(el[res], collapse = ", ")
+      )
+    )
+  }
+}
+
 #' Marks as string to be processed as a JS function
 #'
 #' Useful for htmlwidgets
@@ -12,9 +117,12 @@ dropNulls <- function(x) {
 #' @export
 JS <- function(...) {
   x <- c(...)
-  if (is.null(x)) return()
-  if (!is.character(x))
+  if (is.null(x)) {
+    return()
+  }
+  if (!is.character(x)) {
     stop("The arguments for JS() must be a character vector")
+  }
   x <- paste(x, collapse = "\n")
   structure(x, class = unique(c("JS_EVAL", oldClass(x))))
 }

R/zzz.R

@@ -0,0 +1,4 @@
+.onLoad <- function(libname, pkgname) {
+  reset_ids()
+  invisible(NULL)
+} # nocov end