using the new color option in version 1.0.0

[tanerumit]

Hi,

I see that the new color option is easier to use:

parcoords(
mtcars
, color = list(
colorBy = "cyl"
, colorScale = "scaleOrdinal"
, colorScheme = "schemeCategory10"
)
, withD3 = TRUE
)

However, it is somewhat less flexible. As in the example below, how can I define custom bins and assign custom colors to each bin?

diamonds[sample(1:nrow(diamonds),1000),] %>%
select( carat, color, cut, clarity, depth, table, price, x, y, z) %>%
parcoords(
rownames = F # turn off rownames from the data.frame
, brushMode = "2D-strums"
, reorderable = T
, queue = T
, color = list(
colorBy = "carat"
,colorScale = htmlwidgets::JS(sprintf('
d3.scale.threshold()
.domain(%s)
.range(%s)
'
,jsonlite::toJSON(seq(0,round(max(diamonds$carat))))
,jsonlite::toJSON(RColorBrewer::brewer.pal(6,"PuBuGn"))
))
)
)

[timelyportfolio]

@tanerumit thanks for the question. I have struggled with the color argument for the life of this widget. We have a couple of options. Note, parcoords uses d3v5 so we'll need scaleThreshold. scale.threshold() was in earlier versions of d3.

Ideally, if I had supported scaleThreshold we would be able to do something like this, but unfortunately domain is only supported for scaleSequential as of now.

doesn't work right now

library(parcoords)
library(dplyr)

data("diamonds", package="ggplot2")

diamonds[sample(1:nrow(diamonds),5000),] %>%
  select( carat, color, cut, clarity, depth, table, price, x, y, z) %>%
  parcoords(
    rownames = F # turn off rownames from the data.frame
    , brushMode = "2D-strums"
    , reorderable = T
    , queue = T
    , color = list(
      colorBy = "carat"
      , colorScale = "scaleThreshold"
      , colorDomain = seq(0,round(max(diamonds$carat)))
      , colorScheme = RColorBrewer::brewer.pal(6,"PuBuGn")
    )
    , withD3 = TRUE
  )

So, the only option we have is to apply the color in R and then use a hidden axis for parallel coordinates. I found another small bug in 2d-* brush modes so this will only work with 1d.

sort of works

library(parcoords)
library(dplyr)

data("diamonds", package="ggplot2")

diamonds[sample(1:nrow(diamonds),5000),] %>%
  mutate(carat_color = floor(carat)) %>%
  select( carat, color, cut, clarity, depth, table, price, x, y, z, carat_color) %>%
  parcoords(
    rownames = F, # turn off rownames from the data.frame
    brushMode = "1d",
    reorderable = TRUE,
    queue = TRUE,
    color = list(
      colorBy = "carat_color",
      colorScheme = RColorBrewer::brewer.pal(6,"PuBuGn")
    ),
    withD3 = TRUE,
    tasks = list(htmlwidgets::JS("
      function() {
        HTMLWidgets.parcoordsWidget.methods.hide.call(this.parcoords, ['names','carat_color'])
      }
    "))
  )

Looks like I have some work to do. Hopefully, this will be ok for now and sorry for the trouble.

[tanerumit]

Thanks @timelyportfolio! That works well for the moment. Looking forward for the revised version!

[tanerumit]

@timelyportfolio based on your solution, here is a related problem.

The below code takes diamonds data.frame and assigns blue or red color to parcoords data based on the selected variable (input$color.var) and a threshold value (input$pthreshold).

This works fine, but if we use crosstalk to for dynamically linking to a datatable, it fails. Any ideas?

library(parcoords)
library(dplyr)
library(tidyr)
library(DT)
library(crosstalk)

#### UI-SIDE -------------------------------------------------------------------


ui <- fluidPage(
    column(3,
           inputPanel(
             uiOutput('color.varUI'),
             uiOutput('pthresholdUI')
           )
    ),
    column(9,
           parcoordsOutput("pc"),
           dataTableOutput("mytable1")
           
    )
) 

#### SERVER-SIDE ---------------------------------------------------------------


server <- function(input, output, session) {
  
  data <- ggplot2::diamonds %>% slice(1:1000) %>% select(carat, depth, table, price)

  output$color.varUI  = renderUI({
    
    selectizeInput(
      inputId  = "color.var",
      label    = "Variable",
      choices  = colnames(data),   #colnames(parcoordsData()),
      selected = colnames(data)[1],   #colnames(parcoordsData())[1],
      multiple = FALSE
    )
    
  })
  
  parcoordsDf <- reactive({
    
    req(input$color.var)
    req(input$pthreshold)
    
    data$bin_color <- ifelse(data %>% pull(input$color.var) > input$pthreshold, 1, 0)
    data

    
  })
  
  sharedDf <- SharedData$new(parcoordsDf)
  
  output$mytable1 <- DT::renderDataTable({

    req(parcoordsDf())

    sharedDf$data(withSelection = TRUE) %>%
      filter(selected_ | is.na(selected_)) %>%
      mutate(selected_ = NULL) %>%
      datatable()

  })
  
  output$pthresholdUI = renderUI({
    
    req(input$color.var)
    
    sliderInput(inputId = "pthreshold",
                label = "Threshold",
                ticks = FALSE,
                step  = NULL, #this needs to be fixed
                min   = data %>% pull(input$color.var) %>% min()  %>% round(),
                max   = data %>% pull(input$color.var) %>% max()  %>% round(),
                value = data %>% pull(input$color.var) %>% mean() %>% round(),
                round = 0,
    )
    
  })
  
 
  output$pc <- renderParcoords({

    
    parcoords(
      data     = sharedDf,
      rownames = FALSE,
      color = list(
       colorBy = "bin_color",
       colorScheme = c("blue", "red")
      ),
      tasks = list(htmlwidgets::JS("
         function() {
           HTMLWidgets.parcoordsWidget.methods.hide.call(this.parcoords, ['names','bin_color'])
         }
      ")),
      brushMode = "1d",
      brushPredicate = "and",
      alphaOnBrushed = 0.3,
      reorderable = TRUE,
      axisDots = TRUE,
      bundleDimension = NULL,
      bundlingStrength = 0,
      withD3 = TRUE,
      width = NULL,
      height = 500
    )
  })

}

shinyApp(ui = ui, server = server)

[tanerumit]

Actually, I think the problem is the new color argument doesn't work well with crosstalk (SharedData objects).