Unable to zoom or hover map using nested subplot()

Question

My interactive dashboard where multiple Plotly objects including maps are displayed using nested subplot() in R:

library(digest)
library(sf)
library(jsonlite)
library(plotly)
library(ggplot2)
library(tidyr)
library(dplyr)
library(tibble)

sa_final_dataset <- read.csv("state_data.csv")
final_dataset <- read.csv("nation_data.csv")
australia_data <- read_sf("australia_map.shp")
pivot_data <- read.csv("pivot_data.csv")

sa_map_data <- subset(australia_data, STE_NAME21 == "South Australia")

# Interpolate and split into line segments
  interpolate_segments_as_lines <- function(df, steps = 50) {
    df %>%
      rowwise() %>%
      do({
        x_vals <- seq(.$fromX, .$X, length.out = steps)
        y_vals <- seq(.$fromY, .$Y, length.out = steps)
        position <- seq(0, 1, length.out = steps)

        # Construct segments
        data.frame(
          x = head(x_vals, -1),
          y = head(y_vals, -1),
          xend = tail(x_vals, -1),
          yend = tail(y_vals, -1),
          position = head(position, -1),
          FROM_NAME = .$FROM_NAME,
          TO_NAME = .$TO_NAME,
          TOTAL = .$TOTAL,
          AGE_15_34 = .$AGE_15_34,
          AGE_35_49 = .$AGE_35_49,
          AGE_50_65 = .$AGE_50_65,
          AGE_65_PLUS = .$AGE_65_PLUS
        )
      }) %>%
      ungroup()
  }

  # Apply interpolation
  sa_lines_segments <- interpolate_segments_as_lines(sa_final_dataset)

  sa_lines_segments <- sa_lines_segments %>%
    mutate(
      thickness = round(rescale(abs(TOTAL), to = c(3, 10))),
      color = rgb(
        colorRamp(c("#cc0b15ff", "#1cc00dff"))(position),
        maxColorValue = 255
      )
    )

  # Use add_segments with thickness mapped to line width
  sa_plotly <- plot_ly(height = 900, source = "South_Australia_Map") %>%
    add_sf(
    data = sa_map_data,
    fill = "#007499",
    line = list(color = "black"),
    showlegend = FALSE,
    hoverinfo = "skip"
    )

  # Optionally, you can color by direction or other variable if needed
  for (t in sort(unique(sa_lines_segments$thickness))) {
    seg_data <- sa_lines_segments %>% filter(thickness == t )
    for (g in unique(seg_data$color)) {
      seg_data_color <- seg_data %>% filter(color == g)
      if (nrow(seg_data_color) > 0) {
        sa_plotly <- sa_plotly %>%
          add_segments(
            data = seg_data_color,
            x = ~x, y = ~y, xend = ~xend, yend = ~yend,
            line = list(
              color = ~color,
              width = t
            ),
            opacity = 0.8,
            hovertext = paste0(
              "From: ", seg_data_color$FROM_NAME, "<br>",
              "To: ", seg_data_color$TO_NAME, "<br>",
              "Age 15 - 34 Migrations: <b>", seg_data_color$AGE_15_34, "</b><br>",
              "Age 35 - 49 Migrations: <b>", seg_data_color$AGE_35_49, "</b><br>",
              "Age 50 - 65 Migrations: <b>", seg_data_color$AGE_50_65, "</b><br>",
              "Age 66+ Migrations: <b>", seg_data_color$AGE_65_PLUS, "</b><br>",
              "Net Migrations: <b>", seg_data_color$TOTAL, "</b>"
            ),
            hoverinfo = "text",
            showlegend = FALSE,
            inherit = FALSE,
            yaxis="y"
          )
      }
    }
  }

  sa_plotly <- sa_plotly %>%
    layout(
    xaxis = list(title = ""),
    yaxis = list(title = "")
    )

  interpolate_segments_as_lines_inter <- function(df, steps = 50) {
    df %>%
    rowwise() %>%
    do({
      x_vals <- seq(.$fromX, .$X, length.out = steps)
      y_vals <- seq(.$fromY, .$Y, length.out = steps)
      position <- seq(0, 1, length.out = steps)
      data.frame(
      x = head(x_vals, -1),
      y = head(y_vals, -1),
      xend = tail(x_vals, -1),
      yend = tail(y_vals, -1),
      position = head(position, -1),
      group = .$group,
      thickness = .$thickness,
      SA3_NAME21 = .$SA3_NAME21,
      State = .$State,
      FinalValue = .$FinalValue,
      AGE_15_34 = .$AGE_15_34,
      AGE_35_49 = .$AGE_35_49,
      AGE_50_65 = .$AGE_50_65,
      AGE_65_PLUS = .$AGE_65_PLUS
      )
    }) %>%
    ungroup()
  }

  inter_lines_segments <- interpolate_segments_as_lines_inter(final_dataset)

  inter_hovertexts <- paste0(
    "SA3 Name: ", inter_lines_segments$SA3_NAME21, "<br>",
    "Age 15 - 34 Migrations: <b>", inter_lines_segments$AGE_15_34, "</b><br>",
    "Age 35 - 49 Migrations: <b>", inter_lines_segments$AGE_35_49, "</b><br>",
    "Age 50 - 65 Migrations: <b>", inter_lines_segments$AGE_50_65, "</b><br>",
    "Age 66+ Migrations: <b>", inter_lines_segments$AGE_65_PLUS, "</b><br>",
    "State: <b>", inter_lines_segments$State, "</b><br>",
    "Net Value: <b>", inter_lines_segments$FinalValue, "</b>"
  )

  # Build plotly map for inter-state migration
  plotly_gg_map <- plot_ly(height = 900, source = "Australia_Map") %>%
    add_sf(
      data = subset(australia_data, STE_NAME21 != "South Australia"),
      fill = "#007499",
      line = list(color = "black"),
      showlegend = FALSE,
      hoverinfo = "skip"
    ) %>%
    add_sf(
      data = subset(australia_data, STE_NAME21 == "South Australia"),
      fill = "#007499",
      line = list(color = "black"),
      showlegend = FALSE,
      hoverinfo = "skip"
    )

  groups <- c("Outgoing Migration", "Incoming Migration")
  colors <- c("Outgoing Migration" = "#cc0b15ff", "Incoming Migration" = "#1cc00dff")

  # Track if legend has been added for each group
  legend_added <- setNames(rep(FALSE, length(groups)), groups)

  for (g in groups) {
    for (t in sort(unique(inter_lines_segments$thickness))) {
    seg_data <- inter_lines_segments %>%
      filter(group == g, thickness == t)

    if (nrow(seg_data) > 0) {
      seg_hovertexts <- inter_hovertexts[which(inter_lines_segments$group == g & inter_lines_segments$thickness == t)]
      plotly_gg_map <- plotly_gg_map %>%
      add_segments(
        data = seg_data,
        x = ~x, y = ~y, xend = ~xend, yend = ~yend,
        line = list(color = colors[[g]], width = t),
        opacity = 0.7,
        hovertext = seg_hovertexts,
        hoverinfo = "text",
        name = g,
        legendgroup = g,
        showlegend = !legend_added[[g]]
      )
      legend_added[[g]] <- TRUE
    }
    }
  }

  plotly_gg_map <- plotly_gg_map %>%
    layout(
      showlegend = TRUE,
      xaxis = list(title = ""),
      yaxis = list(overlaying="y2"),
      legend = list(title = list(text = ""))
    )

  plotly_combined <- subplot(
    plotly_gg_map,
    sa_plotly,
    nrows = 1
  ) %>%
    layout(
      showlegend = TRUE,
      legend = list(
        orientation = "h",
        x = 0.5,
        y = 0.1,
        xanchor = "center",
        yanchor = "top",
        font = list(size = 12)
      ),
      annotations = list(
        list(
          text = "<b>Inter State Migration Map</b>",
          x = 0.185,
          y = 1.035,
          xref = "paper",
          yref = "paper",
          showarrow = FALSE
        ),
        list(
          text = "<b>Intra State Migration Map</b>",
          x = 0.825,
          y = 1.035,
          xref = "paper",
          yref = "paper",
          showarrow = FALSE
        )
      )
    )

  # Plotly table
  table_plot <- plot_ly(
    source = "Table 1",
    type = "table",
    columnwidth = c(15, 10, 10, 10, 10, 10, 10, 10, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20),
    header = list(
      values = colnames(pivot_data),
      align = "center",
      line = list(color = "#000000ff"),
      font = list(color = list(
        "black",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white",
        "white"
      ), size = 12),
      fill = list(
        color = list(
          c("#ffffffff"),
          c("#6A625E"),
          c("#6A625E"),
          c("#6A625E"),
          c("#6A625E"),
          c("#6A625E"),
          c("#6A625E"),
          c("#6A625E"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333"),
          c("#333333")
        )
      ),
      height = 40
    ),
    cells = list(
      values = rbind(t(as.matrix(unname(pivot_data)))
      ),
      align = "center",
      line = list(color = "#000000ff"),
      fill = list(color = "#ffffffff"),
      font = list(color = "#000000ff", size = 12)
    )
  )

  table_plot2 <- plot_ly(
    type = "table",
    source = "Table 2",
    header = list(
        values = list(
            c("<b>Sources:</b> Demo")
        ),
        align = "left",
        font = list(family = "Arial", size = 12),
        height = 40,
        line = list(color = "rgba(0,0,0,0)") # Remove borders
    ),
    cells = list(
        line = list(color = "rgba(0,0,0,0)") # Remove borders
    ),
    domain = list(
        x = c(0, 1),
        y = c(0, 0.03)
    )
  )

  # Ensure hoverinfo is retained for all subplots by explicitly setting hoverinfo for each axis
  final_combined <- subplot(
    table_plot, plotly_combined, table_plot2,
    nrows = 3,
    heights = c(0.25, 0.7, 0.05),
    shareX = FALSE,
    shareY = FALSE,
    titleX = FALSE,
    titleY = FALSE
  ) %>%
  layout(
    annotations = list(
      list(
        text = "<b>Average Monthly Net Migration</b>",
        x = 0.5,
        y = 1.035,
        xref = "paper",
        yref = "paper",
        showarrow = FALSE,
        font = list(size = 16, color = "#000000")
      )
    )
  )

print(final_combined)

When using subplot() with multiple maps from sf objects I cannot zoom or pan into the maps and hover text does not appear. It works when the map is plotted individually. Files to reproduce the issue. The data has been modified to remove confidential information so please ignore inconsistency or logical mismatches. It's part of a larger architecture where R acts only as the backend, hence I am limited to Plotly, Leaflet and MapView.

Is this a bug in nested subplot() when used with sf objects or map traces? How can I retain map interactivity (zoom, pan, hover) when embedded as part of a nested subplot() layout? I've tried using subplot() with add_sf() and add_trace() and modifying layout options (dragmode, uirevision, and geo anchoring). final_combined should be able to convert it into Plotly JSON using:

plotly_json <- plotly_json(final_combined, jsonedit = FALSE)

lailaps · Accepted Answer · 2025-08-06 06:26:46Z

Subplot has produced loads of bugs in my experience, i.e. this. I would suggest using manipulateWidget::combineWidgets() instead.

library(digest)
library(sf)
library(jsonlite)
library(plotly)
library(ggplot2)
library(tidyr)
library(dplyr)
library(tibble)
library(scales)

sa_final_dataset <- read.csv("state_data.csv")
final_dataset <- read.csv("nation_data.csv")
australia_data <- read_sf("australia_map.shp")
pivot_data <- read.csv("pivot_data.csv")

sa_map_data <- subset(australia_data, STE_NAME21 == "South Australia")

# Interpolate and split into line segments
interpolate_segments_as_lines <- function(df, steps = 50) {
  df %>%
    rowwise() %>%
    do({
      x_vals <- seq(.$fromX, .$X, length.out = steps)
      y_vals <- seq(.$fromY, .$Y, length.out = steps)
      position <- seq(0, 1, length.out = steps)
      
      # Construct segments
      data.frame(
        x = head(x_vals, -1),
        y = head(y_vals, -1),
        xend = tail(x_vals, -1),
        yend = tail(y_vals, -1),
        position = head(position, -1),
        FROM_NAME = .$FROM_NAME,
        TO_NAME = .$TO_NAME,
        TOTAL = .$TOTAL,
        AGE_15_34 = .$AGE_15_34,
        AGE_35_49 = .$AGE_35_49,
        AGE_50_65 = .$AGE_50_65,
        AGE_65_PLUS = .$AGE_65_PLUS
      )
    }) %>%
    ungroup()
}

# Apply interpolation
sa_lines_segments <- interpolate_segments_as_lines(sa_final_dataset)

sa_lines_segments <- sa_lines_segments %>%
  mutate(
    thickness = round(rescale(abs(TOTAL), to = c(3, 10))),
    color = rgb(
      colorRamp(c("#cc0b15ff", "#1cc00dff"))(position),
      maxColorValue = 255
    )
  )

# Use add_segments with thickness mapped to line width
sa_plotly <- plot_ly(height = 900, source = "South_Australia_Map") %>%
  add_sf(
    data = sa_map_data,
    fill = "#007499",
    line = list(color = "black"),
    showlegend = FALSE,
    hoverinfo = "skip"
  )

# Optionally, you can color by direction or other variable if needed
for (t in sort(unique(sa_lines_segments$thickness))) {
  seg_data <- sa_lines_segments %>% filter(thickness == t )
  for (g in unique(seg_data$color)) {
    seg_data_color <- seg_data %>% filter(color == g)
    if (nrow(seg_data_color) > 0) {
      sa_plotly <- sa_plotly %>%
        add_segments(
          data = seg_data_color,
          x = ~x, y = ~y, xend = ~xend, yend = ~yend,
          line = list(
            color = ~color,
            width = t
          ),
          opacity = 0.8,
          hovertext = paste0(
            "From: ", seg_data_color$FROM_NAME, "<br>",
            "To: ", seg_data_color$TO_NAME, "<br>",
            "Age 15 - 34 Migrations: <b>", seg_data_color$AGE_15_34, "</b><br>",
            "Age 35 - 49 Migrations: <b>", seg_data_color$AGE_35_49, "</b><br>",
            "Age 50 - 65 Migrations: <b>", seg_data_color$AGE_50_65, "</b><br>",
            "Age 66+ Migrations: <b>", seg_data_color$AGE_65_PLUS, "</b><br>",
            "Net Migrations: <b>", seg_data_color$TOTAL, "</b>"
          ),
          hoverinfo = "text",
          showlegend = FALSE,
          inherit = FALSE,
          yaxis="y"
        )
    }
  }
}

sa_plotly <- sa_plotly %>%
  layout(
    xaxis = list(title = ""),
    yaxis = list(title = "")
  )

interpolate_segments_as_lines_inter <- function(df, steps = 50) {
  df %>%
    rowwise() %>%
    do({
      x_vals <- seq(.$fromX, .$X, length.out = steps)
      y_vals <- seq(.$fromY, .$Y, length.out = steps)
      position <- seq(0, 1, length.out = steps)
      data.frame(
        x = head(x_vals, -1),
        y = head(y_vals, -1),
        xend = tail(x_vals, -1),
        yend = tail(y_vals, -1),
        position = head(position, -1),
        group = .$group,
        thickness = .$thickness,
        SA3_NAME21 = .$SA3_NAME21,
        State = .$State,
        FinalValue = .$FinalValue,
        AGE_15_34 = .$AGE_15_34,
        AGE_35_49 = .$AGE_35_49,
        AGE_50_65 = .$AGE_50_65,
        AGE_65_PLUS = .$AGE_65_PLUS
      )
    }) %>%
    ungroup()
}

inter_lines_segments <- interpolate_segments_as_lines_inter(final_dataset)

inter_hovertexts <- paste0(
  "SA3 Name: ", inter_lines_segments$SA3_NAME21, "<br>",
  "Age 15 - 34 Migrations: <b>", inter_lines_segments$AGE_15_34, "</b><br>",
  "Age 35 - 49 Migrations: <b>", inter_lines_segments$AGE_35_49, "</b><br>",
  "Age 50 - 65 Migrations: <b>", inter_lines_segments$AGE_50_65, "</b><br>",
  "Age 66+ Migrations: <b>", inter_lines_segments$AGE_65_PLUS, "</b><br>",
  "State: <b>", inter_lines_segments$State, "</b><br>",
  "Net Value: <b>", inter_lines_segments$FinalValue, "</b>"
)

# Build plotly map for inter-state migration
plotly_gg_map <- plot_ly(height = 900, source = "Australia_Map") %>%
  add_sf(
    data = subset(australia_data, STE_NAME21 != "South Australia"),
    fill = "#007499",
    line = list(color = "black"),
    showlegend = FALSE,
    hoverinfo = "skip"
  ) %>%
  add_sf(
    data = subset(australia_data, STE_NAME21 == "South Australia"),
    fill = "#007499",
    line = list(color = "black"),
    showlegend = FALSE,
    hoverinfo = "skip"
  )

groups <- c("Outgoing Migration", "Incoming Migration")
colors <- c("Outgoing Migration" = "#cc0b15ff", "Incoming Migration" = "#1cc00dff")

# Track if legend has been added for each group
legend_added <- setNames(rep(FALSE, length(groups)), groups)

for (g in groups) {
  for (t in sort(unique(inter_lines_segments$thickness))) {
    seg_data <- inter_lines_segments %>%
      filter(group == g, thickness == t)
    
    if (nrow(seg_data) > 0) {
      seg_hovertexts <- inter_hovertexts[which(inter_lines_segments$group == g & inter_lines_segments$thickness == t)]
      plotly_gg_map <- plotly_gg_map %>%
        add_segments(
          data = seg_data,
          x = ~x, y = ~y, xend = ~xend, yend = ~yend,
          line = list(color = colors[[g]], width = t),
          opacity = 0.7,
          hovertext = seg_hovertexts,
          hoverinfo = "text",
          name = g,
          legendgroup = g,
          showlegend = !legend_added[[g]]
        )
      legend_added[[g]] <- TRUE
    }
  }
}

plotly_gg_map <- plotly_gg_map %>%
  layout(
    showlegend = TRUE,
    xaxis = list(title = ""),
    yaxis = list(overlaying="y2"),
    legend = list(title = list(text = ""))
  )

plotly_combined <- subplot(
  plotly_gg_map,
  sa_plotly,
  nrows = 1
) %>%
  layout(
    showlegend = TRUE,
    legend = list(
      orientation = "h",     
      x = 0.5,
      y = 0.1,
      xanchor = "center",
      yanchor = "top",
      font = list(size = 12)
    ),
    annotations = list(
      list(
        text = "<b>Inter State Migration Map</b>",
        x = 0.185,
        y = 1.035,
        xref = "paper",
        yref = "paper",
        showarrow = FALSE
      ),
      list(
        text = "<b>Intra State Migration Map</b>",
        x = 0.825,
        y = 1.035,
        xref = "paper",
        yref = "paper",
        showarrow = FALSE
      )
    )
  )

# Plotly table
table_plot <- plot_ly(
  source = "Table 1",
  type = "table",
  columnwidth = c(15, 10, 10, 10, 10, 10, 10, 10, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20),
  header = list(
    values = colnames(pivot_data),
    align = "center",
    line = list(color = "#000000ff"),
    font = list(color = list(
      "black",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white",
      "white"
    ), size = 12),
    fill = list(
      color = list(
        c("#ffffffff"),
        c("#6A625E"), 
        c("#6A625E"),
        c("#6A625E"),
        c("#6A625E"),
        c("#6A625E"),
        c("#6A625E"),
        c("#6A625E"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333"),
        c("#333333")
      )
    ),
    height = 40
  ),
  cells = list(
    values = rbind(t(as.matrix(unname(pivot_data)))
    ),
    align = "center",
    line = list(color = "#000000ff"),
    fill = list(color = "#ffffffff"),
    font = list(color = "#000000ff", size = 12)
  )
)

manipulateWidget::combineWidgets(
  table_plot,
  plotly_combined,
  htmltools::p(strong('Sources:'), ' Demo'),
  title = "<b>Average Monthly Net Migration</b>",
  nrow = 3,
  rowsize = c(0.25, 0.7, 0.05)
)

Thank you for your response, it does solves my problem temporarily but as I mentioned in the Setup. the final object needs to be a plotly object in order to be converted into json and further sent to the frontend using R Plumber API. The frontend uses plotly.js library to use the json and show the chart to the users. Maybe if you could provide a solution where it does not give error when the final_combined is passed to plotly_json() as - return_plotly_json <- plotly_json(final_combined, jsonedit = FALSE)
I understand, this an additional requirement and important context. Thank you. In this case I would recommend to store the widget created by combineWidgets as HTML, e.g. encode in base64, send to the frontend, and then include it using setInnerHTML.

Collectives™ on Stack Overflow

Unable to zoom or hover map using nested subplot()

1 Answer 1

2 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related