├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── R ├── create_hist.R ├── make_xray.R ├── make_xray_core.R ├── report_xray.R ├── style_nested_tabs.R └── view_xray.R ├── README.md ├── dataxray.Rproj ├── ggplot2_Diamonds_xray.rmd ├── index.html ├── index.png ├── inst └── templates │ ├── hex_xray.png │ └── report_xray.rmd └── man ├── create_hist.Rd ├── make_xray.Rd ├── make_xray_core.Rd ├── nested_tab_counts.Rd ├── nested_tab_extremes.Rd ├── nested_tab_theme.Rd ├── nested_tab_values.Rd ├── report_xray.Rd └── view_xray.Rd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | inst/hex 4 | ^rmd$ 5 | ^adsl_describer\.html$ 6 | ^adsl_describer\.rmd$ 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: dataxray 2 | Type: Package 3 | Title: An interactive table interface for data summaries 4 | Version: 0.1.0 5 | Author: Agustin Calatroni, Becca Krouse, Stephanie Lussier 6 | Maintainer: Agustin Calatroni 7 | Description: The dataxray package is an interactive framework for viewing data summaries 8 | produced by Frank Harrell's Hmisc::describe and powered by reactable. 9 | License: MIT 10 | Encoding: UTF-8 11 | LazyData: true 12 | Depends: 13 | R (>= 2.10) 14 | Imports: 15 | tidyverse, 16 | haven, 17 | lubridate, 18 | Hmisc, 19 | plotly, 20 | htmltools, 21 | shiny, 22 | reactable (>= 0.2.3.9000), 23 | reactablefmtr (>= 1.1.0) 24 | Suggests: 25 | crosstalk 26 | RoxygenNote: 7.1.2 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Agustin Calatroni 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(create_hist,Date) 4 | S3method(create_hist,POSIXct) 5 | S3method(create_hist,POSIXlt) 6 | S3method(create_hist,character) 7 | S3method(create_hist,factor) 8 | S3method(create_hist,numeric) 9 | S3method(create_hist,timePOSIXt) 10 | export(create_hist) 11 | export(make_xray) 12 | export(make_xray_core) 13 | export(report_xray) 14 | export(view_xray) 15 | import(dplyr) 16 | import(forcats) 17 | import(htmltools) 18 | import(plotly) 19 | import(purrr) 20 | import(reactable) 21 | import(reactablefmtr) 22 | import(tidyr) 23 | importFrom(Hmisc,describe) 24 | importFrom(Hmisc,htmlSN) 25 | importFrom(Hmisc,plotlyParm) 26 | importFrom(dplyr,"%>%") 27 | importFrom(htmltools,span) 28 | importFrom(htmltools,tags) 29 | importFrom(purrr,map) 30 | importFrom(reactablefmtr,fivethirtyeight) 31 | importFrom(shiny,icon) 32 | importFrom(tibble,enframe) 33 | -------------------------------------------------------------------------------- /R/create_hist.R: -------------------------------------------------------------------------------- 1 | #' Create interactive histogram 2 | #' 3 | #' Code adapted from Hmisc package's spike histograms. 4 | #' 5 | #' @importFrom dplyr %>% 6 | #' @import forcats 7 | #' @importFrom Hmisc htmlSN plotlyParm 8 | #' @import plotly 9 | #' 10 | #' @param x Variable from dataset in vector form. 11 | #' @param counts Counts component of Hmisc::describe() output 12 | #' @param values Values component of Hmisc::describe() output 13 | #' 14 | #' @return Plotly figure containing spike histogram (numeric) or traditional histogram (character). 15 | #' 16 | #' @examples 17 | #' adsl <- safetyData::adam_adsl 18 | #' create_hist(adsl$AGE) 19 | #' create_hist(adsl$SITEID) 20 | #' 21 | #' @export 22 | create_hist <- function(x, counts, values) { 23 | UseMethod("create_hist", x) 24 | } 25 | 26 | #' @export 27 | create_hist.character <- function(x, counts, values){ 28 | 29 | y <- -1 30 | fmt <- function(x) Hmisc::htmlSN(x, digits=5) 31 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 32 | 33 | n_distinct <- counts[["distinct"]] %>% as.numeric 34 | 35 | if (n_distinct>0){ 36 | dh <- data.frame(x = as.character(values$value), freq = values$frequency, y = y) %>% 37 | mutate(prop = freq/sum(freq), 38 | txt = paste0(x, '
', round(prop, 3), '
n=', freq)) 39 | 40 | if (is.factor(x)){ 41 | x_levs <- levels(x) 42 | dh <- dh %>% mutate(x = factor(x, levels = x_levs)) 43 | } else { 44 | if (n_distinct > 30){ 45 | dh <- dh %>% 46 | arrange(x) %>% 47 | mutate(x = factor(x)) 48 | } else { 49 | dh <- dh %>% 50 | mutate(x = fct_reorder(x, prop) %>% fct_rev) 51 | } 52 | } 53 | 54 | min_width = 50 55 | max_width = 250 56 | 57 | dh$prop <- 0.6 * dh$prop / max(dh$prop) # scale the proportions 58 | 59 | width <- ifelse(n_distinct == 1, 17, 60 | ifelse(n_distinct == 2, 35, 61 | ifelse(n_distinct == 3, min_width, 62 | ifelse(n_distinct < max_width, scales::rescale(log(n_distinct), 63 | to = c(min_width, max_width), 64 | from = log(c(3, max_width))), 65 | max_width)) ) ) 66 | 67 | 68 | # initiate plot 69 | p <- plotly::plot_ly(width = max_width+20, 70 | height = 60) 71 | 72 | # add spike histogram lines 73 | p <- plotly::add_bars(p, 74 | data = dh, 75 | x = ~x, 76 | y = ~ prop, 77 | hoverinfo = 'text', 78 | hovertext = ~ txt, 79 | color = I('gray50'), 80 | showlegend = FALSE) 81 | 82 | 83 | plotly::layout(p, 84 | margin = list(l = 10, r = max_width+10-width, b = 0, t = 0, pad = 0), 85 | xaxis = list(title='', 86 | zeroline=FALSE, 87 | visible = FALSE, 88 | fixedrange = TRUE), 89 | yaxis = list(title='', 90 | visible = FALSE, 91 | tickvals= -1, 92 | ticktext = 1, 93 | fixedrange = TRUE), 94 | hoverlabel = list(font=list(size=12))) %>% 95 | plotly::config(displayModeBar = F) %>% 96 | plotly::partial_bundle() 97 | } 98 | } 99 | 100 | #' @export 101 | create_hist.hms <- create_hist.character 102 | 103 | #' @export 104 | create_hist.difftime <- create_hist.character 105 | 106 | #' @export 107 | create_hist.factor <- create_hist.character 108 | 109 | #' @export 110 | create_hist.logical <- create_hist.character 111 | 112 | #' @export 113 | create_hist.numeric <- function(x, counts, values){ 114 | 115 | n_distinct <- counts[["distinct"]] %>% as.numeric 116 | 117 | if (n_distinct>0) { 118 | y <- -1 119 | fmt <- function(x) Hmisc::htmlSN(x, digits=5) 120 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 121 | 122 | 123 | dh <- data.frame(x = values$value, freq = values$frequency, y = y) %>% 124 | mutate(prop = freq/sum(freq), 125 | txt = paste0(x, '
', round(prop, 3), '
n=', freq)) 126 | 127 | # mean 128 | dm <- data.frame(Mean=counts[["Mean"]] %>% as.numeric, 129 | n=counts[["n"]] %>% as.numeric, 130 | miss=counts[["missing"]] %>% as.numeric, 131 | y=y)%>% 132 | mutate(txt = paste0('Mean: ', Mean, '
n=', n, '
', miss, ' missing')) 133 | 134 | 135 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 136 | 137 | dh$prop <- 0.6 * dh$prop / max(dh$prop) # scale the proportions 138 | 139 | p <- plotly::plot_ly(width = 270, 140 | height = 60) 141 | 142 | 143 | # add spike histogram lines 144 | p <- plotly::add_segments(p, 145 | data=dh, 146 | x = ~ x, # segments to be drawn at data values on x-axis 147 | xend = ~ x, 148 | y = -1, # segments to start at y=-1 and be length of % of values 149 | yend = ~ -1 + prop, 150 | text = ~ txt, # hovertext to display for data values 151 | hoverinfo = 'text', 152 | color = I('gray50'), 153 | showlegend = FALSE) 154 | 155 | a <- 0.05 156 | b <- 0.4 157 | k <- (a + b) / 6 158 | w <- (b - a) / 8 159 | 160 | # add mean point 161 | p <- plotly::add_markers(p, 162 | data=dm, 163 | mode='markers', 164 | color=I('black'), 165 | x = ~ Mean, 166 | y = ~ y - k, 167 | text = ~ txt, 168 | hoverinfo = 'text', 169 | size=I(10), 170 | name='Mean', 171 | showlegend=FALSE) 172 | } 173 | 174 | if (n_distinct>=10) { 175 | # quartiles 176 | probs <- c(".05", ".25", ".50", ".75", ".95") 177 | qu <- counts[probs] %>% as.numeric 178 | nam <- paste0('Q0', probs) 179 | txt <- paste0(nam, ': ', fmt(qu)) 180 | dq1 <- data.frame(Median=qu[3], txt=txt[3], y=y) # hovertext for Median 181 | dq2 <- data.frame(quartiles=qu[c(2,4)], txt=txt[c(2,4)], y=y) # hovertext for 25th & 75th 182 | dq3 <- data.frame(outer=qu[c(1,5)], txt=txt[c(1,5)], y=y) # hovertext for 5th & 95th 183 | 184 | # function to add segments for the quartiles 185 | segs <- function(p, x, y, yend, text, data, color, name, width=2) { 186 | 187 | plotly::add_segments(p, 188 | data=data, 189 | x=x, y=y, 190 | xend=x, yend=yend, 191 | text=text, 192 | hoverinfo='text', 193 | name=name, 194 | showlegend=FALSE, 195 | color=color, 196 | line=list(width=width)) 197 | } 198 | 199 | p <- segs(p, x=~Median, y=~y-k-w, yend=~y-k+w, text=~txt, data=dq1, color=I('gray50'),name='Median', width=3) 200 | p <- segs(p, x=~quartiles, y=~y-k-w*.8, yend=~y-k+w*.8, text=~txt, data=dq2, color=I('blue'), name='Quartiles') 201 | onam <- '0.05, 0.95
Quantiles' 202 | p <- segs(p, x=~outer, y=~y-k-w*.64, yend=~y-k+w*.64, text=~txt, data=dq3, color=I('red'), name=onam) 203 | 204 | # connect the quartiles w/ a line 205 | ys <- -1 - k 206 | qs <- function(p, x, xend, color, lg){ 207 | 208 | plotly::add_segments(p, 209 | x=x, xend=xend, 210 | y=~ys, yend=~ys, 211 | hoverinfo='none', 212 | showlegend=FALSE, 213 | alpha=0.3, color=color, 214 | name='ignored') 215 | } 216 | 217 | p <- qs(p, x= ~ qu[1], xend=~ qu[2], color=I('red'), lg=onam) 218 | p <- qs(p, x= ~ qu[2], xend=~ qu[4], color=I('blue'), lg='Quartiles') 219 | p <- qs(p, x= ~ qu[4], xend=~ qu[5], color=I('red'), lg=onam) 220 | 221 | } 222 | 223 | if (n_distinct==0){ 224 | # initiate plot 225 | 226 | min_width = 50 227 | max_width = 250 228 | width = 17 229 | 230 | p <- plotly::plot_ly(width = max_width+20, 231 | height = 60) 232 | } 233 | 234 | plotly::layout(p, 235 | margin = list(l = 10, r = 10, b = 0, t = 0, pad = 0), 236 | xaxis = list(title='', 237 | zeroline=FALSE, 238 | visible = FALSE, 239 | fixedrange = FALSE), 240 | yaxis = list(title='', 241 | visible = FALSE, 242 | tickvals= -1, 243 | ticktext = 1, 244 | fixedrange = TRUE), 245 | hoverlabel = list(font=list(size=12), 246 | align = "left"))%>% 247 | plotly::config(displayModeBar = F) %>% 248 | plotly::partial_bundle() 249 | 250 | } 251 | 252 | 253 | #' @export 254 | create_hist.Date <- function(x, counts, values){ 255 | 256 | y <- -1 257 | fmt <- function(x) Hmisc::htmlSN(x, digits=5) 258 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 259 | 260 | n_distinct <- counts[["distinct"]] %>% as.numeric 261 | 262 | 263 | if (n_distinct >0){ 264 | dh <- data.frame(x = values$value, freq = values$frequency, y = y) %>% 265 | mutate(prop = freq/sum(freq), 266 | txt = paste0(x, '
', round(prop, 3), '
n=', freq)) 267 | 268 | # mean 269 | dm <- data.frame(Mean=counts[["Mean"]] %>% as.Date, 270 | n=counts[["n"]] %>% as.numeric, 271 | miss=counts[["missing"]] %>% as.numeric, 272 | y=y)%>% 273 | mutate(txt = paste0('Mean: ', Mean, '
n=', n, '
', miss, ' missing')) 274 | 275 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 276 | 277 | dh$prop <- 0.6 * dh$prop / max(dh$prop) # scale the proportions 278 | 279 | p <- plotly::plot_ly(width = 270, 280 | height = 60) 281 | 282 | 283 | # add spike histogram lines 284 | p <- plotly::add_segments(p, 285 | data=dh, 286 | x = ~ x, # segments to be drawn at data values on x-axis 287 | xend = ~ x, 288 | y = -1, # segments to start at y=-1 and be length of % of values 289 | yend = ~ -1 + prop, 290 | text = ~ txt, # hovertext to display for data values 291 | hoverinfo = 'text', 292 | color = I('gray50'), 293 | showlegend = FALSE) 294 | 295 | a <- 0.05 296 | b <- 0.4 297 | k <- (a + b) / 6 298 | w <- (b - a) / 8 299 | 300 | # add mean point 301 | p <- plotly::add_markers(p, 302 | data=dm, 303 | mode='markers', 304 | color=I('black'), 305 | x = ~ Mean, 306 | y = ~ y - k, 307 | text = ~ txt, 308 | hoverinfo = 'text', 309 | size=I(10), 310 | name='Mean', 311 | showlegend=FALSE) 312 | 313 | 314 | if (n_distinct >=10){ 315 | 316 | # quartiles 317 | probs <- c(".05", ".25", ".50", ".75", ".95") 318 | qu <- counts[probs] %>% as.Date 319 | nam <- paste0('Q0', probs) 320 | txt <- paste0(nam, ': ', fmt(qu)) 321 | dq1 <- data.frame(Median=qu[3], txt=txt[3], y=y) # hovertext for Median 322 | dq2 <- data.frame(quartiles=qu[c(2,4)], txt=txt[c(2,4)], y=y) # hovertext for 25th & 75th 323 | dq3 <- data.frame(outer=qu[c(1,5)], txt=txt[c(1,5)], y=y) # hovertext for 5th & 95th 324 | 325 | # function to add segments for the quartiles 326 | segs <- function(p, x, y, yend, text, data, color, name, width=2) { 327 | 328 | plotly::add_segments(p, 329 | data=data, 330 | x=x, y=y, 331 | xend=x, yend=yend, 332 | text=text, 333 | hoverinfo='text', 334 | name=name, 335 | showlegend=FALSE, 336 | color=color, 337 | line=list(width=width)) 338 | } 339 | 340 | p <- segs(p, x=~Median, y=~y-k-w, yend=~y-k+w, text=~txt, data=dq1, color=I('gray50'),name='Median', width=3) 341 | p <- segs(p, x=~quartiles, y=~y-k-w*.8, yend=~y-k+w*.8, text=~txt, data=dq2, color=I('blue'), name='Quartiles') 342 | onam <- '0.05, 0.95
Quantiles' 343 | p <- segs(p, x=~outer, y=~y-k-w*.64, yend=~y-k+w*.64, text=~txt, data=dq3, color=I('red'), name=onam) 344 | 345 | # connect the quartiles w/ a line 346 | ys <- -1 - k 347 | qs <- function(p, x, xend, color, lg){ 348 | 349 | plotly::add_segments(p, 350 | x=x, xend=xend, 351 | y=~ys, yend=~ys, 352 | hoverinfo='none', 353 | showlegend=FALSE, 354 | alpha=0.3, color=color, 355 | name='ignored') 356 | } 357 | 358 | p <- qs(p, x= ~ qu[1], xend=~ qu[2], color=I('red'), lg=onam) 359 | p <- qs(p, x= ~ qu[2], xend=~ qu[4], color=I('blue'), lg='Quartiles') 360 | p <- qs(p, x= ~ qu[4], xend=~ qu[5], color=I('red'), lg=onam) 361 | 362 | } 363 | 364 | 365 | plotly::layout(p, 366 | margin = list(l = 10, r = 10, b = 0, t = 0, pad = 0), 367 | xaxis = list(title='', 368 | zeroline=FALSE, 369 | visible = FALSE, 370 | fixedrange = FALSE), 371 | yaxis = list(title='', 372 | visible = FALSE, 373 | tickvals= -1, 374 | ticktext = 1, 375 | fixedrange = TRUE), 376 | hoverlabel = list(font=list(size=12), 377 | align = "left"))%>% 378 | plotly::config(displayModeBar = F) %>% 379 | plotly::partial_bundle() 380 | } 381 | 382 | } 383 | 384 | 385 | #' @export 386 | create_hist.POSIXct <- create_hist.Date 387 | 388 | #' @export 389 | create_hist.POSIXlt <- create_hist.Date 390 | 391 | 392 | #' @export 393 | create_hist.timePOSIXt <- function(x, counts, values){ 394 | 395 | y <- -1 396 | fmt <- function(x) Hmisc::htmlSN(x, digits=5) 397 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 398 | 399 | n_distinct <- counts[["distinct"]] %>% as.numeric 400 | 401 | 402 | dh <- data.frame(x = values$value, freq = values$frequency, y = y) %>% 403 | mutate(prop = freq/sum(freq)) %>% 404 | separate(x, c("date","time"), sep = " ", remove = FALSE) %>% 405 | mutate(txt = paste0(time, '
', round(prop, 3), '
n=', freq)) %>% 406 | select(-date) 407 | 408 | # mean 409 | dm <- data.frame(Mean=counts[["Mean"]] %>% hms::as_hms() %>% lubridate::as_datetime(), 410 | n=counts[["n"]] %>% as.numeric, 411 | miss=counts[["missing"]] %>% as.numeric, 412 | y=y) %>% 413 | mutate(txt = paste0('Mean: ', hms::as_hms(Mean), '
n=', n, '
', miss, ' missing')) 414 | 415 | 416 | height <- Hmisc::plotlyParm$heightDotchart(1.2) 417 | 418 | dh$prop <- 0.6 * dh$prop / max(dh$prop) # scale the proportions 419 | 420 | p <- plotly::plot_ly(width = 270, 421 | height = 60) 422 | 423 | 424 | # add spike histogram lines 425 | p <- plotly::add_segments(p, 426 | data=dh, 427 | x = ~ x, # segments to be drawn at data values on x-axis 428 | xend = ~ x, 429 | y = -1, # segments to start at y=-1 and be length of % of values 430 | yend = ~ -1 + prop, 431 | text = ~ txt, # hovertext to display for data values 432 | hoverinfo = 'text', 433 | color = I('gray50'), 434 | showlegend = FALSE) 435 | 436 | a <- 0.05 437 | b <- 0.4 438 | k <- (a + b) / 6 439 | w <- (b - a) / 8 440 | 441 | # add mean point 442 | p <- plotly::add_markers(p, 443 | data=dm, 444 | mode='markers', 445 | color=I('black'), 446 | x = ~ Mean, 447 | y = ~ y - k, 448 | text = ~ txt, 449 | hoverinfo = 'text', 450 | size=I(10), 451 | name='Mean', 452 | showlegend=FALSE) 453 | 454 | if (n_distinct >=10){ 455 | 456 | # quartiles 457 | probs <- c(".05", ".25", ".50", ".75", ".95") 458 | qu0 <- counts[probs] %>% hms::as_hms() 459 | qu <- qu0 %>% lubridate::as_datetime() 460 | nam <- paste0('Q0', probs) 461 | txt <- paste0(nam, ': ', qu0) 462 | dq1 <- data.frame(Median=qu[3], txt=txt[3], y=y) # hovertext for Median 463 | dq2 <- data.frame(quartiles=qu[c(2,4)], txt=txt[c(2,4)], y=y) # hovertext for 25th & 75th 464 | dq3 <- data.frame(outer=qu[c(1,5)], txt=txt[c(1,5)], y=y) # hovertext for 5th & 95th 465 | 466 | # function to add segments for the quartiles 467 | segs <- function(p, x, y, yend, text, data, color, name, width=2) { 468 | 469 | plotly::add_segments(p, 470 | data=data, 471 | x=x, y=y, 472 | xend=x, yend=yend, 473 | text=text, 474 | hoverinfo='text', 475 | name=name, 476 | showlegend=FALSE, 477 | color=color, 478 | line=list(width=width)) 479 | } 480 | 481 | p <- segs(p, x=~Median, y=~y-k-w, yend=~y-k+w, text=~txt, data=dq1, color=I('gray50'),name='Median', width=3) 482 | p <- segs(p, x=~quartiles, y=~y-k-w*.8, yend=~y-k+w*.8, text=~txt, data=dq2, color=I('blue'), name='Quartiles') 483 | onam <- '0.05, 0.95
Quantiles' 484 | p <- segs(p, x=~outer, y=~y-k-w*.64, yend=~y-k+w*.64, text=~txt, data=dq3, color=I('red'), name=onam) 485 | 486 | # connect the quartiles w/ a line 487 | ys <- -1 - k 488 | qs <- function(p, x, xend, color, lg){ 489 | 490 | plotly::add_segments(p, 491 | x=x, xend=xend, 492 | y=~ys, yend=~ys, 493 | hoverinfo='none', 494 | showlegend=FALSE, 495 | alpha=0.3, color=color, 496 | name='ignored') 497 | } 498 | 499 | p <- qs(p, x= ~ qu[1], xend=~ qu[2], color=I('red'), lg=onam) 500 | p <- qs(p, x= ~ qu[2], xend=~ qu[4], color=I('blue'), lg='Quartiles') 501 | p <- qs(p, x= ~ qu[4], xend=~ qu[5], color=I('red'), lg=onam) 502 | 503 | } 504 | 505 | plotly::layout(p, 506 | margin = list(l = 10, r = 10, b = 0, t = 0, pad = 0), 507 | xaxis = list(title='', 508 | zeroline=FALSE, 509 | visible = FALSE, 510 | fixedrange = FALSE), 511 | yaxis = list(title='', 512 | visible = FALSE, 513 | tickvals= -1, 514 | ticktext = 1, 515 | fixedrange = TRUE), 516 | hoverlabel = list(font=list(size=12), 517 | align = "left"))%>% 518 | plotly::config(displayModeBar = F) %>% 519 | plotly::partial_bundle() 520 | 521 | } 522 | -------------------------------------------------------------------------------- /R/make_xray.R: -------------------------------------------------------------------------------- 1 | #' Make data xray by a grouping variable 2 | #' 3 | #' Create comprehensive tibble of variable metadata using Hmisc::describe as engine, with option for grouping 4 | #' 5 | #' @param data A data frame. 6 | #' @param by Optional name of grouping ("by") variable as character string. 7 | #' 8 | #' @importFrom Hmisc describe 9 | #' @import dplyr 10 | #' 11 | #' @return A tibble containing variable metadata with 1 row per group. 12 | #' @export 13 | #' 14 | #' 15 | #' @examples 16 | #' 17 | #' diamonds <- ggplot2::diamonds 18 | #' make_xray(diamonds) 19 | #' 20 | #' make_xray(diamonds, by = 'cut') 21 | #' 22 | make_xray <- function(data, by = NULL){ 23 | 24 | if (!is.null(by)){ 25 | data %>% 26 | nest_by(.data[[by]]) %>% 27 | mutate(data_xray_result = list(make_xray_core(data))) %>% 28 | select(-data) %>% 29 | unnest(cols = data_xray_result) %>% 30 | ungroup 31 | } else { 32 | make_xray_core(data) 33 | } 34 | 35 | } 36 | -------------------------------------------------------------------------------- /R/make_xray_core.R: -------------------------------------------------------------------------------- 1 | #' Make data xray - core function 2 | #' 3 | #' Create comprehensive tibble of variable metadata using Hmisc::describe as engine. 4 | #' 5 | #' @param data A data frame. 6 | #' 7 | #' @importFrom Hmisc describe 8 | #' @import dplyr 9 | #' @import tidyr 10 | #' @import forcats 11 | #' @import purrr 12 | #' 13 | #' @return A tibble containing variable metadata. 14 | #' @export 15 | #' 16 | #' 17 | #' @examples 18 | #' 19 | #' diamonds <- ggplot2::diamonds 20 | #' make_xray_core(diamonds) 21 | #' 22 | make_xray_core <- function(data){ 23 | 24 | stopifnot(is.data.frame(data)) 25 | 26 | data_nest <- data %>% 27 | as.list %>% 28 | tibble(VAR = names(.), 29 | x = .) %>% 30 | mutate(ORDER = row_number()) %>% 31 | rowwise %>% 32 | mutate(attributes = list(attributes(x) %>% 33 | magrittr::extract(c("label","units","format.sas")) %>% 34 | discard(., ~ is.null(.x)) %>% 35 | as_tibble %>% 36 | bind_rows( 37 | tibble(label = character(), 38 | units = character(), 39 | `format.sas` = character()) 40 | ) %>% 41 | unique %>% 42 | rename(LABEL = label, UNITS = units, FORMAT = `format.sas`))) %>% 43 | unnest(cols=attributes, keep_empty = TRUE) %>% 44 | rowwise %>% 45 | mutate( 46 | TYPE = case_when( 47 | is.character(x) | is.factor(x) | is.logical(x) ~ "CHAR", 48 | lubridate::is.Date(x) | lubridate::is.POSIXct(x) | lubridate::is.POSIXlt(x) | hms::is_hms(x) ~ "DT/TIME", 49 | is.numeric(x) ~ "NUM" 50 | ), 51 | describe = Hmisc::describe(x, digits = 3, exclude.missing = FALSE) %>% list(), 52 | counts = describe$counts %>% list(), 53 | values = describe$values %>% list(), 54 | extremes = describe$extremes %>% list()) %>% 55 | mutate( n = counts %>% purrr::pluck('n') %>% as.numeric(), 56 | missing = counts %>% purrr::pluck('missing', .default = NA) %>% as.numeric(), 57 | distinct = counts %>% purrr::pluck('distinct', .default = NA) %>% as.numeric() )%>% 58 | ungroup %>% 59 | mutate(values = map2(values, x, ~ if(is.null(.x)) { 60 | tab <- table(.y) 61 | if (is.numeric(.y)){ 62 | list(value = names(tab) %>% as.numeric, 63 | frequency = tab %>% as.vector) 64 | } else{ 65 | list(value = names(tab), 66 | frequency = tab %>% as.vector) 67 | } 68 | } else { 69 | .x } ))%>% 70 | rowwise %>% 71 | mutate(spike_hist = list(create_hist(x, counts, values))) %>% 72 | select(-x) 73 | 74 | 75 | data_nest_describe <- data_nest %>% 76 | arrange(ORDER) %>% 77 | mutate( counts_df = tryCatch( 78 | counts[-c(1:2)] %>% 79 | enframe(name = 'statistic', value = 'value') %>% 80 | pivot_wider(values_from = value, 81 | names_from = statistic) %>% 82 | list(), 83 | error = function(e) NULL %>% list() 84 | ), 85 | 86 | extremes_df = tryCatch( 87 | extremes %>% 88 | enframe(name = 'extreme', value = 'value') %>% 89 | pivot_wider(values_from = value, 90 | names_from = extreme) %>% 91 | list(), 92 | error = function(e) NULL %>% list() 93 | ), 94 | 95 | values_df = tryCatch( 96 | values %>% 97 | data.frame() %>% 98 | arrange(desc(frequency)) %>% 99 | pivot_wider(values_from = frequency, 100 | names_from = value) %>% 101 | list(), 102 | error = function(e) NULL %>% list() 103 | ) 104 | ) 105 | 106 | return(data_nest_describe%>% 107 | select(ORDER, TYPE, VAR, LABEL, FORMAT, UNITS, n, missing, distinct, 108 | counts_df, values_df, extremes_df, 109 | spike_hist) ) 110 | } 111 | 112 | -------------------------------------------------------------------------------- /R/report_xray.R: -------------------------------------------------------------------------------- 1 | #' Create X-ray report 2 | #' 3 | #' @param data A data frame. 4 | #' @param by Optional name of grouping ("by") variable as character string. 5 | #' @param data_name Name of dataset to be displayed in report as character string. 6 | #' @param study Name of study to be displayed in report as character string. 7 | #' @param loc Directory to save the rmd and html output. Defaults to current working directory. 8 | #' 9 | #' @return 10 | #' @export 11 | #' 12 | #' @examples 13 | #' 14 | #' \dontrun{ 15 | #' 16 | #' diamonds <- ggplot2::diamonds %>% 17 | #' mutate(price = structure(price, label = 'price in US dollars'), 18 | #' carat = structure(carat, label = 'weight of the diamond'), 19 | #' cut = structure(cut, label = 'quality of the cut (Fair, Good, Very Good, Premium, Ideal)'), 20 | #' color = structure(color, label = 'diamond colour, from D (best) to J (worst)'), 21 | #' clarity = structure(clarity, label = 'a measurement of how clear the diamond is (I1 (worst), SI2, SI1, VS2, VS1, VVS2, VVS1, IF (best))'), 22 | #' x = structure(x, label = 'length in mm'), 23 | #' y = structure(y, label = 'width in mm'), 24 | #' z = structure(z, label = 'depth in mm'), 25 | #' depth = structure(depth, label = 'total depth percentage = z / mean(x, y) = 2 * z / (x + y)'), 26 | #' table = structure(table, label = 'width of top of diamond relative to widest point')) 27 | #' 28 | #' diamonds %>% 29 | #' report_xray(data_name = 'Diamonds', study = 'ggplot2', loc = getwd()) 30 | #' 31 | #' diamonds %>% 32 | #' report_xray(data_name = 'Diamonds', by = 'cut', study = 'ggplot2', loc = getwd()) 33 | #' 34 | #' } 35 | #' 36 | report_xray <- function(data, by = NULL, data_name, study, loc = NULL){ 37 | 38 | if (is.null(loc)) { 39 | loc <- getwd() 40 | } 41 | 42 | if(!dir.exists(loc)) stop (paste0(loc," is not a valid directory")) 43 | 44 | report_template <- system.file("templates/report_xray.rmd", package = "dataxray") 45 | 46 | report_out <- file.path(loc, paste0(study,"_",data_name,"_xray")) 47 | 48 | params_in <- list(data = data, 49 | data_name = data_name, 50 | study = study, 51 | by = by) 52 | 53 | file.copy(report_template, paste0(report_out,".rmd"), overwrite = TRUE) 54 | 55 | 56 | rmarkdown::render(input = paste0(report_out,".rmd"), 57 | output_file = paste0(report_out,".html"), 58 | params = params_in) 59 | } -------------------------------------------------------------------------------- /R/style_nested_tabs.R: -------------------------------------------------------------------------------- 1 | 2 | #' Theme for nested tables 3 | #' 4 | #' @import reactablefmtr 5 | #' 6 | #' @return Object of class reactableTheme 7 | #' @keywords internal 8 | nested_tab_theme <- function(){reactableTheme( 9 | color = "black", 10 | backgroundColor = "#ffffff", 11 | borderWidth = "1px", 12 | borderColor = "#dddddd", 13 | stripedColor = "#dddddd", 14 | highlightColor = "#f0f0f0", 15 | cellPadding = "2px", 16 | tableStyle = list( 17 | fontFamily = "Helvetica", 18 | fontSize = 12, 19 | borderBottom = "1px solid #dddddd" 20 | ), 21 | headerStyle = list( 22 | borderWidth = "1px", 23 | paddingTop = "2px", 24 | verticalAlign = "bottom", 25 | textAlign = "bottom", 26 | background = "#ffffff", 27 | textTransform = "uppercase", 28 | borderColor = "#dddddd", 29 | color = "#000000", 30 | "&:hover" = list(background = "#dddddd"), 31 | "&[aria-sort='ascending'], &[aria-sort='descending']" = list(background = "#5b5e5f", color = "#dddddd"), 32 | borderColor = "#333", 33 | fontSize = 12, 34 | fontFamily = "Helvetica" 35 | ))} 36 | 37 | nested_extreme_theme <- function(){reactableTheme( 38 | color = "black", 39 | backgroundColor = "#ffffff", 40 | borderWidth = "1px", 41 | borderColor = "#dddddd", 42 | stripedColor = "#dddddd", 43 | highlightColor = "#f0f0f0", 44 | cellPadding = "2px", 45 | tableStyle = list( 46 | fontFamily = "Helvetica", 47 | fontSize = 12, 48 | borderBottom = "1px solid #dddddd" 49 | ), 50 | headerStyle = list( 51 | #display = "none" 52 | background = "#00FF00", 53 | position = "absolute", 54 | width = "1px", 55 | height = '1px', 56 | padding = "0", 57 | margin = '-1px', 58 | overflow = 'hidden', 59 | clip = 'rect(0, 0, 0, 0)', 60 | border = '0' 61 | ))} 62 | 63 | #' Create nested table display for values 64 | #' 65 | #' @param values_df Dataframe of VALUES from Hmisc::describe 66 | #' 67 | #' @import reactable 68 | #' @import dplyr 69 | #' 70 | #' @keywords internal 71 | nested_tab_values <- function(values_df){ 72 | bind_rows( 73 | values_df, 74 | values_df %>% 75 | mutate(across(everything(), ~round( .x / sum(c_across(everything())), 3))) 76 | ) %>% 77 | mutate(name = c('FREQ','PROP')) %>% 78 | relocate(name) %>% 79 | reactable( compact = TRUE, 80 | bordered = TRUE, 81 | highlight = TRUE, 82 | fullWidth = FALSE, 83 | sortable = FALSE, 84 | theme = nested_tab_theme(), 85 | defaultColDef = colDef(align = 'center', 86 | minWidth = 100), 87 | columns = list( name = colDef(name = '')) 88 | ) 89 | } 90 | 91 | #' Create nested table display for counts 92 | #' 93 | #' @param counts_df Dataframe of COUNTS from Hmisc::describe 94 | #' 95 | #' @import reactable 96 | #' 97 | #' @keywords internal 98 | nested_tab_counts <- function(counts_df){ 99 | counts_df %>% 100 | reactable(compact = TRUE, 101 | bordered = TRUE, 102 | highlight = TRUE, 103 | fullWidth = FALSE, 104 | theme = nested_tab_theme(), 105 | defaultColDef = colDef(sortable = FALSE, 106 | align = 'center', 107 | minWidth = 75, 108 | maxWidth = 150), 109 | columns = list( `.05` = list(name = 'Q5', html = TRUE), 110 | `.10` = list(name = 'Q10', html = TRUE), 111 | `.25` = list(name = 'Q25', html = TRUE), 112 | `.50` = list(name = 'med'), 113 | `.75` = list(name = 'Q75', html = TRUE), 114 | `.90` = list(name = 'Q90', html = TRUE), 115 | `.95` = list(name = 'Q95', html = TRUE) 116 | ) 117 | ) 118 | } 119 | 120 | #' Create nested table display for extremes 121 | #' 122 | #' @param extremes_df Dataframe of EXTREMES from Hmisc::describe 123 | #' 124 | #' @import reactable 125 | #' @importFrom tibble enframe 126 | #' @import dplyr 127 | #' @import tidyr 128 | #' 129 | #' @keywords internal 130 | nested_tab_extremes <- function(extremes_df){ 131 | extremes_df %>% 132 | unlist %>% 133 | enframe(name = 'extreme', value = 'value') %>% 134 | separate(extreme, into = c('type','num'), sep = 1) %>% 135 | mutate(num = as.numeric(num), 136 | num = ifelse(type == 'H', max(num)+1 - num, num), 137 | type = factor(type, labels = c("HIGHEST","LOWEST"))) %>% 138 | pivot_wider(values_from = value, 139 | names_from = num) %>% 140 | reactable(compact = TRUE, 141 | bordered = TRUE, 142 | highlight = TRUE, 143 | fullWidth = FALSE, 144 | sortable = FALSE, 145 | class = "hidden-column-headers", 146 | theme = nested_extreme_theme(), 147 | defaultColDef = colDef(align = 'center', 148 | name = '') 149 | ) 150 | } 151 | -------------------------------------------------------------------------------- /R/view_xray.R: -------------------------------------------------------------------------------- 1 | 2 | #' @importFrom htmltools tags 3 | #' @keywords internal 4 | with_tooltip <- function(value, tooltip) { 5 | htmltools::tags$abbr(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", 6 | title = tooltip, value) 7 | } 8 | 9 | #' @importFrom shiny icon 10 | #' @importFrom htmltools span 11 | #' @keywords internal 12 | type_indicator <- function(value = c("NUM", "CHAR", "DT/TIME")) { 13 | value <- match.arg(value) 14 | label <- switch(value, NUM = "NUM", CHAR = "CHAR", `DT/TIME` = "DT/TIME") 15 | # Add img role and tooltip/label for accessibility 16 | args <- list(role = "img", title = label) 17 | if (value == "NUM") { 18 | args <- c(args, list(shiny::icon("list-ol", "fa-2x"), style = "color: #7f7f7f; font-weight: 500")) 19 | } else if (value == "CHAR") { 20 | args <- c(args, list(shiny::icon("font", "fa-2x"), style = "color: #7f7f7f; font-weight: 500")) 21 | } else if (value == "DT/TIME") { 22 | args <- c(args, list(shiny::icon("calendar","fa-2x"), style = "color: #7f7f7f; font-weight: 500")) 23 | } else { 24 | args <- c(args, list(shiny::icon("circle"), style = "color: #7f7f7f; font-weight: 500")) 25 | } 26 | do.call(htmltools::span, args) 27 | } 28 | 29 | 30 | 31 | #' Create interactive table using Hmisc::describe + reactable 32 | #' 33 | #' @param data_xray Output of `make_xray()` 34 | #' @param data_xray_shared [Optional] `data_xray` converted to a `SharedData` object using crosstalk, for use with linked widgets. 35 | #' @param elementId Unique element ID for the table 36 | #' @param by Optional name of group by variable as character string 37 | #' 38 | #' @import reactable 39 | #' @importFrom reactablefmtr fivethirtyeight 40 | #' @importFrom purrr map 41 | #' @import htmltools 42 | #' 43 | #' @return Reactable display 44 | #' @export 45 | #' 46 | #' @examples 47 | #' 48 | #' diamonds <- ggplot2::diamonds 49 | #' 50 | #' diamonds %>% 51 | #' make_xray() %>% 52 | #' view_xray() 53 | #' 54 | #' diamonds %>% 55 | #' make_xray(by = 'cut') %>% 56 | #' view_xray(by = 'cut') 57 | #' 58 | view_xray <- function(data_xray, data_xray_shared = NULL, by = NULL, elementId = NULL){ 59 | 60 | stopifnot(is.data.frame(data_xray)) 61 | 62 | if (!is.null(data_xray_shared)){ 63 | stopifnot(is.SharedData(data_xray_shared)) 64 | } 65 | 66 | if (is.null(data_xray_shared)){ 67 | data_xray_shared <- data_xray 68 | } 69 | 70 | if (is.null(elementId)){ 71 | elementId <- "describer-table-1" 72 | } 73 | 74 | tbl <- reactable( 75 | data_xray_shared, 76 | elementId = elementId, 77 | groupBy = by, 78 | searchable = FALSE, 79 | pagination = FALSE, 80 | compact = TRUE, 81 | highlight = TRUE, 82 | fullWidth = TRUE, 83 | defaultExpanded = FALSE, 84 | # height = 850, 85 | theme = reactablefmtr::fivethirtyeight(), 86 | 87 | defaultColDef = colDef(vAlign = 'top', 88 | sortable = FALSE, 89 | width = 275), 90 | 91 | columnGroups = list( 92 | colGroup(name = 'Variable', 93 | columns = c('ORDER','TYPE','LABEL')), 94 | colGroup(name = 'Completeness', 95 | columns = c('n', 'missing', 'distinct')), 96 | colGroup(name = 'Interactive Figure', 97 | columns = c('spike_hist')) 98 | ), 99 | 100 | columns = list( 101 | 102 | ORDER = colDef(name = 'No', 103 | header = with_tooltip('No', 'Order of Variable in data'), 104 | width = 45, 105 | sortable = TRUE, 106 | align = 'center'), 107 | 108 | TYPE = colDef(name = 'TYPE', 109 | header = with_tooltip('TYPE', 'Variable Type (Character, Date/Time, Numeric'), 110 | html = TRUE, 111 | width = 75, 112 | sortable = TRUE, 113 | align = 'center', 114 | cell = function(value) type_indicator(value)), 115 | 116 | VAR = colDef(show = TRUE, 117 | name = '', 118 | sortable = F, 119 | width = 0, 120 | cell = function(){''}), 121 | 122 | LABEL = colDef( 123 | name = 'Name - Label', 124 | header = with_tooltip('Name - Label', 'Variable Name (Labels, Formats & Units if present'), 125 | width = 275, 126 | sortable = TRUE, 127 | style = list(borderRight = "1px solid #eee"), 128 | cell = function(value, index) { 129 | htmltools::tagList( 130 | htmltools::div(style = list(fontWeight= 'bold'), data_xray$VAR[index]), 131 | htmltools::div(style = list(fontSize = 12, color = "#999"), ifelse(!is.na(value), value, '')), 132 | htmltools::div(style = list(fontSize = 12, color = "#999"), ifelse(!is.na(data_xray$FORMAT[index]), paste("fmt:",data_xray$FORMAT[index]), '')), 133 | ) 134 | }), 135 | 136 | FORMAT = colDef(show = FALSE), 137 | 138 | UNITS = colDef(show = FALSE), 139 | 140 | n = colDef(name = 'Observed', 141 | width = 150, 142 | sortable = TRUE, 143 | style = list(fontFamily = "monospace", whiteSpace = "pre"), 144 | cell = data_bars(data_xray, 145 | max_value = max(data_xray$n), 146 | text_size = 14, 147 | text_position = 'outside-base', 148 | fill_color = '#2780e3', 149 | fill_opacity = 0.5, 150 | box_shadow = TRUE, 151 | background = ifelse(min(data_xray$n)==max(data_xray$n), 152 | "#2780E380", 153 | 'lightgrey')) 154 | ), 155 | 156 | missing = colDef(name = 'Missing', 157 | html = TRUE, 158 | width = 75, 159 | sortable = TRUE, 160 | align = 'right', 161 | cell = function(value, index){ 162 | paste0(value, "
", round(100*value/(value + data_xray$n[[index]]),0), "%") 163 | }), 164 | 165 | distinct = colDef(name = 'Distinct', 166 | html = TRUE, 167 | width = 75, 168 | sortable = TRUE, 169 | align = 'right'), 170 | 171 | 172 | spike_hist = colDef(name = ' 173 | Mean‧   174 | Q0.05∣ 175 | Q0.25∣ 176 | Median∣ 177 | Q0.75∣ 178 | Q0.95∣ 179 | ', 180 | html = TRUE, 181 | footer = ' 182 | Mean‧   183 | Q0.05∣ 184 | Q0.25∣ 185 | Median∣ 186 | Q0.75∣ 187 | Q0.95∣ 188 | ', 189 | footerStyle = "font-weight: bold; font-size: 12px; text-transform: uppercase;", 190 | cell = function(x){return(htmltools::div(x))}, 191 | align = 'center', 192 | width = 275), 193 | 194 | counts_df = colDef(show = FALSE), 195 | 196 | values_df = colDef(show = FALSE), 197 | 198 | extremes_df = colDef(show = FALSE) 199 | ), 200 | details = function(index){ 201 | cols <- c("counts","values","extremes") 202 | 203 | d <- data_xray 204 | create_div <- function(data, index, col){ 205 | d_col <- data[[paste0(col, "_df")]][[index]] 206 | table_fun <- match.fun(paste0("nested_tab_", col)) 207 | if (!is.null(d_col) && nrow(d_col)>0){ 208 | if ((col=="values" & ncol(d_col)<=12) | (col=="counts" & ncol(d_col)>1) | col=="extremes"){ 209 | htmltools::div(style = "padding: 2px 25px 2px 0px;",table_fun(d_col)) 210 | } 211 | } 212 | } 213 | divs <- map(cols, ~create_div(data=d, index = index, col = .x)) 214 | htmltools::div(divs) 215 | } 216 | ) #%>% 217 | #reactablefmtr::google_font("Roboto") 218 | 219 | tagList( 220 | div( 221 | style = "display: grid; grid-template-columns: 1fr 2fr; grid-gap: 20px; margin-bottom: 12px", 222 | div( 223 | tags$button( 224 | "Expand/collapse all", 225 | onclick = paste0("Reactable.toggleAllRowsExpanded('", elementId, "')") 226 | ) 227 | ), 228 | div( 229 | tags$input( 230 | type = "text", 231 | placeholder = "Search NAME | LABEL", 232 | style = "padding: 4px 8px; width: 50%", 233 | oninput = paste0("Reactable.setSearch('", elementId, "', this.value)") 234 | ) 235 | ) 236 | ), 237 | tbl 238 | ) %>% 239 | htmltools::browsable() 240 | 241 | } 242 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # dataxray 4 | 5 | An interactive table interface for data summaries 6 | 7 | Install package from GitHub with: 8 | 9 | ``` 10 | # install.packages("devtools") 11 | devtools::install_github("agstn/dataxray") 12 | ``` 13 | 14 | ## Report Xray 15 | [Example](https://agstn.github.io/dataxray/) using ggplot2 [diamonds](https://ggplot2.tidyverse.org/reference/diamonds.html) data 16 | 17 | ``` 18 | library(dataxray) 19 | 20 | diamonds <- diamonds %>% 21 | mutate(price = structure(price, label = 'price in US dollars'), 22 | carat = structure(carat, label = 'weight of the diamond'), 23 | cut = structure(cut, label = 'quality of the cut (Fair, Good, Very Good, Premium, Ideal)'), 24 | color = structure(color, label = 'diamond colour, from D (best) to J (worst)'), 25 | clarity = structure(clarity, label = 'a measurement of how clear the diamond is 26 | (I1 (worst), SI2, SI1, VS2, VS1, VVS2, VVS1, IF (best))'), 27 | x = structure(x, label = 'length in mm'), 28 | y = structure(y, label = 'width in mm'), 29 | z = structure(z, label = 'depth in mm'), 30 | depth = structure(depth, label = 'total depth percentage = z / mean(x, y) = 2 * z / (x + y)'), 31 | table = structure(table, label = 'width of top of diamond relative to widest point')) 32 | 33 | diamonds %>% 34 | report_xray(data_name = 'Diamonds', study = 'ggplot2') 35 | ``` 36 | 37 |

38 | 39 |

40 | 41 | ## View Xray 42 | RStudio IDE Viewer pane 43 | ``` 44 | library(dataxray) 45 | 46 | diamonds %>% 47 | make_xray() %>% 48 | view_xray() 49 | ``` 50 | -------------------------------------------------------------------------------- /dataxray.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /ggplot2_Diamonds_xray.rmd: -------------------------------------------------------------------------------- 1 | --- 2 | params: 3 | study: NA 4 | data: NA 5 | data_name: NA 6 | by: 7 | title: 'Study: `r params$study`     Data: `r params$data_name`' 8 | date: " Created: `r format(Sys.time(),format='%A %d %b %Y %I:%M %p %Z')`" 9 | output: 10 | flexdashboard::flex_dashboard: 11 | self_contained: true 12 | mathjax: NULL 13 | source_code: "https://github.com/agstn/dataxray" 14 | --- 15 | 16 | ```{=html} 17 | 34 | ``` 35 | 36 | 37 | ```{r knitr-defaults} 38 | knitr::opts_chunk$set(warning = FALSE, message = FALSE, comment = NA) 39 | knitr::opts_chunk$set(cache = FALSE) 40 | options(width=170) 41 | ``` 42 | 43 | ```{r load-packages} 44 | library(dataxray) 45 | library(tidyverse) 46 | library(haven) 47 | library(crosstalk) 48 | ``` 49 | 50 | ```{r sample-vars, include=FALSE} 51 | data <- params$data 52 | dim <- dim(data) 53 | data_xray <- make_xray(data, by = params$by) 54 | ``` 55 | 56 | # DATA XRAY {#main} 57 | 58 | Inputs {.sidebar data-width=300} 59 | ------------------------------------- 60 | 61 |
62 | 63 | ```{r} 64 | d_reactable <- data_xray 65 | 66 | d_reactable_shared <- SharedData$new(d_reactable) 67 | 68 | filter_select('type', 'variable TYPE', d_reactable_shared, ~ TYPE) 69 | filter_select('var', 'variable NAME', d_reactable_shared, ~ VAR) 70 | filter_select('lab', 'variable LABEL', d_reactable_shared, ~ LABEL) 71 | filter_select('n', 'variable COMPLETE',d_reactable_shared, ~ ifelse(n == dim[1], 'YES', 'NO')) 72 | 73 | filter_slider('missing', 'variable % MISSING', d_reactable_shared, ~ 100*(missing/dim[1]), 74 | width = 250, 75 | post = '%', 76 | min = 0, max = 100, 77 | dragRange = FALSE, 78 | step = 5, round = TRUE, sep = '', ticks = TRUE) 79 | 80 | filter_slider('distinct', 'variable # DISTINCT', d_reactable_shared, ~ distinct, 81 | width = 250, 82 | min = 1, dragRange = FALSE, 83 | step = 5, ticks = FALSE) 84 | ``` 85 | 86 | 87 | Column 88 | ------------------------------------- 89 | ### **`r toupper(params$data_name)`** DATA with **`r dim[1]`** OBSERVATIONS and **`r dim[2]`** VARIABLES 90 | 91 | ```{r create-reactable-1} 92 | view_xray(data_xray = d_reactable, data_xray_shared = d_reactable_shared, by = params$by) 93 | ``` 94 | -------------------------------------------------------------------------------- /index.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/agstn/dataxray/031cf91bb18db80954101b35a75180713cd1a8b1/index.png -------------------------------------------------------------------------------- /inst/templates/hex_xray.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/agstn/dataxray/031cf91bb18db80954101b35a75180713cd1a8b1/inst/templates/hex_xray.png -------------------------------------------------------------------------------- /inst/templates/report_xray.rmd: -------------------------------------------------------------------------------- 1 | --- 2 | params: 3 | study: NA 4 | data: NA 5 | data_name: NA 6 | by: 7 | title: 'Study: `r params$study`     Data: `r params$data_name`' 8 | date: " Created: `r format(Sys.time(),format='%A %d %b %Y %I:%M %p %Z')`" 9 | output: 10 | flexdashboard::flex_dashboard: 11 | self_contained: true 12 | mathjax: NULL 13 | source_code: "https://github.com/agstn/dataxray" 14 | --- 15 | 16 | ```{=html} 17 | 34 | ``` 35 | 36 | 37 | ```{r knitr-defaults} 38 | knitr::opts_chunk$set(warning = FALSE, message = FALSE, comment = NA) 39 | knitr::opts_chunk$set(cache = FALSE) 40 | options(width=170) 41 | ``` 42 | 43 | ```{r load-packages} 44 | library(dataxray) 45 | library(tidyverse) 46 | library(haven) 47 | library(crosstalk) 48 | ``` 49 | 50 | ```{r sample-vars, include=FALSE} 51 | data <- params$data 52 | dim <- dim(data) 53 | data_xray <- make_xray(data, by = params$by) 54 | ``` 55 | 56 | # DATA XRAY {#main} 57 | 58 | Inputs {.sidebar data-width=300} 59 | ------------------------------------- 60 | 61 |
62 | 63 | ```{r} 64 | d_reactable <- data_xray 65 | 66 | d_reactable_shared <- SharedData$new(d_reactable) 67 | 68 | filter_select('type', 'variable TYPE', d_reactable_shared, ~ TYPE) 69 | filter_select('var', 'variable NAME', d_reactable_shared, ~ VAR) 70 | filter_select('lab', 'variable LABEL', d_reactable_shared, ~ LABEL) 71 | filter_select('n', 'variable COMPLETE',d_reactable_shared, ~ ifelse(n == dim[1], 'YES', 'NO')) 72 | 73 | filter_slider('missing', 'variable % MISSING', d_reactable_shared, ~ 100*(missing/dim[1]), 74 | width = 250, 75 | post = '%', 76 | min = 0, max = 100, 77 | dragRange = FALSE, 78 | step = 5, round = TRUE, sep = '', ticks = TRUE) 79 | 80 | filter_slider('distinct', 'variable # DISTINCT', d_reactable_shared, ~ distinct, 81 | width = 250, 82 | min = 1, dragRange = FALSE, 83 | step = 5, ticks = FALSE) 84 | ``` 85 | 86 | 87 | Column 88 | ------------------------------------- 89 | ### **`r toupper(params$data_name)`** DATA with **`r dim[1]`** OBSERVATIONS and **`r dim[2]`** VARIABLES 90 | 91 | ```{r create-reactable-1} 92 | view_xray(data_xray = d_reactable, data_xray_shared = d_reactable_shared, by = params$by) 93 | ``` 94 | -------------------------------------------------------------------------------- /man/create_hist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/create_hist.R 3 | \name{create_hist} 4 | \alias{create_hist} 5 | \title{Create interactive histogram} 6 | \usage{ 7 | create_hist(x, counts, values) 8 | } 9 | \arguments{ 10 | \item{x}{Variable from dataset in vector form.} 11 | 12 | \item{counts}{Counts component of Hmisc::describe() output} 13 | 14 | \item{values}{Values component of Hmisc::describe() output} 15 | } 16 | \value{ 17 | Plotly figure containing spike histogram (numeric) or traditional histogram (character). 18 | } 19 | \description{ 20 | Code adapted from Hmisc package's spike histograms. 21 | } 22 | \examples{ 23 | adsl <- safetyData::adam_adsl 24 | create_hist(adsl$AGE) 25 | create_hist(adsl$SITEID) 26 | 27 | } 28 | -------------------------------------------------------------------------------- /man/make_xray.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/make_xray.R 3 | \name{make_xray} 4 | \alias{make_xray} 5 | \title{Make data xray by a grouping variable} 6 | \usage{ 7 | make_xray(data, by = NULL) 8 | } 9 | \arguments{ 10 | \item{data}{A data frame.} 11 | 12 | \item{by}{Optional name of grouping ("by") variable as character string.} 13 | } 14 | \value{ 15 | A tibble containing variable metadata with 1 row per group. 16 | } 17 | \description{ 18 | Create comprehensive tibble of variable metadata using Hmisc::describe as engine, with option for grouping 19 | } 20 | \examples{ 21 | 22 | diamonds <- ggplot2::diamonds 23 | make_xray(diamonds) 24 | 25 | make_xray(diamonds, by = 'cut') 26 | 27 | } 28 | -------------------------------------------------------------------------------- /man/make_xray_core.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/make_xray_core.R 3 | \name{make_xray_core} 4 | \alias{make_xray_core} 5 | \title{Make data xray - core function} 6 | \usage{ 7 | make_xray_core(data) 8 | } 9 | \arguments{ 10 | \item{data}{A data frame.} 11 | } 12 | \value{ 13 | A tibble containing variable metadata. 14 | } 15 | \description{ 16 | Create comprehensive tibble of variable metadata using Hmisc::describe as engine. 17 | } 18 | \examples{ 19 | 20 | diamonds <- ggplot2::diamonds 21 | make_xray_core(diamonds) 22 | 23 | } 24 | -------------------------------------------------------------------------------- /man/nested_tab_counts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/style_nested_tabs.R 3 | \name{nested_tab_counts} 4 | \alias{nested_tab_counts} 5 | \title{Create nested table display for counts} 6 | \usage{ 7 | nested_tab_counts(counts_df) 8 | } 9 | \arguments{ 10 | \item{counts_df}{Dataframe of COUNTS from Hmisc::describe} 11 | } 12 | \description{ 13 | Create nested table display for counts 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/nested_tab_extremes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/style_nested_tabs.R 3 | \name{nested_tab_extremes} 4 | \alias{nested_tab_extremes} 5 | \title{Create nested table display for extremes} 6 | \usage{ 7 | nested_tab_extremes(extremes_df) 8 | } 9 | \arguments{ 10 | \item{extremes_df}{Dataframe of EXTREMES from Hmisc::describe} 11 | } 12 | \description{ 13 | Create nested table display for extremes 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/nested_tab_theme.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/style_nested_tabs.R 3 | \name{nested_tab_theme} 4 | \alias{nested_tab_theme} 5 | \title{Theme for nested tables} 6 | \usage{ 7 | nested_tab_theme() 8 | } 9 | \value{ 10 | Object of class reactableTheme 11 | } 12 | \description{ 13 | Theme for nested tables 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/nested_tab_values.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/style_nested_tabs.R 3 | \name{nested_tab_values} 4 | \alias{nested_tab_values} 5 | \title{Create nested table display for values} 6 | \usage{ 7 | nested_tab_values(values_df) 8 | } 9 | \arguments{ 10 | \item{values_df}{Dataframe of VALUES from Hmisc::describe} 11 | } 12 | \description{ 13 | Create nested table display for values 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/report_xray.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/report_xray.R 3 | \name{report_xray} 4 | \alias{report_xray} 5 | \title{Create X-ray report} 6 | \usage{ 7 | report_xray(data, by = NULL, data_name, study, loc = NULL) 8 | } 9 | \arguments{ 10 | \item{data}{A data frame.} 11 | 12 | \item{by}{Optional name of grouping ("by") variable as character string.} 13 | 14 | \item{data_name}{Name of dataset to be displayed in report as character string.} 15 | 16 | \item{study}{Name of study to be displayed in report as character string.} 17 | 18 | \item{loc}{Directory to save the rmd and html output. Defaults to current working directory.} 19 | } 20 | \value{ 21 | 22 | } 23 | \description{ 24 | Create X-ray report 25 | } 26 | \examples{ 27 | 28 | \dontrun{ 29 | 30 | diamonds <- ggplot2::diamonds \%>\% 31 | mutate(price = structure(price, label = 'price in US dollars'), 32 | carat = structure(carat, label = 'weight of the diamond'), 33 | cut = structure(cut, label = 'quality of the cut (Fair, Good, Very Good, Premium, Ideal)'), 34 | color = structure(color, label = 'diamond colour, from D (best) to J (worst)'), 35 | clarity = structure(clarity, label = 'a measurement of how clear the diamond is (I1 (worst), SI2, SI1, VS2, VS1, VVS2, VVS1, IF (best))'), 36 | x = structure(x, label = 'length in mm'), 37 | y = structure(y, label = 'width in mm'), 38 | z = structure(z, label = 'depth in mm'), 39 | depth = structure(depth, label = 'total depth percentage = z / mean(x, y) = 2 * z / (x + y)'), 40 | table = structure(table, label = 'width of top of diamond relative to widest point')) 41 | 42 | diamonds \%>\% 43 | report_xray(data_name = 'Diamonds', study = 'ggplot2', loc = getwd()) 44 | 45 | diamonds \%>\% 46 | report_xray(data_name = 'Diamonds', by = 'cut', study = 'ggplot2', loc = getwd()) 47 | 48 | } 49 | 50 | } 51 | -------------------------------------------------------------------------------- /man/view_xray.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/view_xray.R 3 | \name{view_xray} 4 | \alias{view_xray} 5 | \title{Create interactive table using Hmisc::describe + reactable} 6 | \usage{ 7 | view_xray(data_xray, data_xray_shared = NULL, by = NULL, elementId = NULL) 8 | } 9 | \arguments{ 10 | \item{data_xray}{Output of `make_xray()`} 11 | 12 | \item{data_xray_shared}{[Optional] `data_xray` converted to a `SharedData` object using crosstalk, for use with linked widgets.} 13 | 14 | \item{by}{Optional name of group by variable as character string} 15 | 16 | \item{elementId}{Unique element ID for the table} 17 | } 18 | \value{ 19 | Reactable display 20 | } 21 | \description{ 22 | Create interactive table using Hmisc::describe + reactable 23 | } 24 | \examples{ 25 | 26 | diamonds <- ggplot2::diamonds 27 | 28 | diamonds \%>\% 29 | make_xray() \%>\% 30 | view_xray() 31 | 32 | diamonds \%>\% 33 | make_xray(by = 'cut') \%>\% 34 | view_xray(by =) 35 | 36 | } 37 | --------------------------------------------------------------------------------