hafen / trelliscopejs
1
#' Create a Trelliscope Display
2
#'
3
#' @param x an object to create at trelliscope display for
4
#' @param name name of the display
5
#' @param group group that the display belongs to
6
#' @param panel_col optional string specifying the column to use for panels (if there are multiple plot columns in \code{x})
7
#' @param desc optional text description of the display
8
#' @param md_desc optional string of markdown that will be shown in the viewer for additional context about the display
9
#' @param path the base directory of the trelliscope application
10
#' @param height height in pixels of each panel
11
#' @param width width in pixels of each panel
12
#' @param auto_cog should auto cogs be computed (if possible)?
13
#' @param state the initial state the display will open in
14
#' @param nrow the number of rows of panels to display by default
15
#' @param ncol the number of columns of panels to display by default
16
#' @param jsonp should json for display object be jsonp (TRUE) or json (FALSE)?
17
#' @param split_sig optional string that specifies the "signature" of the data splitting. If not specified, this is calculated as the md5 hash of the sorted unique facet variables. This is used to identify "related displays" - different displays that are based on the same faceting scheme. This parameter should only be specified manually if a display's faceting is mostly similar to another display's.
18
#' @param self_contained should the Trelliscope display be a self-contained html document? (see note)
19
#' @param thumb should a thumbnail be created?
20
#' @note Note that \code{self_contained} is severely limiting and should only be used in cases where you would either like your display to show up in the RStudio viewer pane, in an interactive R Markdown Notebook, or in a self-contained R Markdown html document.
21
#' @example man-roxygen/ex-trelliscope.R
22
#' @export
23 1
trelliscope <- function(x, name, group = "common", panel_col = NULL, desc = "",
24 1
  md_desc = "", path, height = 500, width = 500, auto_cog = FALSE, state = NULL,
25 1
  nrow = 1, ncol = 1, jsonp = TRUE, split_sig = NULL, self_contained = FALSE,
26 1
  thumb = FALSE)
27 1
  UseMethod("trelliscope")
28

29
#' @export
30
trelliscope.data.frame <- function(x, name, group = "common", panel_col = NULL,
31
  desc = "", md_desc = "", path = NULL, height = 500, width = 500, auto_cog = FALSE,
32
  state = NULL, nrow = 1, ncol = 1, jsonp = TRUE, split_sig = NULL,
33
  self_contained = FALSE, thumb = FALSE) {
34

35 1
  img_local <- FALSE
36

37 1
  panel_img_col <- names(which(unlist(lapply(x, function(a) {
38 1
    tp <- attr(a, "cog_attrs")$type
39 1
    if (is.null(tp))
40 1
      return(FALSE)
41 0
    if (tp == "panelSrc")
42 0
      return(TRUE)
43
  }))))
44

45 1
  if (length(panel_img_col) == 0)
46 1
    panel_img_col <- NULL
47

48 1
  panel_img_local_col <- names(which(unlist(lapply(x, function(a) {
49 1
    tp <- attr(a, "cog_attrs")$type
50 1
    if (is.null(tp))
51 1
      return(FALSE)
52 0
    if (tp == "panelSrcLocal")
53 0
      return(TRUE)
54
  }))))
55

56 1
  if (length(panel_img_local_col) == 0) {
57 1
    panel_img_local_col <- NULL
58
  } else {
59 0
    panel_img_col <- panel_img_local_col
60 0
    img_local <- TRUE
61
  }
62

63
  # if the user specified panel_col, ignore panel_img_col unless they're the same
64 1
  if (!is.null(panel_col) && !is.null(panel_img_col)) {
65 0
    if (panel_col == panel_img_col) {
66 0
      panel_col <- NULL
67
    } else {
68 0
      panel_img_col <- NULL
69
    }
70
  }
71

72 1
  if (is.null(panel_col) && is.null(panel_img_col)) {
73 1
    classes <- unlist(lapply(x, function(a) class(a)[1]))
74 1
    panel_col <- names(which(classes == "trelliscope_panels"))
75

76 1
    if (length(panel_col) > 1) {
77 0
      panel_col <- panel_col[1]
78 0
      message("Multiple columns containing panels were found. Using ", panel_col, ".",
79 0
        "To explicitly specify which column to use, use the argument 'panel_col'.")
80
    }
81
  }
82

83 1
  if (length(panel_col) != 1 && length(panel_img_col) != 1)
84 0
    stop_nice("A column containing the panel to be plotted must be specified",
85 0
      "using map_plot() or similar, or img_panel().")
86

87 1
  cog_info <- cog_df_info(
88 1
    x,
89 1
    panel_col = panel_col,
90 1
    state = state,
91 1
    auto_cog = auto_cog
92
  )
93 1
  cog_df <- cog_info$cog_df
94 1
  cond_cols <- cog_info$cond_cols
95 1
  state <- cog_info$state
96

97 1
  params <- resolve_app_params(path, self_contained, jsonp, split_sig, name, group,
98 1
    state, nrow, ncol, thumb)
99

100 1
  keys <- apply(x[cond_cols], 1, function(a) paste(a, collapse = "_")) %>%
101 1
    sanitize()
102 1
  x$panelKey <- keys # nolint
103

104 1
  if (length(panel_img_col) == 0) {
105 1
    panels <- x[[panel_col]]
106 1
    names(panels) <- keys
107
  } else {
108
    # don't need to write panels because they are supplied with img_panel
109 0
    panels <- list(structure(list(), class = "img_panel"))
110
  }
111

112
  # need to start progress bar before writing panels
113 1
  pb <- progress::progress_bar$new(
114 1
    format = ":what [:bar] :percent :current/:total eta::eta",
115 1
    total = 5 + length(panels), width = getOption("width") - 8)
116 1
  pb$tick(0, tokens = list(what = "calculating         "))
117

118 1
  if (length(panel_img_col) == 0) {
119 1
    write_panels(
120 1
      panels,
121 1
      base_path = params$path,
122 1
      name = params$name,
123 1
      width = width,
124 1
      height = height,
125 1
      group = params$group,
126 1
      jsonp = params$jsonp,
127 1
      pb = pb
128
    )
129
  } else {
130 0
    if (img_local) {
131 0
      ff <- list.files(params$www_dir, recursive = TRUE)
132 0
      pths <- cog_df[[panel_img_col]]
133 0
      chk <- length(which(pths %in% ff)) / length(pths)
134 0
      if (chk < 0.5)
135 0
        warning("Only found ", round(chk * 100), "% of specified local image in ",
136 0
          params$www_dir, ". Please double check your path specified for local images.")
137
    }
138

139 0
    pb$tick(tokens = list(what = "writing panels      "))
140
  }
141

142 1
  write_display_obj(
143 1
    cog_df,
144 1
    panel_example = panels[[1]],
145 1
    panel_img_col = panel_img_col,
146 1
    base_path = params$path,
147 1
    id = params$id,
148 1
    name = params$name,
149 1
    group = params$group,
150 1
    desc = desc,
151 1
    height = height,
152 1
    width = width,
153 1
    md_desc = md_desc,
154 1
    state = params$state,
155 1
    jsonp = params$jsonp,
156 1
    split_sig = params$split_sig,
157 1
    self_contained = params$self_contained,
158 1
    thumb = params$thumb,
159 1
    pb = pb
160
  )
161

162 1
  prepare_display(params$path, params$id, params$self_contained, params$jsonp, pb = pb)
163

164 1
  trelliscope_widget(
165 1
    id = params$id,
166 1
    www_dir = params$www_dir,
167 1
    latest_display = list(name = params$name, group = params$group),
168 1
    self_contained = params$self_contained,
169 1
    dependencies = get_dependencies(panels[[1]]),
170 1
    config_info = params$config_path,
171 1
    spa = params$spa,
172 1
    sc_deps = get_dependencies(panels[[1]])
173
  )
174
}
175

176
# hacky way to get cond_cols:
177
#   (ideally, we'd use groups(), but dplyr peels one group off after summarise)
178
#   we know grouped variables show up first
179
#   so iterate through until their combination is unique
180
find_cond_cols <- function(x, is_nested) {
181

182
  # if (is_nested)
183
  #   return(names(x))
184

185 1
  nn <- nrow(x)
186 1
  nms <- names(x)
187 1
  cond_cols <- NULL
188

189 1
  if (length(unique(x[[1]])) == nn) {
190 1
    cond_cols <- nms[1]
191
  } else {
192 1
    for (i in seq_len(ncol(x))[-1]) {
193 1
      if (length(unique(do.call(paste, c(x[1:i], sep = "_")))) == nn) {
194 1
        cond_cols <- nms[1:i]
195 1
        break
196
      }
197
    }
198
  }
199

200
  # for (i in seq_len(ncol(x))) {
201
  #   n_unique <- length(unique(do.call(paste, c(x[1:i], sep = "_"))))
202
  #   if (n_unique == nn && i == ncol(x)) {
203
  #     cond_cols <- nms[seq_len(i)]
204
  #     break
205
  #   } else if (n_unique > nn && i > 1) {
206
  #     cond_cols <- nms[seq_len(i - 1)]
207
  #     break
208
  #   }
209
  # }
210

211 1
  if (is.null(cond_cols)) {
212 0
    stop_nice("Could not find unique group variables...")
213
  }
214

215 1
  cond_cols
216
}
217

218
# hacky way to see if the tbl has been sorted after summarise:
219
#   if none of the facet variables are still sorted but another variable is
220
#   then the user must have sorted on that variable
221
#   note: this will only detect first-order sorting...
222
find_sort_cols <- function(x) {
223 1
  if (ncol(x) == 0)
224 1
    return(tibble())
225

226 1
  sortable <- names(x)[sapply(x, is.atomic)]
227

228 1
  res <- lapply(sortable,
229 1
    function(nm) {
230 1
      res <- tibble(name = nm, dir = NA)
231 1
      if (!is.unsorted(x[[nm]], na.rm = TRUE)) {
232 0
        res$dir <- "asc"
233 1
      } else if (!is.unsorted(rev(x[[nm]]), na.rm = TRUE)) {
234 1
        res$dir <- "desc"
235
      }
236 1
      res
237
    }
238 1
  ) %>% bind_rows()
239

240 1
  res %>% filter_(~ !is.na(dir))
241
}

Read our documentation on viewing source code .

Loading