Merge pull request #18 from upsetjs/sgratzl/dash

add Plot.ly Dash support

.Rbuildignore

@@ -4,6 +4,7 @@
 
 ^doc$
 ^shiny$
+^dash$
 ^docs$
 ^Meta$
 ^js$

.gitignore

@@ -24,6 +24,7 @@ docs
 /NAMESPACE
 /inst/htmlwidgets/upsetjs.js
 /inst/htmlwidgets/upsetjs.js.LICENSE.txt
+/inst/dash/
 doc
 Meta
 /vignettes/*.R

LICENSE

@@ -1,10 +1,10 @@
 ## License
 
-If you are using UpSet.js for a commercial project, you would need to get a commercial license by contacting sam@sgratzl.com.
+If you are using UpSet.js for a commercial project or in a commercial environment, you would need to get a commercial license by contacting sam@sgratzl.com.
 
 ### Commercial license
 
-If you want to use UpSet.js for a commercial application, theme or plugin the commercial license is the appropriate license. With this option, your source code is kept proprietary.
+If you want to use UpSet.js for a commercial application or in a commercial environment, the commercial license is the appropriate license. With this option, your source code is kept proprietary.
 
 ### Open-source license
 

R/dash.R

@@ -0,0 +1,58 @@
+#
+# @upsetjs/r
+# https://github.com/upsetjs/upsetjs_r
+#
+# Copyright (c) 2021 Samuel Gratzl <sam@sgratzl.com>
+#
+
+#'
+#' create a new upsetjs dash adapter
+#' @export
+upsetjsDash <- function(children = NULL, id = NULL, width = NULL, height = NULL) {
+  props <- list(
+    children = children, id = id, height = height, width = width,
+    renderMode = "upset"
+  )
+  if (length(props) > 0) {
+    props <- props[!vapply(props, is.null, logical(1))]
+  }
+  component <- list(
+    props = props,
+    type = "DashUpSetJS",
+    namespace = "upsetjs",
+    propNames = c(
+      "children", "id", "height", "width", "renderMode", "mode",
+      "attrs", "sets", "combinations", "queryLegend", "queries", "interactive", "selection",
+      "heightRatios", "widthRatios", "padding", "barPadding", "dotPadding", "numericalScale", "bandScale",
+      "title", "description", "setName", "combinationName", "combinationNameAxisOffset", "barLabelOffset", "setNameAxisOffset",
+      "fontFamily", "fontSizes", "exportButtons", "className",
+      "theme", "selectionColor", "alternatingBackgroundColor", "color",
+      "hasSelectionColor", "textColor", "hoverHintColor", "notMemberColor", "valueTextColor", "strokeColor", "opacity", "hasSelectionOpacity", "filled"
+    ),
+    package = "upsetjs"
+  )
+
+  structure(component, class = c("dash_component", "upsetjs_upset_dash", "upsetjs_common_dash", "list"))
+}
+
+
+.dash_upsetjs_js_metadata <- function() {
+  deps_metadata <- list(
+    `upsetjs` = structure(list(
+      name = "upsetjs",
+      version = "1.9.0",
+      src = list(
+        href = NULL,
+        file = "dash"
+      ),
+      meta = NULL,
+      script = "upsetjs.js",
+      stylesheet = NULL,
+      head = NULL,
+      attachment = NULL,
+      package = "upsetjs",
+      all_files = FALSE
+    ), class = "html_dependency")
+  )
+  return(deps_metadata)
+}

R/data.R

@@ -423,8 +423,12 @@ fromDataFrame <- function(upsetjs,
 #'   getElements()
 #' @export
 getElements <- function(upsetjs) {
-  stopifnot(inherits(upsetjs, "upsetjs_common"))
-  upsetjs$x$elems
+  stopifnot(inherits(upsetjs, c("upsetjs_common", "upsetjs_common_dash")))
+  if (inherits(upsetjs, "upsetjs_common")) {
+    upsetjs$x$elems
+  } else {
+    upsetjs$props$elems
+  }
 }
 
 #'
@@ -438,7 +442,7 @@ getElements <- function(upsetjs) {
 #'   getElements()
 #' @export
 setElements <- function(upsetjs, value) {
-  stopifnot(inherits(upsetjs, "upsetjs_common"))
+  stopifnot(inherits(upsetjs, c("upsetjs_common", "upsetjs_common_dash")))
   setProperty(upsetjs, "elems", value)
 }
 
@@ -452,8 +456,12 @@ setElements <- function(upsetjs, value) {
 #'   getSets()
 #' @export
 getSets <- function(upsetjs) {
-  stopifnot(inherits(upsetjs, "upsetjs_common"))
-  upsetjs$x$sets
+  stopifnot(inherits(upsetjs, c("upsetjs_common", "upsetjs_common_dash")))
+  if (inherits(upsetjs, "upsetjs_common")) {
+    upsetjs$x$sets
+  } else {
+    upsetjs$props$sets
+  }
 }
 
 #'
@@ -467,7 +475,7 @@ getSets <- function(upsetjs) {
 #'   getSets()
 #' @export
 setSets <- function(upsetjs, value) {
-  stopifnot(inherits(upsetjs, "upsetjs_common"))
+  stopifnot(inherits(upsetjs, c("upsetjs_common", "upsetjs_common_dash")))
   setProperty(upsetjs, "sets", value)
 }
 
@@ -481,8 +489,12 @@ setSets <- function(upsetjs, value) {
 #'   getCombinations()
 #' @export
 getCombinations <- function(upsetjs) {
-  stopifnot(inherits(upsetjs, "upsetjs_common"))
-  upsetjs$x$combinations
+  stopifnot(inherits(upsetjs, c("upsetjs_common", "upsetjs_common_dash")))
+  if (inherits(upsetjs, "upsetjs_common")) {
+    upsetjs$x$combinations
+  } else {
+    upsetjs$props$combinations
+  }
 }
 
 #'
@@ -496,7 +508,7 @@ getCombinations <- function(upsetjs) {
 #'   getCombinations()
 #' @export
 setCombinations <- function(upsetjs, value) {
-  stopifnot(inherits(upsetjs, "upsetjs_common"))
+  stopifnot(inherits(upsetjs, c("upsetjs_common", "upsetjs_common_dash")))
   setProperty(upsetjs, "combinations", value)
 }
 
@@ -523,6 +535,9 @@ generateCombinations <- function(upsetjs,
   if (inherits(upsetjs, "upsetjs_common")) {
     sets <- upsetjs$x$sets
     gen <- generateCombinationsImpl(sets, c_type, min, max, empty, order.by, limit, colors, symbol)
+  } else if (inherits(upsetjs, "upsetjs_common_dash")) {
+    sets <- upsetjs$props$sets
+    gen <- generateCombinationsImpl(sets, c_type, min, max, empty, order.by, limit, colors, symbol)
   } else {
     # proxy
     gen <- cleanNull(list(

R/selection.R

@@ -28,7 +28,7 @@ setSelection <- function(upsetjs, name = NULL) {
 #'
 #' make it an interactive chart
 #' @param upsetjs an object of class \code{upsetjs} or \code{upsetjs_proxy}
-#' @param value whether to enable or disable
+#' @param value whether to enable or disable or set the mode: hover, click, contextMenu
 #' @return the object given as first argument
 #' @examples
 #' upsetjs() %>%
@@ -37,7 +37,7 @@ setSelection <- function(upsetjs, name = NULL) {
 #' @export
 interactiveChart <- function(upsetjs, value = TRUE) {
   checkUpSetCommonArgument(upsetjs)
-  stopifnot(is.logical(value), length(value) == 1)
+  stopifnot(is.logical(value) || (value %in% c("hover", "click", "contextMenu")), length(value) == 1)
 
   setProperty(upsetjs, "interactive", value)
 }

R/upsetjs.R

@@ -51,7 +51,6 @@ upsetjs <- function(width = "100%",
                     sizingPolicy = upsetjsSizingPolicy()) {
   # forward options using x
   x <- structure(list(
-    mode = "hover",
     sets = c()
   ))
 
@@ -112,7 +111,6 @@ upsetjsVennDiagram <- function(width = "100%",
   # forward options using x
   x <- structure(list(
     renderMode = "venn",
-    mode = "hover",
     sets = c()
   ))
 
@@ -173,7 +171,6 @@ upsetjsEulerDiagram <- function(width = "100%",
   # forward options using x
   x <- structure(list(
     renderMode = "euler",
-    mode = "hover",
     sets = c()
   ))
 
@@ -234,7 +231,6 @@ upsetjsKarnaughMap <- function(width = "100%",
   # forward options using x
   x <- structure(list(
     renderMode = "kmap",
-    mode = "hover",
     sets = c()
   ))
 

R/utils.R

@@ -7,42 +7,48 @@
 
 checkUpSetCommonArgument <- function(upsetjs) {
   if (!inherits(upsetjs, "upsetjs_common") &&
-    !inherits(upsetjs, "upsetjs_common_proxy")) {
-    stop("first argument needs to be an upsetjs or upsetjs_venn instance")
+    !inherits(upsetjs, "upsetjs_common_proxy") &&
+    !inherits(upsetjs, "upsetjs_common_dash")) {
+    stop("first argument needs to be an upsetjs or upsetjs_venn or upsetjs_kmap instance")
   }
 }
 
 checkUpSetArgument <- function(upsetjs) {
   if (!inherits(upsetjs, "upsetjs_upset") &&
-    !inherits(upsetjs, "upsetjs_upset_proxy")) {
+    !inherits(upsetjs, "upsetjs_upset_proxy") &&
+    !inherits(upsetjs, "upsetjs_upset_dash")) {
     stop("first argument needs to be an upsetjs instance")
   }
 }
 
 checkVennDiagramArgument <- function(upsetjs) {
   if (!inherits(upsetjs, "upsetjs_venn") &&
-    !inherits(upsetjs, "upsetjs_venn_proxy")) {
+    !inherits(upsetjs, "upsetjs_venn_proxy") &&
+    !inherits(upsetjs, "upsetjs_venn_dash")) {
     stop("first argument needs to be an upsetjs_venn instance")
   }
 }
 
 checkKarnaughMapArgument <- function(upsetjs) {
   if (!inherits(upsetjs, "upsetjs_kmap") &&
-    !inherits(upsetjs, "upsetjs_kmap_proxy")) {
+    !inherits(upsetjs, "upsetjs_kmap_proxy") &&
+    !inherits(upsetjs, "upsetjs_kmap_dash")) {
     stop("first argument needs to be an upsetjs_kmap instance")
   }
 }
 
 isVennDiagram <- function(upsetjs) {
   checkUpSetCommonArgument(upsetjs)
   inherits(upsetjs, "upsetjs_venn") ||
-    inherits(upsetjs, "upsetjs_venn_proxy")
+    inherits(upsetjs, "upsetjs_venn_proxy") ||
+    inherits(upsetjs, "upsetjs_venn_dash")
 }
 
 isKarnaughMap <- function(upsetjs) {
   checkUpSetCommonArgument(upsetjs)
   inherits(upsetjs, "upsetjs_kmap") ||
-    inherits(upsetjs, "upsetjs_kmap_proxy")
+    inherits(upsetjs, "upsetjs_kmap_proxy") ||
+    inherits(upsetjs, "upsetjs_kmap_dash")
 }
 
 stopIfNotType <- function(name,
@@ -90,6 +96,8 @@ setProperty <- function(upsetjs, prop, value) {
     props <- list()
     props[[prop]] <- value
     sendMessage(upsetjs, props)
+  } else if (inherits(upsetjs, "upsetjs_common_dash")) {
+    upsetjs$props[[prop]] <- value
   }
   upsetjs
 }
@@ -107,6 +115,12 @@ appendProperty <- function(upsetjs, prop, value) {
     props <- list()
     props[[prop]] <- value
     sendMessage(upsetjs, props, append = TRUE)
+  } else if (inherits(upsetjs, "upsetjs_common_dash")) {
+    if (is.null(upsetjs$x[[prop]])) {
+      upsetjs$props[[prop]] <- list(value)
+    } else {
+      upsetjs$props[[prop]] <- c(upsetjs$props[[prop]], list(value))
+    }
   }
   upsetjs
 }
@@ -123,6 +137,10 @@ setProperties <- function(upsetjs, props, clean = FALSE) {
     }
   } else if (inherits(upsetjs, "upsetjs_common_proxy")) {
     sendMessage(upsetjs, props)
+  } else if (inherits(upsetjs, "upsetjs_common_dash")) {
+    for (prop in names(props)) {
+      upsetjs$props[[prop]] <- props[[prop]]
+    }
   }
   upsetjs
 }

README.md

@@ -2,7 +2,7 @@
 
 [![CRAN][cran-image]][cran-url] [![Github Actions][github-actions-image]][github-actions-url] [![Open in Binder][binder]][binder-r-url] [![Open Docs][docs]][docs-r-url] [![Open example][example]][example-r-url]
 
-This is a [HTMLWidget](http://www.htmlwidgets.org/) wrapper around the JavaScript library [UpSet.js](https://github.com/upsetjs/upsetjs) and an alternative implementation of [UpSetR](https://www.rdocumentation.org/packages/UpSetR).
+This is a [HTMLWidget](http://www.htmlwidgets.org/) and [Plot.ly Dash](https://dashr.plotly.com/) wrapper around the JavaScript library [UpSet.js](https://github.com/upsetjs/upsetjs) and an alternative implementation of [UpSetR](https://www.rdocumentation.org/packages/UpSetR).
 
 This package is part of the UpSet.js ecosystem located at the main [Github Monorepo](https://github.com/upsetjs/upsetjs).
 
@@ -57,7 +57,41 @@ shinyApp(ui = ui, server = server)
 
 ![shiny](https://user-images.githubusercontent.com/4129778/79375695-51d5bb80-7f59-11ea-8437-40fa60ce425c.png)
 
-see also [Shiny Examples](./master/shiny)
+see also [Shiny Examples](./main/shiny)
+
+## Dash Example
+
+```R
+library(dash)
+library(dashHtmlComponents)
+library(upsetjs)
+
+app <- Dash$new()
+
+app$layout(
+    htmlDiv(
+        list(
+            htmlH1("Hello UpSet.js + Dash"),
+            upsetjsDash(id = "upset") %>% fromList(list(a = c(1, 2, 3), b = c(2, 3)))
+                %>% interactiveChart(),
+            htmlDiv(id = "output")
+        )
+    )
+)
+app$callback(
+    output = list(id = "output", property = "children"),
+    params = list(input(id = "upset", property = "selection")),
+    function(selection) {
+        sprintf("You selected \"%s\"", selection$name)
+    }
+)
+
+app$run_server()
+```
+
+TODO
+
+see also [Dash Examples](./main/dash)
 
 ## Documentation
 
@@ -160,11 +194,12 @@ UpSet.js is a client only library. The library or any of its integrations doesn'
 
 ### Commercial license
 
-If you want to use Upset.js for a commercial application the commercial license is the appropriate license. Contact [@sgratzl](mailto:sam@sgratzl.com) for details.
+If you want to use UpSet.js for a commercial application or in a commercial environment, the commercial license is the appropriate license. Contact [@sgratzl](mailto:sam@sgratzl.com) for details.
 
 ### Open-source license
 
-This library is released under the `GNU AGPLv3` version to be used for private and academic purposes. In case of a commercial use, please get in touch regarding a commercial license.
+This library is released under the `GNU AGPLv3` version to be used for private and academic purposes.
+In case of a commercial use, please get in touch regarding a commercial license.
 
 [github-actions-image]: https://github.com/upsetjs/upsetjs_r/workflows/ci/badge.svg
 [github-actions-url]: https://github.com/upsetjs/upsetjs_r/actions