R/gl.map.interactive.r

In dartR.base: Analysing 'SNP' and 'Silicodart' Data - Basic Functions

#' @name gl.map.interactive
#' @title Creates an interactive map (based on latlon) from a genlight object
#' @family graphics

#' @param x A genlight object (including coordinates within the latlon slot) 
#' [required].
#' @param matrix A distance matrix between populations or individuals. The
#' matrix is visualised as lines between individuals/populations. If matrix is
#' asymmetric two lines with arrows are plotted [default NULL].
#' @param standard If a matrix is provided line width will be standardised to be
#' between 1 to 10, if set to true, otherwise taken as given [default TRUE].
#' @param symmetric If a symmetric matrix is provided only one line is drawn
#' based on the lower triangle of the matrix. If set to false arrows indicating
#' the direction are used instead [default TRUE].
#' @param pop.labels Population labels at the center of the individuals of
#'  populations [default TRUE].
#' @param pop.labels.cex Size of population labels [default 12].
#' @param ind.circles Should individuals plotted as circles [default TRUE].
#' @param ind.circle.cols Colors of circles. A color palette or a vectot with
#' as many colors as there are populations in the dataset [default rainbow].
#' @param ind.circle.cex Size or circles in pixels [default 10].
#' @param ind.circle.transparency Transparency of circles between 0=invisible 
#' and 1=no transparency. Defaults to 0.8.
#' @param palette.links Color palette for the links in case a matrix is provided
#'  [default NULL].
#' @param legend.title Legend's title for the links in case a matrix is provided
#'  [default NULL].
#' @param provider Passed to leaflet [default "Esri.NatGeoWorldMap"].
#' @param raster.image Path to a georeferenced raster image to plot 
#' [default NULL].
#' @param raster.opacity The opacity of the raster, expressed from 0 to 1 
#' [default 0.5].
#' @param raster.colors The color palette to use to color the raster values
#'  [default scales::viridis_pal(option = "D")(255)].
#' @param verbose Verbosity: 0, silent or fatal errors; 1, begin and end; 2,
#' progress log; 3, progress and results summary; 5, full report
#' [default 2, unless specified using gl.set.verbosity].
#' 
#' @details 
#' A wrapper around the \pkg{leaflet} package. For possible background 
#' maps check as specified via the provider:
#' \url{http://leaflet-extras.github.io/leaflet-providers/preview/index.html}
#' 
#' The palette.links argument can be any of the following:
#' A character vector of RGB or named colors. Examples: palette(), 
#' c("#000000", "#0000FF", "#FFFFFF"), topo.colors(10)
#' 
#' The name of an RColorBrewer palette, e.g. "BuPu" or "Greens".
#' 
#' The full name of a viridis palette: "viridis", "magma", "inferno", 
#' or "plasma".
#' 
#' A function that receives a single value between 0 and 1 and returns a color.
#'  Examples: colorRamp(c("#000000", "#FFFFFF"), interpolate = "spline").

#' @author Bernd Gruber -- Post to \url{https://groups.google.com/d/forum/dartr}
#' 
#' @examples
#' require("dartR.data")
#' gl.map.interactive(bandicoot.gl)
#' cols <- c("red","blue","yellow")
#' gl.map.interactive(platypus.gl, ind.circle.cols=cols, ind.circle.cex=10, 
#' ind.circle.transparency=0.5)
#' 
#' @importFrom methods is
#' @importFrom raster raster
#' @export
#' @return plots a map

gl.map.interactive <- function(x,
                               matrix = NULL,
                               standard = TRUE,
                               symmetric = TRUE,
                               pop.labels = TRUE,
                               pop.labels.cex = 12,
                               ind.circles = TRUE,
                               ind.circle.cols = rainbow,
                               ind.circle.cex = 10,
                               ind.circle.transparency = 0.8,        
                               palette.links = NULL,
                               legend.title = NULL,
                               provider = "Esri.NatGeoWorldMap",
                               raster.image = NULL,
                               raster.opacity = 0.5,
                               raster.colors = scales::viridis_pal(option = "D")(255),
                               verbose = NULL) {
    
    # SET VERBOSITY
    verbose <- gl.check.verbosity(verbose)
    
    # FLAG SCRIPT START
    funname <- match.call()[[1]]
    utils.flag.start(func = funname,
                     build = "v.2023.2",
                     verbose = verbose)
    
    # CHECK DATATYPE
    datatype <- utils.check.datatype(x, verbose = verbose)
    
    # FUNCTION SPECIFIC ERROR CHECKING
    
    # CHECK IF PACKAGES ARE INSTALLED
    pkg <- "leaflet"
    if (!(requireNamespace(pkg, quietly = TRUE))) {
      cat(error(
        "Package",
        pkg,
        " needed for this function to work. Please install it.\n"
      ))
      return(-1)
    }
    
    pkg <- "leaflet.minicharts"
    if (!(requireNamespace(pkg, quietly = TRUE))) {
      cat(error(
        "Package",
        pkg,
        " needed for this function to work. Please install it.\n"
      ))
      return(-1)
    } else {
       
        if (is.null(x@other$latlon)) {
            stop(error(
                "No valid coordinates are supplied at gl@other$latlon"
            ))
        }
        
        if (sum(colnames(x@other$latlon) %in% c("lat", "lon")) != 2) {
            stop(error(
 "Coordinates under gl@other$latlon are not named 'lat' and 'lon'."
            ))
        }
        
        if (!is.null(matrix)) {
            if (nrow(matrix) != nInd(x) & nrow(matrix) != nPop(x)) {
                stop(
                    error(
"The dimension of the provided matrix does neither match the number of 
individuals nor the number of populations."
                    )
                )
            }
        }
        
      # if pop colors is a palette
      if (is(ind.circle.cols, "function")) {
        cols <- ind.circle.cols(length(levels(pop(x))))
      }
      # if pop colors is a vector
      if (!is(ind.circle.cols, "function")) {
        cols <- ind.circle.cols
      }
      ic <- cols[as.numeric(pop(x))]
        # if (is.null(ind.circle.cols)){
        #     cols <- rainbow(nPop(x))
        #     cols <- substr(cols, 1, 7)
        #     ic <- cols[as.numeric(pop(x))]
        # } else{
        #   ic <- ind.circle.cols
        # }
        
        df <- x@other$latlon
        centers <-
            apply(df, 2, function(xx)
                tapply(xx, pop(x), mean, na.rm = TRUE))
        # when there is just one population the output of centers is a vector 
        #the following lines fix this error
        if (nPop(x) == 1) {
            centers <- data.frame(lon = centers[1], lat = centers[2])
            row.names(centers) <- popNames(x)
        }
        # Add default OpenStreetMap map tiles
        m <- leaflet::leaflet() %>%
            leaflet::addTiles()
        
        if (ind.circles) {
            m <- m %>%
                leaflet::addCircles(
                    lng = df$lon,
                    lat = df$lat,
                    popup = indNames(x),
                    color = ic,
                    opacity = ind.circle.transparency,
                    weight = ind.circle.cex
                    
                )
        }
        
        if (pop.labels) {
            m <- m %>%
                leaflet::addLabelOnlyMarkers(
                    lng = centers[, "lon"],
                    lat = centers[, "lat"],
                    label = popNames(x),
                    labelOptions = leaflet::labelOptions(
                        noHide = TRUE,
                        direction = "top",
                        textOnly = TRUE,
                        textsize = paste0(pop.labels.cex, "px")
                    )
                )
        }
        
        if (!is.null(matrix)) {
          
          if (nrow(matrix) == nPop(x)) {
            matrix <- matrix
          } else {
            matrix <- matrix[order(indNames(x)),]
          }
          
            # standardize
            if (standard) {
                matrix[, ] <-
                    ((matrix[, ] - min(matrix, na.rm = TRUE)) / 
                       (max(matrix, na.rm = TRUE) - 
                          min(matrix, na.rm = TRUE))) * 9 + 1
            }
            
            if (nrow(matrix) == nPop(x)) {
                xys <- centers
            } else {
                xys <- df
            }
          
          if(is.null(palette.links)){
            palette.links <- 
          gl.colors("div")(length(unique(unlist(unname(as.vector(matrix))))))
          }
            
          qpal <- leaflet::colorNumeric(
            palette = palette.links,
            domain = unique(unlist(unname(as.vector(matrix)))))
          
            if (symmetric) {
                for (ii in 1:nrow(matrix)) {
                    for (i in ii:nrow(matrix)) {
                        if (!is.null(matrix[i, ii]) | !is.na(matrix[i, ii]) & 
                            matrix[i, ii] > 0 ){
                            m <- m %>%
                                leaflet::addPolylines(
                                    lng = c(xys[i, "lon"], xys[ii, "lon"]),
                                    lat = c(xys[i, "lat"], xys[ii, "lat"]),
                                    color = qpal(matrix[i,ii]),
                                    opacity = 1
                                )
                        }else{
                          next()
                        }
                    }
                }
              m <- m %>% leaflet::addLegend(
                pal = qpal, 
                values = unique(unlist(unname(as.vector(matrix)))), 
                group = "addPolylines", 
                position = "bottomleft",
                title = legend.title) 
       
            }
            
            if (!symmetric) {
                for (i in 1:nrow(matrix)) {
                    for (ii in 1:nrow(matrix)) {
                        if (abs((i - ii)) != 0) {
                            from <- xys[i, ]
                            to <- xys[ii, ]
                            if (!is.null(matrix[i, ii]) &
                                !is.null(matrix[ii, i])) {
                                if (matrix[i, ii] > matrix[ii, i]){
                                    lcols <-"#FFAA00"
                                }else{
                                    lcols <-"#00AAFF"
                                }
                                if (matrix[i, ii] == matrix[ii, i]){
                                    lcols <-"#00AA00"
                                }
                            } else{
                                lcols <-"#333333"
                            }
                            m <- m %>%
                                leaflet.minicharts::addFlows(
                                    lng0 = as.numeric(from["lon"]),
                                    lng1 = as.numeric(to["lon"]),
                                    lat0 = as.numeric(from["lat"]),
                                    lat1 = as.numeric(to["lat"]),
                                    flow = matrix[i, ii],
                                    color = lcols,
                                    maxThickness = 10,
                                    minThickness = 0,
                                    maxFlow = max(matrix,
                                                  na.rm = T),
                                    opacity = 0.8
                                )
                        }
                    }
                }
            }
        }
        
        # FLAG SCRIPT END
        
        if (verbose >= 1) {
            cat(report("Completed:", funname, "\n"))
        }
        
        # RETURN
        
        plot.map <- m %>% leaflet::addProviderTiles(provider)
        if(!is.null(raster.image)){
          # if(is.null(raster.colors)){
          #   raster.colors <- scales::viridis_pal(option = "D")(255)
          # }
          
          r <- raster::raster(raster.image)
          plot.map <- plot.map  %>% 
            leaflet::addRasterImage(r, 
                                    opacity = raster.opacity,
                                    colors = raster.colors)
          
        } 
        
        return(plot.map)
        
    }
}