remove frameOrder warning (#1927)

* remove frameOrder warning

* use expect_warning

* fix bunch of tests warnings

* update expected shinytest (jquery and crosstalk versions)

* Apply suggestions from code review

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

Author: FrankBornais

R/plotly_build.R

@@ -425,7 +425,10 @@ registerFrames <- function(p, frameMapping = NULL) {
   # remove frames from the trace names
   for (i in seq_along(p$x$data)) {
     tr <- p$x$data[[i]]
-    if (length(tr[["name"]]) != 1) next
+    if (length(tr[["name"]]) != 1) {
+      p$x$data[[i]]$frameOrder <- NULL
+      next
+    } 
     nms <- strsplit(as.character(tr[["name"]]), br())[[1]]
     idx <- setdiff(seq_along(nms), tr$frameOrder %||% 0)
     p$x$data[[i]]$name <- if (length(idx)) paste(nms[idx], collapse = br()) else NULL

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json

@@ -413,9 +413,9 @@
         },
         {
           "name": "jquery",
-          "version": "1.11.3",
+          "version": "3.5.1",
           "src": {
-            "href": "jquery-1.11.3"
+            "href": "jquery-3.5.1"
           },
           "meta": null,
           "script": "jquery.min.js",
@@ -426,9 +426,9 @@
         },
         {
           "name": "crosstalk",
-          "version": "1.1.0.1",
+          "version": "1.1.1",
           "src": {
-            "href": "crosstalk-1.1.0.1"
+            "href": "crosstalk-1.1.1"
           },
           "meta": null,
           "script": "js/crosstalk.min.js",

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png

@@ -430,9 +430,9 @@
         },
         {
           "name": "jquery",
-          "version": "1.11.3",
+          "version": "3.5.1",
           "src": {
-            "href": "jquery-1.11.3"
+            "href": "jquery-3.5.1"
           },
           "meta": null,
           "script": "jquery.min.js",
@@ -443,9 +443,9 @@
         },
         {
           "name": "crosstalk",
-          "version": "1.1.0.1",
+          "version": "1.1.1",
           "src": {
-            "href": "crosstalk-1.1.0.1"
+            "href": "crosstalk-1.1.1"
           },
           "meta": null,
           "script": "js/crosstalk.min.js",

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json

@@ -434,9 +434,9 @@
         },
         {
           "name": "jquery",
-          "version": "1.11.3",
+          "version": "3.5.1",
           "src": {
-            "href": "jquery-1.11.3"
+            "href": "jquery-3.5.1"
           },
           "meta": null,
           "script": "jquery.min.js",
@@ -447,9 +447,9 @@
         },
         {
           "name": "crosstalk",
-          "version": "1.1.0.1",
+          "version": "1.1.1",
           "src": {
-            "href": "crosstalk-1.1.0.1"
+            "href": "crosstalk-1.1.1"
           },
           "meta": null,
           "script": "js/crosstalk.min.js",

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png

@@ -435,9 +435,9 @@
         },
         {
           "name": "jquery",
-          "version": "1.11.3",
+          "version": "3.5.1",
           "src": {
-            "href": "jquery-1.11.3"
+            "href": "jquery-3.5.1"
           },
           "meta": null,
           "script": "jquery.min.js",
@@ -448,9 +448,9 @@
         },
         {
           "name": "crosstalk",
-          "version": "1.1.0.1",
+          "version": "1.1.1",
           "src": {
-            "href": "crosstalk-1.1.0.1"
+            "href": "crosstalk-1.1.1"
           },
           "meta": null,
           "script": "js/crosstalk.min.js",

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json

@@ -359,8 +359,8 @@ test_that("simple animation targeting works", {
 
 test_that("animation frames are boxed up correctly", {
   dallas <- subset(txhousing, city == "Dallas" & month == 1)
-  p <- ggplot(dallas) +
-    geom_point(aes(x = volume, y = sales, frame = year))
+  p <- ggplot(dallas, aes(x = volume, y = sales, frame = year)) +
+    geom_point()
   l <- plotly_build(p)$x
 
   for (i in seq_along(l$frames)) {

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png

@@ -33,12 +33,14 @@ test_that("factor levels determine tick order", {
 ## range are dropped, resulting in a misleading box plot.
 bp.ylim.hide <- bp + ylim(5, 7.5)
 test_that("ylim hides points", {
-  info <- expect_traces(bp.ylim.hide, 1, "ylim.hide")
+  info <- expect_warning(expect_traces(bp.ylim.hide, 1, "ylim.hide"), 
+                         regexp = "non-finite values")
 })
 
 bp.scale.hide <- bp + scale_y_continuous(limits = c(5, 7.5))
 test_that("scale_y(limits) hides points", {
-  info <- expect_traces(bp.scale.hide, 1, "scale.hide")
+  info <- expect_warning(expect_traces(bp.scale.hide, 1, "scale.hide"), 
+                         regexp = "non-finite values")
   expect_equivalent(range(info$layout$yaxis$tickvals), c(5, 7.5))
   y <- unlist(lapply(info$data, "[[", "y"))
   expect_true(all(5 <= y & y <= 7.5, na.rm = TRUE))

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json

@@ -33,5 +33,7 @@ test_that("scale_x_date and irregular time series work", {
   )
   df <- df[order(df$date), ]
   dt <- qplot(date, price, data = df, geom = "line") + theme(aspect.ratio = 1/4)
-  info <- expect_doppelganger_built(dt, "date-irregular-time-series")
+  
+  info <- expect_warning(expect_doppelganger_built(dt, "date-irregular-time-series"), 
+                         regexp = "Aspect ratios aren't yet implemented")
 })

inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png

@@ -33,7 +33,9 @@ test_that("Categorical axis reflects custom scale mapping", {
   g <- ggplot(mpg, aes(class, color = class)) + 
     geom_bar() +
     scale_x_discrete(limits = lims)
-  p <- ggplotly(g, dynamicTicks = "x")
+  
+  expect_warning(p <- ggplotly(g, dynamicTicks = "x"), 
+                 regexp = "non-finite values")
 
   axisActual <- with(
     p$x$layout$xaxis, list(type, tickmode, categoryorder, categoryarray)
@@ -48,7 +50,8 @@ test_that("Categorical axis reflects custom scale mapping", {
   g <- ggplot(mpg, aes(class, color = class)) + 
     geom_bar() +
     scale_x_discrete(limits = lims, labels = labs)
-  p <- ggplotly(g, dynamicTicks = "x")
+  expect_warning(p <- ggplotly(g, dynamicTicks = "x"), 
+                 regexp = "non-finite values")
 
   axisActual <- with(
     p$x$layout$xaxis, list(type, tickmode, categoryorder, categoryarray)
@@ -103,4 +106,3 @@ test_that("Inverse maps colorbar data", {
   expect_true(l$data[[2]]$y %in% unique(mpg$manufacturer))
 
 })
-

tests/testthat/test-animate-highlight.R

@@ -56,7 +56,8 @@ test_that('boxes with coord_flip()+facet_grid(scales="free")', {
 
 test_that("limits can hide data", {
   boxes.limits <- boxes + scale_x_discrete(limits = c("trt1", "ctrl"))
-  info <- expect_traces(boxes.limits, 1, "limits-hide")
+  info <- expect_warning(expect_traces(boxes.limits, 1, "limits-hide"), 
+                         regexp = "missing values")
   expect_equivalent(info$layout$xaxis$ticktext, c("trt1", "ctrl"))
 })
 

tests/testthat/test-cookbook-axes.R

@@ -12,27 +12,31 @@ test_that("plot_ly() handles a simple scatterplot", {
 })
 
 test_that("Mapping a factor variable to color works", {
-  p <- plot_ly(palmerpenguins::penguins, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species)
+  d <- palmerpenguins::penguins %>% 
+    filter(!is.na(bill_length_mm))
+  p <- plot_ly(d, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species)
   l <- expect_traces(p, 3, "scatterplot-color-factor")
   markers <- lapply(l$data, "[[", "marker")
   cols <- unlist(lapply(markers, "[[", "color"))
   expect_equivalent(length(cols), 3)
 })
 
 test_that("Custom RColorBrewer pallette works for factor variable", {
+  d <- palmerpenguins::penguins %>% 
+    filter(!is.na(bill_length_mm))
   cols <- RColorBrewer::brewer.pal(9, "Set1")
   # convert hex to rgba spec for comparison's sake
   colsToCompare <- toRGB(cols)
   # specifying a pallette set should "span the gamut" 
-  p <- plot_ly(palmerpenguins::penguins, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species, 
+  p <- plot_ly(d, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species, 
                colors = "Set1")
   l <- expect_traces(p, 3, "scatterplot-color-factor-custom")
   markers <- lapply(l$data, "[[", "marker")
   colz <- unlist(lapply(markers, "[[", "color"))
   idx <- if (packageVersion("scales") > '1.0.0') c(1, 2, 3) else c(1, 5, 9)
   expect_identical(sort(colsToCompare[idx]), sort(colz))
   # providing vector of RGB codes should also work
-  p <- plot_ly(palmerpenguins::penguins, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species, 
+  p <- plot_ly(d, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~species, 
                colors = cols[1:3])
   l <- expect_traces(p, 3, "scatterplot-color-factor-custom2")
   markers <- lapply(l$data, "[[", "marker")
@@ -51,7 +55,9 @@ test_that("Passing hex codes to colors argument works", {
 })
 
 test_that("Mapping a numeric variable to color works", {
-  p <- plot_ly(palmerpenguins::penguins, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~bill_depth_mm)
+  d <- palmerpenguins::penguins %>% 
+    filter(!is.na(bill_length_mm))
+  p <- plot_ly(d, x = ~bill_length_mm, y = ~flipper_length_mm, color = ~bill_depth_mm)
   # one trace is for the colorbar
   l <- expect_traces(p, 2, "scatterplot-color-numeric")
   idx <- vapply(l$data, is.colorbar, logical(1))
@@ -76,14 +82,18 @@ test_that("color/stroke mapping with box translates correctly", {
 })
 
 test_that("Custom RColorBrewer pallette works for numeric variable", {
-  p <- plot_ly(palmerpenguins::penguins, x = ~bill_length_mm, y = ~flipper_length_mm, 
+  d <- palmerpenguins::penguins %>% 
+    filter(!is.na(bill_length_mm))
+  p <- plot_ly(d, x = ~bill_length_mm, y = ~flipper_length_mm, 
                color = ~bill_depth_mm, colors = "Greens")
   # one trace is for the colorbar
   l <- expect_traces(p, 2, "scatterplot-color-numeric-custom")
 })
 
 test_that("axis titles get attached to scene object for 3D plots", {
-  p <- plot_ly(palmerpenguins::penguins, x = ~bill_length_mm, y = ~bill_depth_mm, z = ~flipper_length_mm)
+  d <- palmerpenguins::penguins %>% 
+    filter(!is.na(bill_length_mm))
+  p <- plot_ly(d, x = ~bill_length_mm, y = ~bill_depth_mm, z = ~flipper_length_mm)
   l <- expect_traces(p, 1, "scatterplot-scatter3d-axes")
   expect_identical(l$data[[1]]$type, "scatter3d")
   scene <- l$layout$scene

tests/testthat/test-ggplot-date.R

@@ -121,12 +121,12 @@ test_that("positioning with multiple colorbars and legends", {
 
   s <- subplot(
     plot_ly(z = ~volcano),
-    plot_ly(x = 1:10, y = 1:10, color = factor(1:10))
+    plot_ly(x = 1:8, y = 1:8, color = factor(1:8))
   )
 
   b <- plotly_build(s)
   d <- b$x$data
-  expect_length(d, 11)
+  expect_length(d, 9)
 
   expect_true(d[[1]]$colorbar$len == 0.5)
   expect_true(d[[1]]$colorbar$lenmode == "fraction")

tests/testthat/test-ggplot-dynamicTicks.R

@@ -57,8 +57,11 @@ test_that("Trace ordering matches factor levels", {
 })
 
 test_that("Trace ordering is alphabetical", {
-  lvls <- sort(unique(mpg$class))
-  p <- plot_ly(mpg, x = ~cty, y = ~hwy, linetype = ~class) %>% add_lines()
+  #keep only 6 categories (to avoid warning)
+  mpg2 <- mpg %>% dplyr::filter(class %in% c("compact", "midsize", "suv", "2seater", "pickup", "subcompact"))
+  
+  lvls <- sort(unique(mpg2$class))
+  p <- plot_ly(mpg2, x = ~cty, y = ~hwy, linetype = ~class) %>% add_lines()
   l <- expect_traces(p, length(lvls), "alphabetical")
   expect_equivalent(sapply(l$data, "[[", "name"), lvls)
 })

tests/testthat/test-ggplot-ticks.R

@@ -48,3 +48,34 @@ test_that("doesn't break old behavior", {
   expect_equal(l$x$data[[1]]$name, "Fair cut")
   expect_equal(l$x$data[[2]]$name, "Ideal cut")
 })
+
+
+test_that("adding trace name with frame does not throw frameOrder warning", {
+  
+  dt <- data.frame(source = rep(c(rep("TEL", 2) , rep("WEB", 2), rep("OTH",2)),2), 
+                   period = rep(c("AM", "PM"), 6), 
+                   y_val = runif(12), 
+                   year = c(rep(2020,6), rep(2021,6)))
+  
+  
+  p1 <- plot_ly()
+  
+  for (yr in unique(dt$year)){
+    
+    which_lines <- which(dt$year==yr)
+    
+    p1 <- add_trace(p1, 
+                    x = dt$period[which_lines], 
+                    y = dt$y_val[which_lines], 
+                    frame = dt$source[which_lines],
+                    type = "scatter", mode = "lines+markers", 
+                    name = yr)
+  }
+  
+  expect_warning(l <- plotly_build(p1), NA) 
+  
+  expect_equal(l$x$data[[1]]$name, 2020)
+  expect_equal(l$x$data[[2]]$name, 2021)
+  
+  
+})

tests/testthat/test-plotly-color.R

@@ -34,7 +34,8 @@ test_that("plot_geo() lat/lon range is set", {
   skip_if_not_installed("sf")
 
   nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
-  p <- plotly_build(plot_geo(nc))
+  expect_warning(p <- plotly_build(plot_geo(nc)), 
+                 regexp = "Attempting transformation to the target coordinate system")
   expect_equal(
     p$x$layout$geo$lataxis$range, 
     c(33.85492, 36.61673), 
@@ -86,7 +87,8 @@ test_that("Can plot sfc with a missing crs", {
   skip_if_not_installed("sf")
 
   storms <- sf::st_read(system.file("shape/storms_xyz.shp", package = "sf"), quiet = TRUE)
-  p <- plotly_build(plot_geo(storms, name = "Storms"))
+  expect_warning(p <- plotly_build(plot_geo(storms, name = "Storms")), 
+                 regexp = "Missing coordinate reference system")
   expect_true(p$x$data[[1]]$type == "scattergeo")
   expect_true(p$x$data[[1]]$mode == "lines")
 })