Feature/plotly

DESCRIPTION

@@ -52,7 +52,8 @@ Suggests:
   faviconPlease,
   ggplot2,
   opencpu,
+  plotly,
   tinytest (>= 1.2.3),
   ttdo (>= 0.0.6),
   UpSetR
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2

R/add.R

@@ -398,7 +398,8 @@ addMetaFeatures <- function(study, metaFeatures, reset = FALSE) {
 #'   will be assumed to be \code{"singleFeature"} and \code{"singleTest"}.
 #'   Optionally, if the plotting function requires external packages, these can
 #'   be defined in the element \code{packages}. To share plots across multiple
-#'   models, use the modelID "default".
+#'   models, use the modelID "default". To add a plotting function that returns
+#'   an interactive plotly plot, add "plotly" to the \code{plotType} vector.
 #' @inherit shared-add
 #'
 #' @seealso \code{\link{getPlottingData}}, \code{\link{plotStudy}}

R/plots.R

@@ -40,6 +40,7 @@ plotStudy <- function(study, modelID, featureID, plotID, testID = NULL, librarie
          "Plots available:\n",
          sprintf("* \"%s\"\n", plotsAvailable))
   }
+
   p <- plots[[plotID]]
   if (inherits(study, "onStudy")) {
     f <- getPlotFunction(plotID)
@@ -63,6 +64,7 @@ plotStudy <- function(study, modelID, featureID, plotID, testID = NULL, librarie
   }
 
   nPlotType <- length(plotType)
+  dynamic <- FALSE
 
   for (ind in 1:nPlotType) {
     if (plotType[ind] == "singleFeature") {
@@ -97,6 +99,9 @@ plotStudy <- function(study, modelID, featureID, plotID, testID = NULL, librarie
         sprintf("Received %d testID(s)", nTests)
       )
     }
+    if(plotType[ind] == "plotly"){
+      dynamic <- TRUE
+    }
     # multiModel is checked as a multiTest as it requires at least 2 testIDs, eg.:
     # (1) 1 testID per model and > 1 model
     # (2) > 1 testID and 1 model
@@ -121,18 +126,18 @@ plotStudy <- function(study, modelID, featureID, plotID, testID = NULL, librarie
           )
         }
       }
+      if (length(modelID) > 1) {
+        model_features <- mapping[[modelID[1]]][!is.na(mapping[[modelID[1]]])]
+        if (!all(featureID %in% model_features)) {
+          stop(
+            "features list contains at least one feature not present in the corresponding model from mapping object\n",
+            sprintf("ModelID : %s", modelID[1])
+          )
+        }
+      }
     }
   }
 
-  if (length(modelID) > 1) {
-    model_features <- mapping[[modelID[1]]][!is.na(mapping[[modelID[1]]])]
-    if (!all(featureID %in% model_features)) {
-      stop(
-        "features list contains at least one feature not present in the corresponding model from mapping object\n",
-        sprintf("ModelID : %s", modelID[1])
-        )
-    }
-  }
 
   plottingData <- getPlottingData(study, modelID, featureID, testID = testID,
                                   libraries = libraries)
@@ -155,7 +160,12 @@ plotStudy <- function(study, modelID, featureID, plotID, testID = NULL, librarie
     }
   }
 
-  returned <- f(plottingData)
+  if (dynamic == TRUE){
+    returned <- plotly::plotly_json(f(plottingData), jsonedit = FALSE)
+
+    }else{
+    returned <- f(plottingData)
+  }
 
   # This is required so that the plot is immediately displayed. The final value
   # is returned invisibly to avoid overwhelming the R console with the data some

R/tests.R

@@ -293,6 +293,7 @@ testPlots <- function() {
     graphics::plot(df$value.x ~ df$value.y, col = factor(df$variable))
   }
   assign("plotMultiTestMf", plotMultiTestMf, envir = parent.frame())
+
   multiModel_scatterplot <- function(x) {
     ggdf <- data.frame(
       var1 = x[[1]]$results[,"beta"],
@@ -313,6 +314,17 @@ testPlots <- function() {
   }
   assign("multiModel_barplot_sf", multiModel_barplot_sf, envir = parent.frame())
 
+  plotPlotly <- function(x){
+    plotPoints <- as.numeric(x[["assays"]][1, ])
+    featureMedian <- stats::median(plotPoints)
+    plotTitle <- sprintf("%s, median: %0.2f", x[["features"]][["customID"]],
+                         featureMedian)
+    p <- ggplot2::qplot(seq_along(plotPoints), plotPoints, main = plotTitle,
+                   xlab = "Samples", ylab = "Expression level")
+    plotly::ggplotly(p)
+  }
+  assign("plotPlotly", plotPlotly, envir = parent.frame())
+
   plots <- list(
     default = list(
       plotBase = list(
@@ -351,6 +363,11 @@ testPlots <- function() {
         displayName = "Custom ggplot2 plot",
         plotType = "singleFeature",
         packages = c("ggplot2", "stats")
+      ),
+      plotPlotly = list(
+        displayName = "Custom plotly plot",
+        plotType = c("singleFeature", "plotly"),
+        packages = c("plotly", "ggplot2", "stats")
       )
     )
   )

inst/tinytest/testPlot.R

@@ -30,7 +30,7 @@ pkgDependencies <- utils::packageDescription(
 
 expect_identical_xl(
   pkgDependencies,
-  "data.table, ggplot2, graphics, rlang, stats"
+  "data.table, ggplot2, graphics, plotly, rlang, stats"
 )
 
 pkgExports <- sort(getNamespaceExports(testPkgName))
@@ -90,6 +90,10 @@ expect_silent_xl(
 expect_error_xl(
   plotStudy(testStudyObj, modelID = "model_03", featureID = "feature_0001", plotID = "plotBase")
 )
+#plotly
+expect_error_xl(
+  plotStudy(testStudyObj, modelID = "model_01", featureID = "feature_0001", plotID = "plotPlotly")
+)
 
 expect_error_xl(
   plotStudy(testStudyObj, modelID = "model_01", featureID = "feature_0001", plotID = "plotGg")
@@ -131,6 +135,10 @@ expect_silent_xl(
 expect_error_xl(
   plotStudy(testStudyName, modelID = "model_03", featureID = "feature_0001", plotID = "plotBase")
 )
+#plotly
+expect_error_xl(
+  plotStudy(testStudyName, modelID = "model_04", featureID = "feature_0001", plotID = "plotPlotly")
+)
 
 expect_error_xl(
   plotStudy(testStudyName, modelID = "model_01", featureID = "feature_0001", plotID = "plotGg")
@@ -937,6 +945,14 @@ expect_identical_xl(
   c("feature_0006", "feature_0002")
 )
 
+# Plotly Plots -----------------------------------------------------------------
+
+
+json <- plotStudy(testStudyName, modelID = "model_03", featureID = "feature_0001", plotID = "plotPlotly")
+expect_true_xl(
+  inherits(json, "json")
+)
+
 # Teardown ---------------------------------------------------------------------
 
 unloadNamespace(testPkgName)