R/plotly2DHeatmap.R

In kerschke/moPLOT: Visualizing Multi-Objective Optimization Problems

#' @export
plotly2DHeatmap = function(grid, fn, mode = "decision.space", impute.zero = TRUE, colorscale = plotlyColorscale(), log.scale = TRUE) {
  # grid: list of obj.space, dims, dec.space, step.sizes
  # fn: smoof function, 2 dimensional decision space
  
  n = smoof::getNumberOfObjectives(fn)
  lower = smoof::getLowerBoxConstraints(fn)
  upper = smoof::getUpperBoxConstraints(fn)
  
  if (impute.zero) {
    grid$height = imputeZero(grid$height)
  }
  
  if (!log.scale) {
    grid$height = exp(grid$height)
  }
  
  x = cbind.data.frame(grid$dec.space, grid$height, grid$obj.space)
  x = x[order(x$height, decreasing=T),] # relevant for obj.space
  
  if (n == 3) {
    objective.scene = list(
      aspectmode='cube',
      xaxis = list(range = c(min(x[,'y1']),max(x[,'y1'])), title='y<sub>1</sub>'),
      yaxis = list(range = c(min(x[,'y2']),max(x[,'y2'])), title='y<sub>2</sub>'),
      zaxis = list(range = c(min(x[,'y3']),max(x[,'y3'])), title='y<sub>3</sub>')
    )
  }
  
  marker = plotlyMarker(grid$height, colorscale = colorscale)
  
  if (mode == "both") {
    x.shared = highlight_key(x)
    p.decision = plotly2DHeatmapDecisionSpace(x.shared, fn, colorscale)
    p.objective = plotly2DHeatmapObjectiveSpace(x.shared, fn, marker, scene="scene")
    
    domain.left = list(
      x=c(0,0.5),
      y=c(0,1)
    )
    decision.scene = list(domain=domain.left)
    
    domain.right = list(
      x=c(0.5,1),
      y=c(0,1)
    )
    if (n == 3) {
      objective.scene$domain = domain.right
    } else {
      objective.scene = list(domain=domain.right)
    }
    
    subplot(p.decision, p.objective) %>% layout(
      scene = objective.scene
    ) %>% highlight(
      on="plotly_click",
      off="plotly_deselect",
      opacityDim = 0.5,
      color = "red"
    ) %>% hide_guides()
  } else if (mode == "decision.space") {
    plotly2DHeatmapDecisionSpace(x, fn, colorscale) %>%
      hide_guides()
  } else if (mode == "objective.space") {
    if (n == 3) {
      plotly2DHeatmapObjectiveSpace(x, fn, marker) %>% layout(
        scene = objective.scene
      )
    } else {
      plotly2DHeatmapObjectiveSpace(x, fn, marker)
    }
  }
  
}

plotly2DHeatmapObjectiveSpace = function(x, fn, marker.style, scene="scene") {
  n = smoof::getNumberOfObjectives(fn)
  
  if (n == 2) {
    plot_ly(data = x,
            type="scattergl",
            x=~y1,y=~y2,
            mode = "markers",
            marker = marker.style
    ) %>% layout(
      xaxis = list(
        title = "y<sub>1</sub>",
        constrain = "domain"
      ),
      yaxis = list(
        title = "y<sub>2</sub>",
        constrain = "domain"
      )
    )
  } else if (n == 3) {
    plot_ly(data = x,
            type="scatter3d",
            x=~y1,y=~y2,z=~y3,
            scene = scene,
            mode = "markers",
            marker = marker.style
    )
  }
}

plotly2DHeatmapDecisionSpace = function(x, fn, colorscale) {
  plot_ly(data = x,
          type="heatmap",
          x=~x1,y=~x2,z=~log(height),
          colorscale=colorscale
  ) %>% layout(
    xaxis = list(
      title = "x<sub>1</sub>",
      constrain = "domain"
    ),
    yaxis = list(
      scaleanchor = "x",
      scaleratio = (max(x$x1) - min(x$x1)) / (max(x$x2) - min(x$x2)),
      title = "x<sub>2</sub>",
      constrain = "domain"
    )
  )
}