rplotlyr-leaflet

How to have iframe popups in leaflet for multiple groups?


I have a leaflet map with multiple data sources (ie different group arguments) and I want popup with plotly graphs to open when clicking on markers. I use leafpop:::addPopupIframes, saving widgets locally in temporary files. It works fine to assign popups to a single groups, but when I try multiple groups, only one of them is linked with popups. Here's a reprex of the issue:

library(leaflet)
library(leafpop)
library(plotly)
library(htmlwidgets)

df1=data.frame(Name="Site1", Lon=0, Lat=0)
df2=data.frame(Name="Site2", Lon=1, Lat=2)

p1 = plot_ly(data=data.frame(x=1:10, y=rnorm(10)), x=~x, y=~y) 
p2 = plot_ly(data=data.frame(x=1:10, y=rnorm(10)), x=~x, y=~y) 

fl1 = tempfile(fileext = ".html")
saveWidget(p1, file = fl1)

fl2 = tempfile(fileext = ".html")
saveWidget(p2, file = fl2)

leaflet() %>% 
  addTiles() %>%
  addMarkers(df1$Lon, df1$Lat, group="3") %>%
  leafpop:::addPopupIframes(source = fl1, group = "3") %>%
  addMarkers(df2$Lon, df2$Lat, group="2") %>%
  leafpop:::addPopupIframes(source = fl2, group = "2")

Solution

  • leafpop:::addPopupIframes seems to be completely bugged. The main issue here is that the iframe dependency gets attached twice to the map, this gets resolved and hence you only see one iframe (because the other one is dropped). If your map is called m, one can see it using:

    > length(m$dependencies)
    [1] 10
    > length(htmltools::resolveDependencies(m$dependencies)) 
    [1] 9
    

    There is a logic in addPopupIframes for preventing this, but it does not apply because of a typo:

    src_dep_id = grep("ifrme", map$dependencies) # "a" is missing
    

    But even if this gets corrected, it still does not work. The reason is that each iframe gets saved in its own temporary directory (using leafpop:::createTempFolder twice), but it seems to be necessary to store them in one directory. The solution for this issue is to define the directory previously, and pass it to each call of a custom function:

    customAddPopUpIFrames

    customAddPopUpIFrames <- function (map, source, group, width = 300, height = 300, drs) 
    {
      srcs = lapply(1:length(source), function(i) {
        fl = source[[i]]
        if (file.exists(fl)) {
          src = "l"
          width = width
          height = height
          nm = basename(fl)
          fls = file.path(drs, nm)
          invisible(file.copy(fl, file.path(drs, nm)))
          from_dir = paste0(tools::file_path_sans_ext(fl), 
                            "_files")
          if (dir.exists(from_dir)) {
            invisible(file.copy(from = from_dir, to = drs, 
                                recursive = TRUE))
          }
        }
        else {
          src = "r"
          nm = fl
          width = width
          height = height
        }
        return(list(nm = nm, width = width, height = height, 
                    src = src))
      })
      nms = lapply(srcs, "[[", "nm")
      names(nms) = basename(tools::file_path_sans_ext(source))
      name = names(nms)
      local_sources = nms[file.exists(unlist(source))]
      width = lapply(srcs, "[[", "width")
      height = lapply(srcs, "[[", "height")
      src = lapply(srcs, "[[", "src")
      map$dependencies <- c(map$dependencies, list(htmltools::htmlDependency("popup", 
                                                                             "0.0.1", system.file("htmlwidgets", package = "leafpop"), 
                                                                             script = c("popup.js"))), list(htmltools::htmlDependency("iframe", 
                                                                                                                                      "0.0.1", drs, attachment = local_sources)))
      src_dep_id = grep("iframe", map$dependencies)
      src_dep_ln = lengths(sapply(map$dependencies[src_dep_id], 
                                  "[[", "attachment"))
      src_dep_id = src_dep_id[src_dep_ln > 0]
      src_dep_id = src_dep_id[!is.na(src_dep_id)]
      if (length(src_dep_id) > 1) {
        map$dependencies[[src_dep_id[1]]] = utils::modifyList(map$dependencies[[src_dep_id[1]]], 
                                                              map$dependencies[[src_dep_id[2]]], keep.null = TRUE)
        map$dependencies[[src_dep_id[2]]] = map$dependencies[[src_dep_id[1]]]
      }
      map$dependencies = map$dependencies[!duplicated(map$dependencies)]
      leaflet::invokeMethod(map, leaflet::getMapData(map), "iframePopup", 
                            unname(nms), group, width, height, src, as.list(name))
    }
    

    And then the custom function can be used like this and it works:

    library(leaflet)
    library(leafpop)
    library(plotly)
    library(htmlwidgets)
    
    df1=data.frame(Name="Site1", Lon=0, Lat=0)
    df2=data.frame(Name="Site2", Lon=1, Lat=2)
    
    set.seed(42)
    
    p1 = plot_ly(data=data.frame(x=1:10, y=rnorm(10)), x=~x, y=~y) 
    p2 = plot_ly(data=data.frame(x=1:10, y=rnorm(10)), x=~x, y=~y) 
    
    fl1 = tempfile(fileext = ".html")
    saveWidget(p1, file = fl1)
    
    fl2 = tempfile(fileext = ".html")
    saveWidget(p2, file = fl2)
    
    drs = leafpop:::createTempFolder("iframes")
    
    leaflet() %>% 
      addTiles() %>%
      addMarkers(df1$Lon, df1$Lat, group="3") %>%
      customAddPopUpIFrames(source = fl1, group = "3", drs = drs) %>%
      addMarkers(df2$Lon, df2$Lat, group="2") %>%
      customAddPopUpIFrames(source = fl2, group = "2", drs = drs)
    

    enter image description here

    enter image description here