11# Handlers for the client Pull Requests (HTTP GET/POST)
22
3+ capture_str <- function (object , max_level = 0L ) {
4+ paste0(utils :: capture.output(
5+ utils :: str(object ,
6+ max.level = max_level ,
7+ give.attr = FALSE ,
8+ vec.len = 1L
9+ )
10+ ), collapse = " \n " )
11+ }
12+
13+ try_capture_str <- function (object , max_level = 0L ) {
14+ tryCatch(
15+ capture_str(object , max_level ),
16+ error = function (e ) paste0(class(object ), collapse = " , " )
17+ )
18+ }
19+
20+ workspace_child_count <- function (object ) {
21+ if (is.environment(object )) {
22+ length(object )
23+ } else if (isS4(object )) {
24+ length(methods :: slotNames(object ))
25+ } else if (typeof(object ) %in% c(" list" , " pairlist" )) {
26+ length(object )
27+ } else {
28+ 0L
29+ }
30+ }
31+
332get_workspace_data <- function () {
433 env <- .GlobalEnv
5- all_names <- ls(env )
34+ all_names <- ls(env , sorted = FALSE )
635
736 objs <- lapply(all_names , function (name ) {
37+ if (bindingIsActive(name , env )) {
38+ return (list (
39+ class = " active_binding" ,
40+ type = " active_binding" ,
41+ length = 0L ,
42+ str = " (active-binding)" ,
43+ has_children = FALSE
44+ ))
45+ }
46+
847 obj <- env [[name ]]
9- list (
48+ obj_class <- class(obj )
49+ obj_type <- typeof(obj )
50+ obj_length <- length(obj )
51+ obj_dim <- dim(obj )
52+ first_class <- if (length(obj_class )) obj_class [[1 ]] else obj_type
53+ info <- list (
1054 class = class(obj ),
11- type = typeof(obj ),
12- length = length(obj ),
13- # Create a concise string representation
14- str = paste0(
15- utils :: capture.output(utils :: str(obj , max.level = 0 , give.attr = FALSE )),
16- collapse = " \n "
17- )
55+ type = obj_type ,
56+ length = obj_length ,
57+ str = if (! is.null(obj_dim )) {
58+ paste0(first_class , " : " , paste(obj_dim , collapse = " x " ))
59+ } else if (obj_type == " environment" ) {
60+ " <environment>"
61+ } else if (obj_type %in% c(" closure" , " builtin" )) {
62+ trimws(try_capture_str(obj ))
63+ } else {
64+ paste0(first_class , " , length " , obj_length )
65+ },
66+ has_children = workspace_child_count(obj ) > 0L
1867 )
68+
69+ obj_names <- if (is.object(obj )) {
70+ utils :: .DollarNames(obj , pattern = " " )
71+ } else if (is.recursive(obj )) {
72+ names(obj )
73+ } else {
74+ NULL
75+ }
76+ if (length(obj_names )) {
77+ info $ names <- obj_names
78+ }
79+ if (isS4(obj )) {
80+ info $ slots <- methods :: slotNames(obj )
81+ }
82+ if (! is.null(obj_dim )) {
83+ info $ dim <- obj_dim
84+ }
85+ info
1986 })
2087 names(objs ) <- all_names
2188
@@ -26,16 +93,113 @@ get_workspace_data <- function() {
2693 )
2794}
2895
96+ workspace_object <- function (name , path = list ()) {
97+ object <- get(name , envir = .GlobalEnv , inherits = FALSE )
98+ for (selector in path ) {
99+ object <- switch (selector $ kind ,
100+ index = object [[as.integer(selector $ value )]],
101+ name = get(selector $ value , envir = object , inherits = FALSE ),
102+ slot = methods :: slot(object , selector $ value ),
103+ stop(" Unknown workspace selector" )
104+ )
105+ }
106+ object
107+ }
108+
109+ workspace_child_page_size <- 500L
110+
111+ workspace_child_item <- function (object , str , selector ) {
112+ list (
113+ str = str ,
114+ class = paste(class(object ), collapse = " , " ),
115+ type = typeof(object ),
116+ has_children = workspace_child_count(object ) > 0L ,
117+ selector = selector
118+ )
119+ }
120+
121+ workspace_child_label <- function (name , index ) {
122+ if (! is.null(name ) && ! is.na(name ) && nzchar(name )) {
123+ paste0(" $ " , name )
124+ } else {
125+ paste0(" [[" , index , " ]]" )
126+ }
127+ }
128+
129+ get_workspace_children <- function (name , path = list (), start = 1L ) {
130+ tryCatch({
131+ object <- workspace_object(name , path )
132+ child_count <- workspace_child_count(object )
133+ if (child_count == 0L ) {
134+ return (list (children = I(list ()), next_start = NULL ))
135+ }
136+
137+ start <- max(1L , as.integer(start ))
138+ end <- min(child_count , start + workspace_child_page_size - 1L )
139+ if (start > end ) {
140+ return (list (children = I(list ()), next_start = NULL ))
141+ }
142+
143+ children <- if (is.environment(object )) {
144+ child_names <- ls(object , sorted = FALSE )[seq.int(start , end )]
145+ lapply(child_names , function (child_name ) {
146+ if (bindingIsActive(child_name , object )) {
147+ list (
148+ str = paste0(" $ " , child_name , " : (active-binding)" ),
149+ class = " active_binding" ,
150+ type = " active_binding" ,
151+ has_children = FALSE
152+ )
153+ } else {
154+ child <- get(child_name , envir = object , inherits = FALSE )
155+ workspace_child_item(
156+ child ,
157+ paste0(" $ " , child_name , " : " , trimws(try_capture_str(child ))),
158+ list (kind = " name" , value = child_name )
159+ )
160+ }
161+ })
162+ } else if (isS4(object )) {
163+ child_names <- methods :: slotNames(object )[seq.int(start , end )]
164+ lapply(child_names , function (child_name ) {
165+ child <- methods :: slot(object , child_name )
166+ workspace_child_item(
167+ child ,
168+ paste0(" @ " , child_name , " : " , trimws(try_capture_str(child ))),
169+ list (kind = " slot" , value = child_name )
170+ )
171+ })
172+ } else {
173+ indices <- seq.int(start , end )
174+ child_names <- names(object )
175+ lapply(indices , function (index ) {
176+ child <- object [[index ]]
177+ child_name <- if (is.null(child_names )) NULL else child_names [[index ]]
178+ workspace_child_item(
179+ child ,
180+ paste0(
181+ workspace_child_label(child_name , index ),
182+ " : " ,
183+ trimws(try_capture_str(child ))
184+ ),
185+ list (kind = " index" , value = index )
186+ )
187+ })
188+ }
189+
190+ list (
191+ children = I(children ),
192+ next_start = if (end < child_count ) end + 1L else NULL
193+ )
194+ }, error = function (e ) list (children = I(list ()), next_start = NULL ))
195+ }
196+
29197handle_hover <- function (expr_str ) {
30198 tryCatch(
31199 {
32200 expr <- parse(text = expr_str , keep.source = FALSE )[[1 ]]
33201 obj <- eval(expr , .GlobalEnv )
34- str_preview <- paste0(
35- utils :: capture.output(utils :: str(obj , max.level = 0 , give.attr = FALSE )),
36- collapse = " \n "
37- )
38- list (str = str_preview )
202+ list (str = capture_str(obj ))
39203 },
40204 error = function (e ) NULL
41205 )
@@ -77,7 +241,7 @@ handle_complete <- function(expr_str, trigger = NULL) {
77241 }))
78242 }
79243
80- if (trigger == " @" && methods :: isS4(obj )) {
244+ if (trigger == " @" && isS4(obj )) {
81245 nms <- methods :: slotNames(obj )
82246 return (lapply(nms , function (n ) {
83247 item <- methods :: slot(obj , n )
0 commit comments