metric.osrm coverage - 73.07%

Files
Source

# @name osrmTableGrpe1
# @title Calcul la durée et/ou la distance entre deux points.
# @description La fonction osrmTableGrpe1 permet de calculer la durée et la distance d'un point 
# vers un groupe de points ou d'un groupe de points vers un point. 
# Chaque groupe est composé d'au moins 1000 points 
# @param couples Un data.frame 7 colonnes "idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID".
# @param duree Un booleen. La fonction retourne la durée. Par défaut à TRUE.
# @param distance Un booleen. La fonction retourne la distance. Par défaut à TRUE.
# @param exclude Une chaine de carctère string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
# @return Un data.frame
# @importFrom shiny withProgress incProgress
# @importFrom progress progress_bar
# @noRd
# @export
# 
osrmTableGrpe1 <-
function(couples, duree, distance, exclude, interactive)
{
  list_res_1n_n1 <- list()
  cpt <- 0

  couples_save <- couples

  cptSrc <- table(couples[,1])
  cptDst <- table(couples[,4])

  while(any(cptSrc[which.max(cptSrc)]>=1000 | cptDst[which.max(cptDst)]>=1000))
  {
    if(cptSrc[which.max(cptSrc)]>=cptDst[which.max(cptDst)])
    {
      id <- names(cptSrc[which.max(cptSrc)])
      couplesMax <- couples[couples[,1] %in% id,]
    }else
    {
      id <- names(cptDst[which.max(cptDst)])
      couplesMax <- couples[couples[,4] %in% id,]
    }

    couples <- couples[-which(couples$ID %in% couplesMax$ID),]

    cptSrc <- table(couples[,1])
    cptDst <- table(couples[,4])

    cpt <- cpt + 1
  }

  cpt <- cpt - 1

  if(cpt > 0)
  {
    couples <- couples_save

    cptSrc <- table(couples[,1])
    cptDst <- table(couples[,4])

    if(interactive)
    {
      shiny::withProgress(message = "Calculs en cours - 1/3 : ",{
        for(i in 1:cpt)
        {
          list_res_1n_n1[[i]] <- calculs_faceaface_groupe1(cptSrc, cptDst, couples, duree, distance, exclude)

          couples <- couples[-which(couples$ID %in% list_res_1n_n1[[i]][,1]),]

          cptSrc <- table(couples[,1])
          cptDst <- table(couples[,4])

          shiny::incProgress(1/cpt)
        }
      })
    }else if(!interactive)
    {
      pb1 <- progress::progress_bar$new(
        format = "Calcul en cours - 1/3 : [:bar] :percent :elapsed",
        total = cpt, clear = FALSE, width= 60
      )

      pb1$tick(0)

      for(i in 1:cpt)
      {
        list_res_1n_n1[[i]] <- calculs_faceaface_groupe1(cptSrc, cptDst, couples, duree, distance, exclude)

        couples <- couples[-which(couples$ID %in% list_res_1n_n1[[i]][,1]),]

        cptSrc <- table(couples[,1])
        cptDst <- table(couples[,4])

        pb1$tick()
      }
    }else
    {
      pb1 <- progress::progress_bar$new(
        format = "Calcul en cours - 1/3 : [:bar] :percent :elapsed",
        total = 2, clear = FALSE, width= 60
      )

      for (i in 1:2) {
        pb1$tick()
        Sys.sleep(0.2)
      }

      res_1g <- NULL
    }

    res_1g <- do.call(rbind,list_res_1n_n1)

  }else
  {
    pb1 <- progress::progress_bar$new(
      format = "Calcul en cours - 1/3 : [:bar] :percent :elapsed",
      total = 2, clear = FALSE, width= 60
    )

    for (i in 1:2) {
      pb1$tick()
      Sys.sleep(0.2)
    }

    res_1g <- NULL
  }

  return(res_1g)
}

#' @name adresseToCoord
#'
#' @title Geolocaliser des adresses et renvoyer leurs coordonnees en WGS84 (EPSG 4326)
#'
#' @description La fonction adresseToCoord permet de récupérer les coordonnées WGS84 (longitude/latitude code epsg 4326) de plusieurs adresses.
#'
#' La fonction utilise l'API Adresses (documentation : https://geo.api.gouv.fr/adresse).
#'
#' @param adresses vecteur texte Adresses à géolocaliser.
#' @param nbEchos valeur numérique. Nombre de résultats maximum par adresse en cas de doute sur la géolocalisation. Par défaut 1.
#' @param codePostal vecteur texte. Par défaut NULL.
#' @param codeInsee vecteur texte. Par défaut NULL.
#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
#'
#' @return Un data.frame
#'
#' @details En plus des coordonnées lon et lat, un score entre 0 et 1 est proposé, indiquant la pertinence de la géolocalisation.
#'
#' Le codePostal et le codeInsee sont des arguments optionnels qui permettent d'améliorer la géolocalisation en cas de doute sur un libellé d'adresse.
#'
#' Le code postal peut aussi être mentionné directement dans les libellés d'adresses.
#'
#' Le nombre d'echos permet à la fonction de retourner jusqu'à n echos si la géolocalisation renvoie plusieurs possibilités. Seuls les échos les plus pertinents sont proposés.
#'
#' @importFrom RJSONIO fromJSON
#' @importFrom shiny withProgress incProgress
#' @importFrom progress progress_bar
#' @export
#'
#' @examples
#' # Exemple 1 : avec une seule adresse
#' adresseToCoord(adresses = "88 avenue Verdier Montrouge",
#'                nbEchos = 1)
#'
#' # Exemple 2 : avec un vecteur d'adresses
#' adresses <- c("1 Rue des Abeilles 13001 Marseille",
#'               "1 Allee des Abeilles 13016 Marseille",
#'               "1 Impasse Abeille 13003 Marseille",
#'               "1 Impasse de la Chapelle 13013 Marseille",
#'               "1 Boulevard de la Chapelle 13009 Marseille",
#'               "1 Boulevard de la Chapelle 13014 Marseille")
#'
#' adresseToCoord(adresses = adresses,
#'                nbEchos = 1) # un resultat par adresse
#'
#' adresseToCoord(adresses = adresses,
#'                nbEchos = 2) # 2 resultats max possibles par adresse
#'
adresseToCoord <- function(adresses, nbEchos = 1, codePostal = NULL, codeInsee = NULL, interactive = FALSE)
{
  msg_error1 <- msg_error2 <- msg_error3 <- msg_error4 <- NULL

  if(!is.character(adresses)) msg_error1 <- "Le parametre adresses doit etre un vecteur caractere / "
  if(!is.numeric(nbEchos)) msg_error2 <- "Le parametre nbEchos doit etre une valeur numerique / "
  if(!is.null(codePostal)) if(!is.character(codePostal)) msg_error3 <- "Le parametre codePostal doit etre un vecteur caractere / "
  if(!is.null(codeInsee)) if(!is.character(codeInsee)) msg_error4 <- "Le parametre codeInsee doit etre un vecteur caractere / "

  if(any(!is.null(msg_error1),!is.null(msg_error2),!is.null(msg_error3),!is.null(msg_error4)))
  {
    stop(simpleError(paste0(msg_error1,msg_error2,msg_error3,msg_error4)))
  }

  options(adresse.server = "https://api-adresse.data.gouv.fr/")

  supprAccent <- function(text) {
    text <- gsub("['`^~\"]", " ", text)
    text <- iconv(text, from = "UTF-8", to = "ASCII//TRANSLIT//IGNORE")
    text <- gsub("['`^~\"]", "", text)
    return(text)
  }

  dt_adresses <- data.frame(ADRESSES=adresses, stringsAsFactors = FALSE)

  # Conversion en UTF-8 uniquement si les libellés d'adresses n'y sont pas déjà
  if(!"UTF-8" %in% Encoding(dt_adresses$ADRESSES)){
    dt_adresses$ADRESSES <- iconv(dt_adresses$ADRESSES, to = "UTF-8")
  }

  # Suppression des accents en entree pour que la fonction RJSONIO::fromjson puisse traiter la requete
  dt_adresses$ADRESSES <- supprAccent(dt_adresses$ADRESSES)

  if(!is.null(codePostal)) dt_codePostal <- data.frame(codePostal=codePostal, stringsAsFactors = FALSE)
  if(!is.null(codeInsee)) dt_codeInsee <- data.frame(codeInsee=codeInsee, stringsAsFactors = FALSE)

  if(!interactive)
  {
    pb <- progress::progress_bar$new(
      format = paste0("G\u00e9olocalisation en cours de ",nrow(dt_adresses)," adresses -  [:bar] :percent :elapsed"),
      total = nrow(dt_adresses), clear = FALSE, width= 80
    )

    pb$tick(0)

    res <- t(lapply(1:nrow(dt_adresses),function(x) {

      pb$tick()

      if(nchar(dt_adresses[x,]) == 0)
      {
        return(data.frame(ADRESSES = dt_adresses[x,],
                          ADRESSES_GEOLOC = "unknown",
                          LON = 0,
                          LAT = 0,
                          SCORE = 0,
                          stringsAsFactors = FALSE))
      }

      if(!is.null(codePostal))
      {
        req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&postcode=",dt_codePostal[x,],"&limit=",nbEchos)
      }else if(!is.null(codeInsee))
      {
        req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&citycode=",dt_codeInsee[x,],"&limit=",nbEchos)
      }else
      {
        req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&limit=",nbEchos)
      }

      # On specifie explicitement que l'encodage en sortie doit etre du latin1, sinon il considere qu'il est unknown meme si implicitement c'est du latin1.
      # Sinon, cela qui peut generer des caracteres non reconnus a l'affichage si la reponse contient des caracteres speciaux.
      # MAJ 2023 - suppression de cette rustine, on précise désormais UTF8 pour RJSONIO
      #a <- RJSONIO::fromJSON(req, encoding = "latin1")
      
      a <- RJSONIO::fromJSON(req, encoding = "UTF-8")
      if(length(a[["features"]])>0)
      {
        res <- lapply(1:length(a[["features"]]),function(y){
                                                data.frame(ADRESSES = dt_adresses[x,],
                                                           ADRESSES_GEOLOC = a[["features"]][[y]][["properties"]][["label"]],
                                                           LON = a[["features"]][[y]][["geometry"]][["coordinates"]][1],
                                                           LAT = a[["features"]][[y]][["geometry"]][["coordinates"]][2],
                                                           SCORE = a[["features"]][[y]][["properties"]][["score"]],
                                                           stringsAsFactors = FALSE)
        })

        res <- do.call("rbind", res)

        # On convertit la sortie latin1 en UTF-8
        #res$ADRESSES_GEOLOC <- iconv(res$ADRESSES_GEOLOC, from = "latin1", to = "UTF-8")

        return(res)
      }else{
        return(data.frame(ADRESSES = dt_adresses[x,],
                          ADRESSES_GEOLOC = "unknown",
                          LON = 0,
                          LAT = 0,
                          SCORE = 0,
                          stringsAsFactors = FALSE))
      }


    }))
  }else
  {
    shiny::withProgress(message = paste0("G\u00e9olocalisation en cours de ",nrow(dt_adresses)," adresses"),{

      res <- t(lapply(1:nrow(dt_adresses),function(x) {

        shiny::incProgress(1/nrow(dt_adresses))

        if(nchar(dt_adresses[x,]) == 0)
        {
          return(data.frame(ADRESSES = dt_adresses[x,],
                            ADRESSES_GEOLOC = "unknown",
                            LON = 0,
                            LAT = 0,
                            SCORE = 0,
                            stringsAsFactors = FALSE))
        }

        if(!is.null(codePostal))
        {
          req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&postcode=",dt_codePostal[x,],"&limit=",nbEchos)
        }else if(!is.null(codeInsee))
        {
          req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&citycode=",dt_codeInsee[x,],"&limit=",nbEchos)
        }else
        {
          req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&limit=",nbEchos)
        }

        # On specifie explicitement que l'encodage en sortie doit etre du latin1, sinon il considere qu'il est unknown meme si implicitement c'est du latin1.
        # Sinon, cela qui peut generer des caracteres non reconnus a l'affichage si la reponse contient des caracteres speciaux.
        # MAJ 2023 - suppression de cette rustine, on précise désormais UTF8 pour RJSONIO
        
        a <- RJSONIO::fromJSON(req, encoding = "UTF-8")

        if(length(a[["features"]])>0)
        {
          res <- lapply(1:length(a[["features"]]),function(y){
            data.frame(ADRESSES = dt_adresses[x,],
                       ADRESSES_GEOLOC = a[["features"]][[y]][["properties"]][["label"]],
                       LON = a[["features"]][[y]][["geometry"]][["coordinates"]][1],
                       LAT = a[["features"]][[y]][["geometry"]][["coordinates"]][2],
                       SCORE = a[["features"]][[y]][["properties"]][["score"]],
                       stringsAsFactors = FALSE)
          })

          res <- do.call("rbind", res)

          # On convertit la sortie latin1 en UTF-8
          #res$ADRESSES_GEOLOC <- iconv(res$ADRESSES_GEOLOC, from = "latin1", to = "UTF-8")

          return(res)
        }else{
          return(data.frame(ADRESSES = dt_adresses[x,],
                            ADRESSES_GEOLOC = "unknown",
                            LON = 0,
                            LAT = 0,
                            SCORE = 0,
                            stringsAsFactors = FALSE))
        }
      }))
    })
  }

  coordAdresses <- do.call("rbind", res)

  coordAdresses$LON <- as.numeric(clean_coord(coordAdresses$LON))
  coordAdresses$LAT <- as.numeric(clean_coord(coordAdresses$LAT))
  coordAdresses$SCORE <- as.numeric(clean_coord(coordAdresses$SCORE))

  return(coordAdresses)
}

#' @name convertTo
#'
#' @title Convertir des coordonnees d'un systeme geographique a un autre et dans un format different (sf ou data.frame)
#'
#' @description La fonction convertTo permet de convertir un objet sf ou un data.frame de coordonnées dans un système géographique différent et dans un autre format, au choix entre sf ou data.frame. 
#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
#'
#' @param from objet sf avec un CRS valide, ou un data.frame de deux colonnes (coordonnées) ou 3 colonnes (id en 1ère colonne puis les coordonnées).
#' Conversion implicite des data.table en data.frame et des objets sp en objet sf
#' @param to texte. Type d'objet souhaité en sortie : "sf" ou "data.frame". Si NULL (par défaut), le type de sortie sera le même que celui de l'objet en entrée.
#' @param fromEpsg texte ou numérique. Si from est un data.frame, fromEpsg doit correspondre au code EPSG des coordonnées à convertir.
#' @param toEpsg texte ou numérique. Code EPSG souhaité pour l'objet à convertir.
#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
#'
#' @return Un objet sf ou un data.frame
#'
#' @details Le code EPSG du système WGS84 est communément 4326.
#'
#' En France métropolitaine, le système de projection en vigueur est le Lambert 93, code EPSG 2154.
#'
#' Pour la Guadeloupe et la Martinique, le code EPSG est 5490 pour la projection UTM 20 N.
#'
#' Pour la Guyane, le code EPSG est 2972 pour la projection UTM 22 N.
#'
#' Pour la Réunion, le code EPSG est 2975 pour la projection UTM 40 S.
#'
#' Pour Mayotte, le code EPSG est 4471 pour la projection UTM 38 S.
#'
#' La projection Mercator pour représenter la mappemonde a pour code EPSG 3395.
#'
#' @importFrom sf st_sf st_sfc st_as_sf st_crs st_geometry st_transform st_coordinates st_point as_Spatial
#' @importFrom shiny withProgress incProgress
#' @importFrom methods is
#' @export
#'
#' @examples
#' # Creation d'un data.frame de 4 coordonnees en Lambert 93.
#' coord <- data.frame(id = c(1:4),
#'                     X = c(897740.5,901367.8,874261.9,897740.5),
#'                     Y = c(6272912,6251706,6291801,6272912),
#'                     stringsAsFactors = FALSE)
#'
#' # Conversion des coordonnees en WGS84 (EPSG 4326).
#' # Transformation du data.frame en objet spatial sf.
#' coord_sf_WGS84 <- convertTo(from = coord,
#'                             to = "sf",
#'                             fromEpsg = 2154,
#'                             toEpsg = 4326)
#'
#'
#' # Creation d'un objet sf : un point en coordonnees Lambert93 (EPSG 2154).
#' objet_sf_points <- sf::st_sf(geometry = sf::st_sfc(
#'                                         sf::st_geometry(
#'                                         sf::st_point(
#'                                         c(897740.5,6272912.0)
#'                                         )),
#'                              crs=2154))
#'
#' # Transformation de l'objet sf en data.frame.
#' # Conversion implicite des coordonnees en WGS84 (EPSG 4326).
#' coord_dt_WGS84 <- convertTo(from = objet_sf_points,
#'                             to = "data.frame")

convertTo <- function(from, to = NULL, fromEpsg = NULL, toEpsg = 4326, interactive = FALSE)
{
if(any(class(from)=="data.table"))
{
  from<-as.data.frame(from)
  warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
} 
if(methods::is(from, "Spatial"))
{
  from <- sf::st_as_sf(x = from)
  warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
}  
  
if(testSf(from)){
    typeFrom <- "sf"
    
} else 
  if(length(class(from))==1 & any(class(from)=="data.frame"))
  {
    typeFrom <- "data.frame"
  }else
  {
    stop(simpleError(paste0("from doit \u00eatre un objet sf avec un CRS renseign\u00e9, 
                            ou un data.frame de 2 colonnes (coordonn","\u00e9","es) ou 3 colonnes (id et coordonn","\u00e9","es).")))
  }

  if(typeFrom == "data.frame")
  {
    if(!is.null(fromEpsg))
    {
      fromEpsg <- as.numeric(fromEpsg)
    }else # fromEpsg est obligatoire si from est une liste
    {
      stop(simpleError(paste0("Veuillez pr","\u00e9","ciser un code epsg dans fromEpsg correspondant \u00e0 un syst\u00e8me de projection.")))
    }
  }

  if(!is.null(toEpsg))
  {
    toEpsg <- as.numeric(toEpsg)
  }else
  {
    stop(simpleError(paste0("Veuillez pr","\u00e9","ciser un code epsg dans toEpsg correspondant \u00e0 un syst\u00e8me de projection.")))
  }

  # si from est un data.frame de coordonnees
  if(typeFrom=="data.frame")
  {
    if(ncol(from)<2 | ncol(from)>3)
    {
      stop(simpleError(paste0("Le data.frame doit \u00eatre compos\u00e9  de 2 colonnes (les coordonn","\u00e9","es en type num\u00e9rique) ou de 3 colonnes (un id et les coordonn","\u00e9","es en type num\u00e9rique).")))
    }else if(ncol(from)==2)
    {
      col <- 0
    }else if(ncol(from)==3)
    {
      col <- 1
    }else
    {}

    if(!is.numeric(from[,col+1]) | !is.numeric(from[,col+2]))
    {
      stop(simpleError(paste0("Le data.frame doit \u00eatre compos\u00e9  de 2 colonnes (les coordonn","\u00e9","es en type num\u00e9rique) ou de 3 colonnes (un id et les coordonn","\u00e9","es en type num\u00e9rique).")))
    }

    st_un_multipoint = function(x) {
      oprj <- sf::st_crs(x)
      g <- sf::st_geometry(x)
      j <- rep(seq_len(nrow(x)), sapply(g, nrow))
      x <- x[j,]
      sf::st_geometry(x) <- sf::st_sfc(do.call(c, lapply(g, function(geom) lapply(1:nrow(geom), function(i) sf::st_point(geom[i,])))))
      x <- sf::st_sf(x, crs = oprj)
      x
    }

    nb_boucles <- nrow(from) %/% 10000
    reste <- nrow(from) %% 10000
    list_pts_coord <- list()
    i <- 0

    if(!interactive)
    {
      pb <- progress::progress_bar$new(
        format = "Calcul en cours - \u00e9tape 1 [:bar] :percent :elapsed",
        total = nb_boucles, clear = FALSE, width= 60
      )

      pb$tick(0)

      if(nb_boucles > 0)
      {
        for(i in 1:nb_boucles)
        {
          pb$tick()
          subset_from <- from[((i-1)*10000+1):(i*10000),]
          pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
          list_pts_coord[[i]] <- st_un_multipoint(pts_coord)
        }
      }
      if(reste > 0)
      {
        subset_from <- from[(i*10000+1):(i*10000+reste),]
        pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
        list_pts_coord[[i+1]] <- st_un_multipoint(pts_coord)
      }
    }else if(interactive)
    {
      shiny::withProgress(message = "Patientez le temps des calculs - \u00e9tape 1",{

        if(nb_boucles > 0)
        {
          for(i in 1:nb_boucles)
          {
            shiny::incProgress(1/nb_boucles)
            subset_from <- from[((i-1)*10000+1):(i*10000),]
            pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
            list_pts_coord[[i]] <- st_un_multipoint(pts_coord)
          }
        }
        if(reste > 0)
        {
          subset_from <- from[(i*10000+1):(i*10000+reste),]
          pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
          list_pts_coord[[i+1]] <- st_un_multipoint(pts_coord)
        }
      })
    }

    if(length(list_pts_coord) > 10)
    {
      nb_boucles <- length(list_pts_coord) %/% 10
      reste <- length(list_pts_coord) %% 10
      list2_pts_coord <- list()
      i <- 0

      if(!interactive)
      {
        pb <- progress::progress_bar$new(
          format = "Calcul en cours - \u00e9tape 2 [:bar] :percent :elapsed",
          total = nb_boucles, clear = FALSE, width= 60
        )

        pb$tick(0)

        if(nb_boucles > 0)
        {
          for(i in 1:nb_boucles)
          {
            pb$tick()
            list2_pts_coord[[i]] <- do.call(rbind,list_pts_coord[((i-1)*10+1):(i*10)])
          }
        }
        if(reste > 0)
        {
          list2_pts_coord[[i+1]] <- do.call(rbind,list_pts_coord[(i*10+1):(i*10+reste)])
        }
      }else if(interactive)
      {
        shiny::withProgress(message = "Patientez le temps des calculs - \u00e9tape 2",{

          if(nb_boucles > 0)
          {
            for(i in 1:nb_boucles)
            {
              shiny::incProgress(1/nb_boucles)
              list2_pts_coord[[i]] <- do.call(rbind,list_pts_coord[((i-1)*10+1):(i*10)])
            }
          }
          if(reste > 0)
          {
            list2_pts_coord[[i+1]] <- do.call(rbind,list_pts_coord[(i*10+1):(i*10+reste)])
          }
        })
      }
    }else
    {
      list2_pts_coord <- list_pts_coord
    }

    pts_coord <- do.call(rbind,list2_pts_coord)

    if(col==1)
    {
      pts_coord$id <- as.data.frame(from)[,1]
      pts_coord <- pts_coord[,c("id","geometry")]
      from <- pts_coord
    }else if(col == 0)
    {
      from <- pts_coord
    }else
    {}
  }

  coordWGS84 <- sf::st_transform(from, crs = toEpsg)

  if(any(to == "data.frame") | (typeFrom == "data.frame" & is.null(to)))
  {
    if(!any(class(sf::st_geometry(coordWGS84)) %in% "sfc_MULTIPOLYGON"))
    {
      if(ncol(coordWGS84)==1)
      {
        coordWGS84 <- data.frame(lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,2])), stringsAsFactors = FALSE)
      }else if(ncol(coordWGS84) > 1)
      {
        coordWGS84 <- data.frame(id = as.data.frame(coordWGS84)[,1], lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,2])), stringsAsFactors = FALSE)
      }else
      {}
    }else if(any(class(sf::st_geometry(coordWGS84)) %in% "sfc_MULTIPOLYGON"))
    {
      if(ncol(coordWGS84)==1)
      {
        coordWGS84 <- data.frame(lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,2])), stringsAsFactors = FALSE)
      }else if(ncol(coordWGS84) > 1)
      {
        list_coordWGS84 <- list()
        for(i in 1:nrow(coordWGS84))
        {
          list_coordWGS84[[i]] <- data.frame(id = as.data.frame(coordWGS84)[i,1], lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84[i,])[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84[i,])[,2])), stringsAsFactors = FALSE)
        }
        coordWGS84 <- do.call(rbind,list_coordWGS84)
      }else
      {}
    }
  } else if(any(to == "sf") | (typeFrom == "sf" & is.null(to)))
  { }else     # coordWGS84 est deja un objet sf 
  {
    stop(simpleError(paste0("L'argument to doit \u00eatre \u00e9gal \u00e0 sf, data.frame ou laiss\u00e9 \u00e0 NULL.")))
  }

  return(coordWGS84)
}

#' @name metricOsrmIso
#'
#' @title Calculer des isochrones ou des isodistances autour d'un ou plusieurs points
#'
#' @description La fonction metricOsrmIso permet de créer des courbes d’isochrones ou d'isodistances mesurant l’accessibilité
#' en temps de parcours ou en distance autour d’un ou plusieurs points.
#'
#' @param loc vecteur numérique (id/lon/lat ou lon/lat), data.frame (3 colonnes id/lon/lat ou 2 colonnes lon/lat), objet sf précisant le(s) point(s)
#' de départ, centre(s) des isochrones. 
#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
#' @param breaks vecteur numérique. Séquence de valeurs numériques indiquant les temps en minutes relatifs aux courbes isochrones ou les distances en kilomètres relatives aux courbes isodistances.
#' @param res numérique. Valeur numérique indiquant la résolution des courbes isochrones, la précision des contours.
#' @param fusion booléen. Si TRUE (par défaut), fusion des courbes isochrones si il y a plusieurs points loc (voir details).
#' @param courbes texte. "isochrones" (par défaut) ou "isodistances". Choix des courbes iso : isochrones ou isodistances.
#' @param exclude texte. Permet aux trajets d'éviter les autoroutes (“motorway”), les péages (“toll”) ou les ferries (“ferry”). Par défaut NULL.
#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
#'
#' @return Une liste d'un ou plusieurs objets sf (MULTIPOLYGON).
#'
#' @details Le temps de calcul peut être important si le nombre de points de départ (loc) et la résolution (res) sont élevés.
#'
#' Le nombre de couples calculé est égal au nombre de points de départ x (résolution)².
#'
#' Si fusion = TRUE, une résolution élevée peut être nécessaire si les points de départ sont très distants.
#'
#' Le nombre de breaks n’influe pas sur le temps de calcul.
#'
#' Si fusion = TRUE (par défaut), les courbes d'isochrones ou d'isodistances fusionnent pour former autant de polygones que de classes (nombre de breaks).
#' Cas d'utilisation : pour mesurer l'accessibilité d'un type d'équipement le plus proche en temps.
#'
#' Si fusion = FALSE, les courbes d'isochrones ou d'isodistances sont calculées autour de chaque point.
#' Cas d'utilisation : pour mesurer séparément l'accessibilité d'un ou plusieurs équipements.
#'
#' @importFrom sf st_sf st_sfc st_as_sf st_crs st_centroid st_geometry read_sf st_transform st_bbox st_coordinates st_distance st_buffer st_union st_intersects st_point st_polygon st_contains st_dimension st_make_valid st_collection_extract
#' @importFrom RJSONIO fromJSON
#' @importFrom methods is as
#' @importFrom progress progress_bar
#' @importFrom isoband iso_to_sfg
#' @export
#'
#' @examples
#' # Specification d'un serveur osrm obligatoire pour executer les exemples
#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
#'
#' # Specification du profil
#' options(osrm.profile = "driving")
#'
#' # Calcul d'isochrones a partir d'un point.
#' iso1 <- metricOsrmIso(loc = data.frame(lon = 4.92,
#'                                        lat = 46.15),
#'                       courbes = "isochrones")
#'
#' plot(sf::st_geometry(iso1[[1]]))
#'
#' # Calcul de deux isochrones separees.
#' iso2 <- metricOsrmIso(loc = data.frame(lon = c(4.92,4.98),
#'                                        lat = c(46.15,46.30)),
#'                       breaks = c(0,30,60),
#'                       res = 20,
#'                       fusion = FALSE,
#'                       courbes = "isochrones")
#'
#' plot(sf::st_geometry(iso2[[2]]), border = "blue")
#' plot(sf::st_geometry(iso2[[1]]), border = "red", add = TRUE)
#'
#' # Calcul d'isochrones fusionnees a partir de deux points.
#' iso3 <- metricOsrmIso(loc = data.frame(lon = c(4.92,4.98),
#'                                        lat = c(46.15,46.30)),
#'                       breaks = c(0,30,60),
#'                       res = 20,
#'                       fusion = TRUE,
#'                       courbes = "isochrones")
#'
#' plot(sf::st_geometry(iso3[[1]]))
#'
#' # Calcul d'isodistances fusionnees a partir de deux points.
#' iso4 <- metricOsrmIso(loc = data.frame(lon = c(4.92,4.98),
#'                                        lat = c(46.15,46.30)),
#'                       breaks = c(0,30,60),
#'                       res = 20,
#'                       fusion = TRUE,
#'                       courbes = "isodistances")
#'
#' plot(sf::st_geometry(iso4[[1]]))
#'
metricOsrmIso <-
function (loc, breaks = seq(from = 0, to = 60, length.out = 5), res = 30, fusion = TRUE, courbes = "isochrones", exclude = NULL, interactive = FALSE)
{
  oprj <- NA
  if (methods::is(loc, "Spatial")) {
    loc <- sf::st_as_sf(loc)
    warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
  }
  if (testSf(loc)) {
    oprj <- sf::st_crs(loc)
    loc <- suppressWarnings(sf::st_centroid(loc))
  }else if (methods::is(loc, "data.frame")){
    if (methods::is(loc, "data.table")){
    warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
      loc<-as.data.frame(loc)  
    }
    if(dim(loc)[2]==2)
    {
      loc <- sf::st_sf(id = 1, geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[,1], lat = loc[,2]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
    }else if(dim(loc)[2]==3)
    {
      loc <- sf::st_sf(id = loc[,1], geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[,2], lat = loc[,3]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
    }else
    {
      e <- "Le data.frame doit comporter 2 colonnes lon et lat ou 3 colonnes id, lon et lat."
      stop(e, call. = FALSE)
    }
  }else if (methods::is(loc, "numeric")){
    if(length(loc)==2)
    {
      loc <- sf::st_sf(id = 1, geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[1], lat = loc[2]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
    }else if(length(loc)==3)
    {
      loc <- sf::st_sf(id = loc[1], geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[2], lat = loc[3]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
    }else
    {
      e <- "Le vecteur numeric doit comporter 2 valeurs lon et lat ou 3 valeurs id, lon et lat."
      stop(e, call. = FALSE)
    }
  }else
  {
    e <- "loc doit \u00eatre un objet sf, data.frame ou vecteur numeric"
    stop(e, call. = FALSE)
  }

  loc_dt <- sfToDf(loc)

  loc <- sf::st_transform(loc, 3857)
  breaks <- unique(sort(breaks))
  tmax <- max(breaks)
  if (options("osrm.profile") %in% c("walk","foot","walking","routed-foot")) {
    speed = 10 * 1000/60
  }
  if (options("osrm.profile") %in% c("bike","bicycle","cycling","routed-bike")) {
    speed = 20 * 1000/60
  }
  if (options("osrm.profile") %in% c("car","driving","routed-car")) {
    speed = 130 * 1000/60
  }
  dmax <- tmax * speed

  if(!is.null(getOption("osrm.server")))
  {
    if(getOption("osrm.server") %in% url)
    {
      emprisePbf <- emprise_pbf
      suppressWarnings(sf::st_crs(emprisePbf) <- 3857)
    }else
    {
      emprisePbf <- NULL
    }
  }else
  {
    emprisePbf <- NULL
  }

  if(nrow(loc)>1)
  {
    bbox <- sf::st_bbox(loc)
    long_x <- bbox[3]-bbox[1]
    long_y <- bbox[4]-bbox[2]
    cote <- max(long_x,long_y)

    lon <- bbox[1]+long_x/2
    lat <- bbox[2]+long_y/2
  }else
  {
    lon <- sf::st_coordinates(loc)[1]
    lat <- sf::st_coordinates(loc)[2]
    cote <- 0
  }

  grid <- data.frame(lon = lon, lat = lat)
  grid <- sf::st_as_sf(grid, coords = c("lon", "lat"), crs = 3857)

  sgrid <- rgrid(loc = grid[1,], dmax = dmax+cote/2, res = res)

  if(!is.null(emprisePbf))
  {
    sgrid_keep <- sf::st_intersects(sgrid, emprisePbf)
    sgrid_select <- sgrid[lengths(sgrid_keep) > 0,]
  }else
  {
    sgrid_select <- sgrid
  }

  lsgr <- nrow(sgrid_select)
  f500 <- lsgr%/%500
  r500 <- lsgr%%500

  matDurDist <- matrix(nrow = nrow(loc_dt), ncol = nrow(sgrid_select))

  if(!interactive)
  {
    pb <- progress::progress_bar$new(
      format = paste0("Etape 1/2 : calcul en cours de ",nrow(loc_dt)*nrow(sgrid_select)," couples -  [:bar] :percent :elapsed"),
      total = nrow(loc_dt), clear = FALSE, width= 80
    )

    pb$tick(0)

    if(any(courbes %in% "isochrones"))
    {
      measure <- "duree"
    }else if(length(courbes) == 1)
    {
      if(courbes == "isodistances")
      {
        measure <- "distance"
      }else
      {
        measure <- "duree"
      }
    }else
    {
      courbes <- "isochrones"
      measure <- "duree"
    }

    for(i in 1:nrow(loc_dt))
    {
      listDurDist <- list()
      listDest <- list()

      if (f500 > 0) {

        for (j in 1:f500) {

          st <- (j - 1) * 500 + 1
          en <- j * 500

          dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,]), duree = TRUE, distance = TRUE, exclude = exclude)

          if(any(dmat$duree < 0))
          {
            dmat[dmat$duree < 0, c("duree", "distance")] <- NA
            if(any(is.na(dmat$duree)))
            {
              list_dmat <- list()
              for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + 500), ])))
              {
                list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
              }
              dmat <- do.call(rbind, list_dmat)
              if(any(dmat$duree < 0))
              {
                dmat[dmat$duree < 0, c("duree", "distance")] <- NA
              }
            }
          }

          listDurDist[[j]] <- dmat[,measure]
          listDest[[j]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
        }
        if (r500 > 0) {

          dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ]), duree = TRUE, distance = TRUE, exclude = exclude)

          if(any(dmat$duree < 0))
          {
            dmat[dmat$duree < 0, c("duree", "distance")] <- NA
            if(any(is.na(dmat$duree)))
            {
              list_dmat <- list()
              for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + r500), ])))
              {
                list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
              }
              dmat <- do.call(rbind, list_dmat)
              if(any(dmat$duree < 0))
              {
                dmat[dmat$duree < 0, c("duree", "distance")] <- NA
              }
            }
          }

          listDurDist[[j+1]] <- dmat[,measure]
          listDest[[j+1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
        }
      }else {

        dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select), duree = TRUE, distance = TRUE, exclude = exclude)

        if(any(dmat$duree < 0))
        {
          dmat[dmat$duree < 0, c("duree", "distance")] <- NA
          if(any(is.na(dmat$duree)))
          {
            list_dmat <- list()
            for(k in 1:nrow(sfToDf(sgrid_select)))
            {
              list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select)[k,], duree = TRUE, distance = TRUE, exclude = exclude)
            }
            dmat <- do.call(rbind, list_dmat)
            if(any(dmat$duree < 0))
            {
              dmat[dmat$duree < 0, c("duree", "distance")] <- NA
            }
          }
        }

        listDurDist[[1]] <- dmat[,measure]
        listDest[[1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
      }
      matDurDist[i,] <- do.call(c, listDurDist)
      destinations <- do.call(rbind, listDest)

      pb$tick()
    }
  }else
  {
    shiny::withProgress(message = paste0("Etape 1/2 : calcul en cours de ",nrow(loc_dt)*nrow(sgrid_select)," couples"),{

      shiny::incProgress(1/nrow(loc_dt))

      if(any(courbes %in% "isochrones"))
      {
        measure <- "duree"
      }else if(length(courbes) == 1)
      {
        if(courbes == "isodistances")
        {
          measure <- "distance"
        }else
        {
          measure <- "duree"
        }
      }else
      {
        courbes <- "isochrones"
        measure <- "duree"
      }

      for(i in 1:nrow(loc_dt))
      {
        listDurDist <- list()
        listDest <- list()

        if (f500 > 0) {
          for (j in 1:f500) {

            st <- (j - 1) * 500 + 1
            en <- j * 500

            dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,]), duree = TRUE, distance = TRUE, exclude = exclude)

            if(any(dmat$duree < 0))
            {
              dmat[dmat$duree < 0, c("duree", "distance")] <- NA
              if(any(is.na(dmat$duree)))
              {
                list_dmat <- list()
                for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + 500), ])))
                {
                  list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
                }
                dmat <- do.call(rbind, list_dmat)
                if(any(dmat$duree < 0))
                {
                  dmat[dmat$duree < 0, c("duree", "distance")] <- NA
                }
              }
            }

            listDurDist[[j]] <- dmat[,measure]
            listDest[[j]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
          }
          if (r500 > 0) {

            dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ]), duree = TRUE, distance = TRUE, exclude = exclude)

            if(any(dmat$duree < 0))
            {
              dmat[dmat$duree < 0, c("duree", "distance")] <- NA
              if(any(is.na(dmat$duree)))
              {
                list_dmat <- list()
                for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + r500), ])))
                {
                  list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
                }
                dmat <- do.call(rbind, list_dmat)
                if(any(dmat$duree < 0))
                {
                  dmat[dmat$duree < 0, c("duree", "distance")] <- NA
                }
              }
            }

            listDurDist[[j+1]] <- dmat[,measure]
            listDest[[j+1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
          }
        }else {

          dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select), duree = TRUE, distance = TRUE, exclude = exclude)

          if(any(dmat$duree < 0))
          {
            dmat[dmat$duree < 0, c("duree", "distance")] <- NA
            if(any(is.na(dmat$duree)))
            {
              list_dmat <- list()
              for(k in 1:nrow(sfToDf(sgrid_select)))
              {
                list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select)[k,], duree = TRUE, distance = TRUE, exclude = exclude)
              }
              dmat <- do.call(rbind, list_dmat)
              if(any(dmat$duree < 0))
              {
                dmat[dmat$duree < 0, c("duree", "distance")] <- NA
              }
            }
          }

          listDurDist[[1]] <- dmat[,measure]
          listDest[[1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
        }
        matDurDist[i,] <- do.call(c, listDurDist)
        destinations <- do.call(rbind, listDest)

        shiny::incProgress(1/nrow(loc_dt))
      }
    })
  }

  if(measure == "duree")
  {
    if(fusion)
    {
      measures <- suppressWarnings(matrix(apply(matDurDist, 2, function(x) min(x, na.rm=T))/60, nrow=1))
      if(any(measures %in% "Inf")) measures[measures %in% "Inf"] <- NA
    }else
    {
      measures <- matDurDist/60
    }
  }else
  {
    if(fusion)
    {
      measures <- suppressWarnings(matrix(apply(matDurDist, 2, function(x) min(x, na.rm=T))/1000, nrow=1))
      if(any(measures %in% "Inf")) measures[measures %in% "Inf"] <- NA
    }else
    {
      measures <- matDurDist/1000
    }
  }

  if(!interactive)
  {
    pb <- progress::progress_bar$new(
      format = paste0("Etape 2/2 : formation de ",dim(measures)[1]," ", courbes," -  [:bar] :percent :elapsed"),
      total = dim(measures)[1], clear = FALSE, width= 80
    )

    pb$tick(0)

    list_iso <- list()

    for(i in 1:dim(measures)[1])
    {
      rpt <- sf::st_as_sf(destinations, coords = c("lon", "lat"), crs = 4326)
      rpt <- sf::st_transform(rpt, sf::st_crs(loc))
      rpt$measures <- measures[i,]
      if(any(is.na(rpt$measures))) rpt <- rpt[!is.na(rpt$measures),]
      b <- as.numeric(sf::st_distance(sgrid[1, ], sgrid[2, ])/2)
      xx <- st_make_grid_metric(x = sf::st_buffer(sf::st_union(sgrid), b), n = c(res,res))
      bbox_rpt <- sf::st_bbox(rpt)
      sfbbox_rpt <- sf::st_sfc(sf::st_polygon(list(rbind(c(bbox_rpt[1]-50000, bbox_rpt[2]-50000),
                                                         c(bbox_rpt[3]+50000, bbox_rpt[2]-50000),
                                                         c(bbox_rpt[3]+50000, bbox_rpt[4]+50000),
                                                         c(bbox_rpt[1]-50000, bbox_rpt[4]+50000),
                                                         c(bbox_rpt[1]-50000, bbox_rpt[2]-50000)))),
                               crs = sf::st_crs(xx))

      inter <- sf::st_intersects(xx, sfbbox_rpt)
      xx <- xx[lengths(inter) > 0,]
      if(length(xx) == 0)
      {
        e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
        stop(e, call. = FALSE)
      }
      inter <- sf::st_intersects(sgrid, xx)
      sgrid2 <- sgrid[lengths(inter) > 0,]
      inter <- sf::st_contains(xx, rpt)
      sgrid2$measures <- unlist(lapply(inter, function(x) mean(rpt[["measures"]][x], na.rm = TRUE)))

      if(nrow(sgrid2) > 0)
      {
        sgrid2[is.nan(sgrid2$measures), "measures"] <- tmax + 1
        sgrid2[sgrid2$measures > tmax, "measures"] <- tmax + 1
      }else
      {
        e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
        stop(e, call. = FALSE)
      }

      if(min(sgrid2$measures) > tmax) {
        e <- "Utilisez des 'breaks' plus faibles ou augmenter 'res'"
        stop(e, call. = FALSE)
      }
      iso <- isopoly(x = sgrid2, breaks = breaks, var = "measures")
      if (!is.na(oprj)) {
        iso <- sf::st_transform(x = iso, oprj)
      }else {
        iso <- sf::st_transform(x = iso, 4326)
      }

      list_iso[[i]] <- iso

      pb$tick()
    }
  }else
  {
    shiny::withProgress(message = paste0("Etape 2/2 : formation de ",dim(measures)[1]," ", courbes),{

      shiny::incProgress(1/dim(measures)[1])

      list_iso <- list()

      for(i in 1:dim(measures)[1])
      {
        rpt <- sf::st_as_sf(destinations, coords = c("lon", "lat"), crs = 4326)
        rpt <- sf::st_transform(rpt, sf::st_crs(loc))
        rpt$measures <- measures[i,]
        if(any(is.na(rpt$measures))) rpt <- rpt[!is.na(rpt$measures),]
        b <- as.numeric(sf::st_distance(sgrid[1, ], sgrid[2, ])/2)
        xx <- st_make_grid_metric(x = sf::st_buffer(sf::st_union(sgrid), b), n = c(res,res))
        bbox_rpt <- sf::st_bbox(rpt)
        sfbbox_rpt <- sf::st_sfc(sf::st_polygon(list(rbind(c(bbox_rpt[1]-50000, bbox_rpt[2]-50000),
                                                           c(bbox_rpt[3]+50000, bbox_rpt[2]-50000),
                                                           c(bbox_rpt[3]+50000, bbox_rpt[4]+50000),
                                                           c(bbox_rpt[1]-50000, bbox_rpt[4]+50000),
                                                           c(bbox_rpt[1]-50000, bbox_rpt[2]-50000)))),
                                 crs = sf::st_crs(xx))

        inter <- sf::st_intersects(xx, sfbbox_rpt)
        xx <- xx[lengths(inter) > 0,]
        if(length(xx) == 0)
        {
          e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
          stop(e, call. = FALSE)
        }
        inter <- sf::st_intersects(sgrid, xx)
        sgrid2 <- sgrid[lengths(inter) > 0,]

        inter <- sf::st_contains(xx, rpt)
        sgrid2$measures <- unlist(lapply(inter, function(x) mean(rpt[["measures"]][x], na.rm = TRUE)))
        if(nrow(sgrid2) > 0)
        {
          sgrid2[is.nan(sgrid2$measures), "measures"] <- tmax + 1
          sgrid2[sgrid2$measures > tmax, "measures"] <- tmax + 1
        }else
        {
          e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
          stop(e, call. = FALSE)
        }
        if (min(sgrid2$measures) > tmax) {
          e <- "Utilisez des 'breaks' plus faibles ou augmenter 'res'"
          stop(e, call. = FALSE)
        }
        iso <- isopoly(x = sgrid2, breaks = breaks, var = "measures")
        if (!is.na(oprj)) {
          iso <- sf::st_transform(x = iso, oprj)
        }else {
          iso <- sf::st_transform(x = iso, 4326)
        }

        list_iso[[i]] <- iso

        shiny::incProgress(1/dim(measures)[1])
      }
    })
  }

  return(list_iso)
}

#' @name indTableSrcDst
#'
#' @title Calculer des indicateurs en volume par source (src) ou par destination (dst)
#'
#' @description La fonction indTableSrcDst permet de calculer par destination (dst) la somme d'une ou plusieurs variables en volume issues des sources (src), la population par exemple.
#'
#' La fonction permet également de calculer la part des variables en volume pour chaque source dans l'ensemble des sources ayant une même destination.
#'
#' @param res data.frame. Résultat de la fonction metricOsrmTable avec nbDstVolOiseau = 1 ou nbDstMeasure = 1.
#'
#' @return liste de deux objets sf.
#'
#' Le 1er élément comporte une source (src) par observation. Les variables en volume sont couplées à une variable indiquant la part de ce volume dans l'ensemble des sources ayant la même destination (en pourcentage).
#'
#' Le 2ème élément comporte une destination (dst) par observation (voir details).
#'
#' @details La table res doit etre calculée à partir de la fonction metricOsrmTable avec les arguments nbDstVolOiseau = 1 ou nbDstMeasure = 1.
#' En effet, il ne faut qu'un seul résultat par source : la destination la plus proche d'une source à vol d'oiseau, en temps ou en distance.
#'
#' L'ordre des colonnes de res en entrée de indTableSrcDst doit être obligatoirement le même que celui obtenu en sortie de la fonction metricOsrmTable.
#'
#' Pour calculer les indicateurs, il faut ajouter des variables en volume à la suite du tableau de résultats (la population par source par exemple).
#'
#' En sortie, le 2ème élément de la liste indique les indicateurs en volume par destination. Il s'agit de la somme de toutes les variables de sources pour chaque destination.
#' Il donne également un comptage du nombre de sources allant vers chaque destination.
#' Si il n'y a pas de variable en volume ajoutée au tableau de résultats, seul l'indicateur de comptage est indiqué.
#'
#' Les deux éléments sont des objets sf. Il est alors possible, par exemple, de réaliser une carte en ronds proportionnels par destination selon un indicateur calculé.
#'
#' @importFrom stats aggregate
#' @export
#'
#' @examples
#' # Reproduction d'une table de resultats avec la fonction metricOsrmTable
#' res <- data.frame(ID = c(1:4),
#'                   idSrc = c("1","2","3","4"),
#'                   lonSrc = c(5.39200,5.39242,5.37107,5.46476),
#'                   latSrc = c(43.28292,43.28368,43.47900,43.31246),
#'                   idDst = c("B","B","A","C"),
#'                   lonDst = c(5.38385,5.38385,5.47678,5.38219),
#'                   latDst = c(43.28571,43.28571,43.29028,43.44144),
#'                   duree = c(87.3,62.8,726.8,239.7),
#'                   distance = c(1103.3,942.7,8318.6,3252.6),
#'                   pop = c(1204,806,1164,976),
#'                   stringsAsFactors = FALSE)
#'
#' res_ind <- indTableSrcDst(res = res)
#'
indTableSrcDst <- function(res)
{
  measure <- c()
  if(any(names(res) %in% "duree")) measure <- c(measure,"duree")
  if(any(names(res) %in% "distance")) measure <- c(measure,"distance")

  if(!identical(names(res)[1:7], c("ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst"))) # si les 7 premieres colonnes ne correspondent pas, erreur
  {
    if(identical(names(res)[1:7], c("idSrc","ID","lonSrc","latSrc","idDst","lonDst","latDst")))
    {
      res <- res[,c(2,1,3:ncol(res))] # si merge de la table de resultat, les 2 premieres colonnes seront inversees, dc on les met dans le bon ordre si l'utilisateur ne l'a pas deja fait.
    }else
    {
      stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
    }
  }
  if(is.null(measure)) # si il n'y a pas de colonnes duree et/ou distance, erreur
  {
    stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
  }
  if(length(measure)==1)
  {
    if(!names(res)[8] %in% measure) # si la 8ème colonne n'est ni duree, ni distance, erreur
    {
      stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
    }
  }

  if(any(measure %in% "duree"))
  {
    if(any(res$duree %in% -999999.00))
    {
      nbNonCalc <- length(res$duree[res$duree %in% -999999.00])
      if(nbNonCalc == 1)
      {
        message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (duree = -999999.00)."))
        message(paste0("Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs par source et par destination"))
      }
      if(nbNonCalc > 1)
      {
        message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (duree = -999999.00)."))
        message(paste0("Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs par source et par destination."))
      }
      res <- res[!res$duree %in% -999999.00,]
    }
  }

  if(any(measure %in% "distance") & !any(measure %in% "duree"))
  {
    if(any(res$distance %in% -999999.00))
    {
      nbNonCalc <- length(res$distance[res$distance %in% -999999.00])
      if(nbNonCalc == 1)
      {
        message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (distance = -999999.00)."))
        message(paste0("Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs par source et par destination."))
      }
      if(nbNonCalc > 1)
      {
        message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (distance = -999999.00)."))
        message(paste0("Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs par source et par destination."))
      }
      res <- res[!res$distance %in% -999999.00,]
    }
  }

  if(length(res$idSrc) != length(unique(res$idSrc)))
  {
    message(paste0("[WARNING] Il existe plusieurs sources identiques alors qu'il n'en faut qu'une seule pour le calcul de l'indicateur."))
    message(paste0("Veuillez filtrer la table de r\u00e9sultats ou r","\u00e9","ex","\u00e9","cutez la fonction metricOsrmTable "))
    message(paste0("avec les arguments nbDstVolOiseau = 1 ou nbDstMeasure = 1."))
    return(NULL)
  }

  sf_src <- unique(convertTo(from = res[,c(2:4)], to = "sf", fromEpsg = 4326))
  sf_src[,names(res)[8:length(names(res))]] <- res[,8:ncol(res)]
  names(sf_src)[1] <- "idSrc"
  names(attr(sf_src, "agr"))[1] <- "idSrc"

  sf_dst <- unique(convertTo(from = res[,c(5:7)], to = "sf", fromEpsg = 4326))
  names(sf_dst)[1] <- "idDst"
  names(attr(sf_dst, "agr"))[1] <- "idDst"

  parSrc <- merge(sf_src, res[,c("idSrc","idDst")], by = "idSrc")
  parSrc <- parSrc[,c(1,ncol(parSrc)-1,2:(ncol(parSrc)-2),ncol(parSrc))]

  parDstNb <- stats::aggregate(parSrc$idDst, by = list(parSrc$idDst), FUN = length)
  names(parDstNb) <- c("idDst","nbSrc")

  if(ncol(parSrc) > 5 | (ncol(parSrc) > 4 & length(measure) == 1))
  {
    parDstSum <- stats::aggregate(parSrc[,(3+length(measure)):(ncol(parSrc)-1)], by = list(parSrc$idDst), FUN = sum)
    names(parDstSum) <- c("idDst",names(parSrc)[(3+length(measure)):(length(names(parSrc))-1)],"geometry")
    parDst <- merge(parDstNb, as.data.frame(parDstSum)[,c(1,2:(ncol(parDstSum)-1))], by = "idDst")
    parDst <- merge(sf_dst, parDst, by = "idDst")
  }else
  {
    parDst <- merge(sf_dst, parDstNb, by = "idDst")
  }

  if(ncol(parDst) > 3)
  {
    var <- names(parDst)[3:(ncol(parDst)-1)]

    parSrc <- merge(parSrc, as.data.frame(parDst)[,c("idDst",var)], by = "idDst")
    names(parSrc) <- c("idDst","idSrc",measure,var,paste0("tot_",var),"geometry")

    parSrc[,paste0("part_",var)] <- round(as.data.frame(parSrc)[,var] / as.data.frame(parSrc)[,paste0("tot_",var)]*100,3)

    parSrc <- parSrc[,c("idSrc","idDst",measure,as.vector(sapply(1:length(var), function(x) c(var[x],paste0("part_",var)[x]))),"geometry")]
    names(attr(parSrc, "agr")) <- names(parSrc)[-length(names(parSrc))]
  }

  return(list(parSrc,parDst))
}

#' @name indIsoSpatial
#'
#' @title Calculer des indicateurs en volume par regroupement de mailles selon leur appartenance spatiale
#'
#' @description La fonction indIsoSpatial permet de sommer une ou plusieurs variables (la population par exemple)
#' d'une maille (maille communale ou grille par exemple) selon leur appartenance spatiale à une zone particulière (polygones d'isochrones par exemple).
#'
#' @param pol,maille objet sf (POLYGON ou MULTIPOLYGON).
#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' @param var vecteur texte. Noms des variables en volume à sommer de l'objet maille.
#' @param pond vecteur numérique. Noms des variables de pondération de l'objet maille. A appliquer aux variables à sommer. Par défaut NULL.
#' @param choixIntersect numérique. 1, 2 ou 3 (voir details). Par défaut 1.
#' @param return vecteur texte. "pol", "maille" ou c("pol","maille") (voir details). Par défaut "pol".
#' @param idGroup texte. Nom de la variable identifiant les pol et constituant les groupes de maille si return contient "maille". Par défaut NULL.
#'
#' @return Si return == "pol", l'objet pol, enrichi des variables sommées issues de l'objet maille.
#'
#' Si return == "maille", l'objet maille, enrichi d'une variable indiquant le groupe d'appartenance de la maille à pol et les valeurs sommées pour chaque groupe.
#'
#' Si return == c("pol","maille"), une liste contenant pol et maille est renvoyée, enrichie des variables décrites ci-dessus.
#'
#' @details Si les variables de pondérations sont renseignées, le vecteur des variables de pondérations doit respecter le même ordre que le vecteur des variables à sommer.
#'
#' Le paramètre choixIntersect vaut 1, 2 ou 3. Si une maille intersecte pol :
#'
#' choix 1 : la totalité de la variable de la maille intersectée est comptabilisée dans la somme.
#'
#' choix 2 : la maille est tronquée selon le découpage de pol. Les valeurs à sommer sont recalculées selon le prorata de la surface de la maille tronquée.
#'
#' choix 3 : la totalité de la variable de la maille intersectée est exclue de la somme.
#'
#' Les arguments pol et maille doivent être dans le même système de projection, peu importe le système.
#'
#' @importFrom sf st_as_sf st_transform st_cast st_intersects st_intersection st_area
#' @importFrom methods is
#' @export
#'
#' @examples
#' # Specification d'un serveur osrm obligatoire pour executer les exemples
#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
#'
#' # Specification du profil
#' options(osrm.profile = "driving")
#'
#' # Appel a la fonction metricOsrmIso
#' iso <- metricOsrmIso(loc = data.frame(lon = 4.92,lat = 46.15))
#'
#' # Conversion en projection metrique Lambert 93 (EPSG 2154)
#' iso_L93 <- convertTo(from = iso[[1]],
#'                      toEpsg = 2154)
#'
#' # Construction d'une grille
#' grille <- sf::st_as_sf(x = sf::st_make_grid(iso_L93, cellsize = 52000))
#'
#' # Ajout d'une variable en volume a la grille
#' grille$vol <- c(15,11,26,5,3,17)
#'
#' # Calcul de l'indicateur spatial
#' ind_res <- indIsoSpatial(pol = iso_L93,
#'                          maille = grille,
#'                          var = "vol",
#'                          choixIntersect = 1,
#'                          return = c("pol","maille"),
#'                          idGroup = "id")
#'
indIsoSpatial <- function(pol, maille, var, pond = NULL, choixIntersect = 1, return = "pol", idGroup = NULL)
{
  if(any(!return %in% c("pol","maille")))
  {
    stop(simpleError("return doit etre 'pol', 'maille' ou c('pol','maille')."))
  }

  if(!choixIntersect %in% c(1,2,3))
  {
    stop(simpleError("choixIntersect doit etre 1, 2 ou 3."))
  }

  if(methods::is(pol, "Spatial")) {
    pol <- sf::st_as_sf(pol)
    warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
  }
  if(methods::is(maille, "Spatial")) {
    maille <- sf::st_as_sf(maille)
    warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
  }

  if(length(which(names(maille) %in% var)) != length(var))
  {
    stop(simpleError("Toutes les variables du vecteur var doivent \u00eatre presentes dans l'objet maille."))
  }

  if(any(return %in% "maille") & !any(names(pol) %in% idGroup))
  {
    stop(simpleError("Si return contient 'maille', idGroup doit \u00eatre la variable identifiant de pol."))
  }

  if(!is.null(pond))
  {
    if(length(var) != length(pond))
    {
      stop(simpleError("Le vecteur var doit \u00eatre de m\u00eame longueur que le vecteur pond"))
    }
    if(length(which(names(maille) %in% pond)) != length(pond))
    {
      stop(simpleError("Toutes les variables du vecteur pond doivent \u00eatre presentes dans l'objet maille."))
    }
    pondNULL <- FALSE
  }else if(is.null(pond))
  {
    for(i in 1:length(var))
    {
      maille[,paste0("pond",i)] <- 1
      pond <- c(pond,paste0("pond",i))
    }
    pondNULL <- TRUE
  }else
  {}

  pol <- sf::st_transform(pol, crs = 2154)
  maille <- sf::st_transform(maille, crs = 2154)

  for(i in 1:length(var))
  {
    pol[,var[i]] <- NA
  }

  if(any(return %in% "maille")) listMaille <- list()

  pb <- progress::progress_bar$new(
    format = paste0("Calcul en cours pour ",nrow(pol)," polygones -  [:bar] :percent :elapsed"),
    total = nrow(pol), clear = FALSE, width= 80
  )

  pb$tick(0)

  for(i in 1:nrow(pol))
  {
    # on garde tous les carreaux inclus dans le polygone et ceux qui touchent
    carr_intersects <- as.numeric(sf::st_intersects(maille,pol[i,]))
    carr_intersects <- data.frame(i=carr_intersects,idx=1:length(carr_intersects), stringsAsFactors = FALSE)
    if(any(is.na(carr_intersects$i))) carr_intersects <- carr_intersects[!is.na(carr_intersects$i),]

    if(choixIntersect == 1)
    {
      maille_1 <- maille[carr_intersects$idx,]

      calcul_1 <- round(apply(as.data.frame(as.data.frame(maille_1)[,var])*as.data.frame(as.data.frame(maille_1)[,pond]),2,sum),1)
      calcul_2 <- 0
      calcul_3 <- 0

      if(any(return %in% "maille"))
      {
        maille_1$groupe_pol <- as.data.frame(pol)[i,idGroup]
        for(j in 1:length(var))
        {
          maille_1[,paste0("sum_",var[j])] <- calcul_1[j]
        }
        maille_2 <- NULL
        maille_3 <- NULL
      }
    }

    if(choixIntersect %in% c(2,3))
    {
      # On repère d'abord les carreaux qui touchent ...
      carr_touches <- sf::st_cast(pol[i,], to = "MULTILINESTRING")
      carr_touches <- as.numeric(sf::st_intersects(maille,carr_touches))
      carr_touches <- data.frame(i=carr_touches,idx=1:length(carr_touches), stringsAsFactors = FALSE)
      if(any(is.na(carr_touches$i))) carr_touches <- carr_touches[!is.na(carr_touches$i),]
      maille_4 <- maille[carr_touches$idx,]

      # ... puis on les enlève du résultat d'intersects
      carr_contains <- carr_intersects[!carr_intersects$idx %in% carr_touches$idx,]
      maille_3 <- maille[carr_contains$idx,]

      calcul_3 <- round(apply(as.data.frame(as.data.frame(maille_3)[,var])*as.data.frame(as.data.frame(maille_3)[,pond]),2,sum),1)

      if(choixIntersect == 3)
      {
        calcul_1 <- 0
        calcul_2 <- 0

        maille_1 <- NULL
        maille_2 <- NULL

        if(any(return %in% "maille"))
        {
          maille_3$groupe_pol <- as.data.frame(pol)[i,idGroup]
          for(j in 1:length(var))
          {
            maille_3[,paste0("sum_",var[j])] <- calcul_3[j]
          }
        }
      }
    }

    if(choixIntersect == 2)
    {
      # On tronque les carreaux qui touchent à partir de maille_4
      suppressWarnings(carr_intersection <- sf::st_intersection(maille_4,pol[i,]))
      carr_intersection <- carr_intersection[,names(maille_4)]
      surf_intersection <- as.numeric(sf::st_area(carr_intersection))
      surf_carr_entier <- max(as.numeric(sf::st_area(maille_3)))
      rapport_surf_intersection <- surf_intersection/surf_carr_entier

      calcul_1 <- 0
      calcul_2 <- round(calcul_3 + apply(as.data.frame(as.data.frame(maille_4)[,var])*as.data.frame(as.data.frame(maille_4)[,pond])*rapport_surf_intersection,2,sum),1)
      calcul_3 <- 0

      if(any(return %in% "maille"))
      {
        maille_1 <- NULL

        # On colle à tous les carreaux inclus entièrement dans le polygone (maille_3)
        maille_2 <- rbind(carr_intersection,maille_3)

        maille_2$groupe_pol <- as.data.frame(pol)[i,idGroup]
        for(j in 1:length(var))
        {
          maille_2[,paste0("sum_",var[j])] <- calcul_2[j]
        }

        maille_3 <- NULL
      }
    }

    if(any(return %in% "pol"))
    {
      pol[i,var] <- calcul_1 + calcul_2 + calcul_3
      attr(pol, "agr") <- c("id","min","max","center",var)
    }

    if(any(return %in% "maille"))
    {
      listMaille[[i]] <- rbind(maille_1,maille_2,maille_3)
    }

    pb$tick()
  }

  if(any(return %in% "maille"))
  {
    maille <- do.call(rbind, listMaille)
    maille <- maille[order(as.numeric(row.names(maille))),]

    if(pondNULL) maille <- maille[,-which(names(maille) %in% pond)]
  }

  if(length(return) == 1 & any(return %in% "pol")) return(pol)
  if(length(return) == 1 & any(return %in% "maille")) return(maille)
  if(length(return) == 2) return(list(pol,maille))
}

input_route <-
function (x, id, single = TRUE)
{
  if (single) {
    if (is.vector(x)) {
      if (length(x) == 2) {
        id <- id
        i <- 0
      }
      else {
        i <- 1
        id <- x[i]
      }
      lon <- clean_coord(x[i + 1])
      lat <- clean_coord(x[i + 2])
    }
    if (methods::is(x, "Spatial")) {
      x <- sf::st_as_sf(x[1, ])
      warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf.")
    }
    if (is.data.frame(x)) {
      if (methods::is(x, "data.table")) {      
      warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame.")
        x <- as.data.frame(x)
      }
      if (methods::is(x, "sf")) {
        x <- sfToDf(x)
        i <- 1
        id <- x[1, i]
      }
      else {
        if (length(x) == 2) {
          i <- 0
          id <- id
        }
        else {
          i <- 1
          id <- x[1, i]
        }
      }
      lon <- clean_coord(x[1, i + 1])
      lat <- clean_coord(x[1, i + 2])
    }
    return(list(id = id, lon = lon, lat = lat))
  }
  else {
    if (methods::is(x, "Spatial")) {
      x <- sf::st_as_sf(x)
      warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf.")
    }
    if (methods::is(x, "data.table")) {      
      warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame.")
      x <- as.data.frame(x)
    }
    if (is.data.frame(x)) {
      if (methods::is(x, "sf")) {
        x <- sfToDf(x)
        i <- 1
        id1 <- x[1, 1]
        id2 <- x[nrow(x), 1]
      }
      else {
        if (length(x) == 2) {
          i <- 0
          id1 <- "src"
          id2 <- "dst"
        }
        else {
          i <- 1
          id1 <- x[1, 1]
          id2 <- x[nrow(x), 1]
        }
      }
      lon <- clean_coord(x[, i + 1])
      lat <- clean_coord(x[, i + 2])
    }
    return(list(id1 = id1, id2 = id2, lon = lon, lat = lat))
  }
}

# Calcul la durée et/ou la distance
#
# La fonction osrmTable_1n_n1 permet de calculer la durée et la distance d'un point vers un groupe de points
# ou d'un groupe de points vers un point.
#
# @param src data.frame (3 colonnes id/lon/lat).
# @param dst data.frame (3 colonnes id/lon/lat).
# @param duree booleen. La fonction retourne la durée. Par défaut à TRUE.
# @param distance booleen. La fonction retourne la distance. Par défaut à TRUE.
# @param exclude string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
#
# @return data.frame
osrmTable_1n_n1 <- function(src, dst, duree, distance, exclude)
{
  nb_row <- 500 # nombre de couples max par requete 1->n ou n->1
  res_duree <- data.frame()
  res_distance <- data.frame()
  res_destinations <- data.frame()
  res_sources <- data.frame()
  measure <- NULL
  if(duree) measure <- "duration"
  if(distance) measure <- c(measure,"distance")
  if(is.null(measure)) measure <- "duration"
  if(is.null(exclude))
  {
    exclude_str <- ""
  }else{
    exclude <- paste(exclude, sep = "", collapse = ",")
    exclude_str <- paste("&exclude=", exclude, sep = "")
  }
  src_seul <- FALSE
  dst_seul <- FALSE

  if(nrow(src)==1)
  {
    if(nrow(dst)==nb_row)
    {
      nb_boucle <- 0
    }else
    {
      nb_boucle <- nrow(dst)%/%nb_row
    }
    src_seul <- TRUE
  }else if(nrow(dst)==1)
  {
    if(nrow(src)==nb_row)
    {
      nb_boucle <- 0
    }else
    {
      nb_boucle <- nrow(src)%/%nb_row
    }
    dst_seul <- TRUE
  }else{}

  list_res_1n_n1 <- list()
  for(i in 0:nb_boucle)
  {
    if(dst_seul & nrow(src) > 0)
    {
      if(nrow(src)<nb_row)
      {
        idx_src <- 1:nrow(src)
      }else
      {
        idx_src <- 1:nb_row
      }

      idx_dst <- idx_src[length(idx_src)]

      res <- requeteOsrm_n1(src = src, idx_src = idx_src, dst = dst, idx_dst = idx_dst, measure = measure, exclude_str = exclude_str)

    }else if(src_seul & nrow(dst) > 0)
    {
      idx_src <- 0

      if(nrow(dst)<nb_row)
      {
        idx_dst <- 1:nrow(dst)
      }else
      {
        idx_dst <- 1:nb_row
      }

      res <- requeteOsrm_1n(src = src, idx_src = idx_src, dst = dst, idx_dst = idx_dst, measure = measure, exclude_str = exclude_str)

    }else{}

    if(nrow(src) > 0 & nrow(dst) > 0)
    {
      if(duree)
      {
        # Cas des couples non calculés
        if(length(which(sapply(res$durations, function(x) is.null(x[[1]])))) > 0)
        {
          idx_0 <- which(sapply(res$durations, function(x) is.null(x[[1]])))
          for(j in 1:length(idx_0))
          {
            res$durations[[idx_0[j]]] <- -60
          }
        }
        # Cas des valeurs négatives
        if(length(which(sapply(res$durations, function(x) x[[1]] < 0))) > 0)
        {
          idx_0 <- which(sapply(res$durations, function(x) x[[1]] < 0))
          for(j in 1:length(idx_0))
          {
            if(any(res$durations[[idx_0[j]]] != -60)) res$durations[[idx_0[j]]] <- abs(res$durations[[idx_0[j]]])
          }
        }

        aa <- lapply(1:length(res$durations[[1]]), function(x) if(is.null(res$durations[[1]][[x]])) res$durations[[1]][[x]] <<- -60)
        rm(aa)
        res_duree <- data.frame(duree=unlist(res$durations))
      }
      if(distance)
      {
        # Cas des couples non calculés
        if(length(which(sapply(res$distances, function(x) is.null(x[[1]])))) > 0)
        {
          idx_0 <- which(sapply(res$distances, function(x) is.null(x[[1]])))
          for(j in 1:length(idx_0))
          {
            res$distances[[idx_0[j]]] <- -1000
          }
        }
        
        # Cas des valeurs négatives
        if(length(which(sapply(res$distances, function(x) x[[1]] < 0))) > 0)
        {
          idx_0 <- which(sapply(res$distances, function(x) x[[1]] < 0))
          for(j in 1:length(idx_0))
          {
            if(any(res$distances[[idx_0[j]]] != -1000)) res$distances[[idx_0[j]]] <- abs(res$distances[[idx_0[j]]])
          }
        }

        aa <- lapply(1:length(res$distances[[1]]), function(x) if(is.null(res$distances[[1]][[x]])) res$distances[[1]][[x]] <<- -1000)
        rm(aa)
        res_distance <- data.frame(distance=unlist(res$distances))
      }
      coords <- coordFormat(res = res, src = src[1:length(idx_src),], dst = dst[1:length(idx_dst),])
      res_sources <- coords$sources
      res_destinations <- coords$destinations

      names(res_sources) <- c("idSrc","lonSrc","latSrc")
      names(res_destinations) <- c("idDst","lonDst","latDst")

      res_1n_n1 <- cbind(res_sources,res_destinations)
      if(duree) res_1n_n1 <- cbind(res_1n_n1,res_duree)
      if(distance) res_1n_n1 <- cbind(res_1n_n1,res_distance)

      list_res_1n_n1[[i+1]] <- res_1n_n1

      if(dst_seul)
      {
        src <- src[-idx_src,]
      }else if(src_seul)
      {
        dst <- dst[-idx_dst,]
      }
    }
  }

  res_1n_n1 <- do.call(rbind,list_res_1n_n1)
  res_1n_n1$idSrc <- as.character(res_1n_n1$idSrc)
  res_1n_n1$idDst <- as.character(res_1n_n1$idDst)

  row.names(res_1n_n1) <- c(1:nrow(res_1n_n1))

  return(res_1n_n1)
}

# @name osrmTableFiltre
# @title La fonction interne osrmTableFiltre.
# @description La fonction interne osrmTableFiltre permet de filtrer n destinations les plus proche d'une source dans un rayonMax. 
# @param code_epsg Entier numérique de longueur 4.
# @inheritParams metriOsrmTable -code_epsg
# @return Un data.frame
# @noRd
# @export
# 
osrmTableFiltre <- function(src, dst, duree, distance, exclude, rayonMax, nbDstVolOiseau, nbDstMeasure, optiMeasure, code_epsg, interactive)
{
  src <- unique(src)
  dst <- unique(dst)

  if(any(duplicated(as.data.frame(dst)[,1])))
  {
    message(paste0("[WARNING] Attention, il y a des doublons dans les identifiants des destinations. Ils devraient \u00eatre unique si rayonMax ou nbDstVolOiseau > 0."))
  }

  rayonMax <- rayonMax*1000

  coord_src <- convertTo(from = src, fromEpsg = 4326, toEpsg = code_epsg)

  coord_dst <- convertTo(from = dst, fromEpsg = 4326, toEpsg = code_epsg)

  mat <- NULL

  if(rayonMax > 0 & nbDstVolOiseau > 0) # n dst par src les plus proches dans un rayon de x km max
  {
    if(nbDstVolOiseau > nrow(dst)) nbDstVolOiseau <- nrow(dst)
    res <- tryCatch({
            mat <- RANN::nn2(coord_dst[,-1], coord_src[,-1], k = nbDstVolOiseau, searchtype = 'radius', radius = rayonMax)
    },error = function(err){
      message(paste0("Aucun point n'a \u00e9t\u00e9 trouv\u00e9 \u00e0 moins de ",rayonMax/1000," km \u00e0 vol d'oiseau"))
    })
  }else if(rayonMax == 0 & nbDstVolOiseau > 0) # n dst par src les plus proches dans l'ensemble des src
  {
    if(nbDstVolOiseau > nrow(dst)) nbDstVolOiseau <- nrow(dst)
    res <- tryCatch({
            mat <- RANN::nn2(coord_dst[,-1], coord_src[,-1], k = nbDstVolOiseau)
    },error = function(err){
      message(paste0("Aucun point n'a \u00e9t\u00e9 trouv\u00e9"))
    })
  }else if(rayonMax > 0 & nbDstVolOiseau == 0) # tous les dst par src dans un rayon de x km max
  {
    res <- tryCatch({
            mat <- RANN::nn2(coord_dst[,-1], coord_src[,-1], k = nrow(dst), searchtype = 'radius', radius = rayonMax)
    },error = function(err){
      message(paste0("Aucun point n'a \u00e9t\u00e9 trouv\u00e9 \u00e0 moins de ",rayonMax/1000," km \u00e0 vol d'oiseau"))
    })
  }else
  {
    # tous les dst dans l'ensemble des src
    # rayonMax == 0 & nbPlusProche == 0 --> fct osrmTableCartesien
    stop(simpleError("Veuillez svp utiliser la fonction osrmTableCartesien."))
  }

  if(!is.null(mat))
  {
    idx <- lapply(1:ncol(mat$nn.idx), function(x) {
                  dt <- data.frame(idx_src = 1:nrow(mat$nn.idx),
                                   idx_dst = mat$nn.idx[,x],
                                   stringsAsFactors = FALSE)
                  if(any(which(dt$idx_dst == 0)) > 0) dt <- dt[-which(dt$idx_dst == 0),]
                  return(dt)
            })

    idx <- do.call(rbind, idx)
    idx <- idx[order(idx$idx_src),]

    if(nrow(idx) > 0)
    {
      src <- src[idx$idx_src,]
      dst <- dst[idx$idx_dst,]

      res <- osrmTableFaceAFace(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
      # on met les -999999 (en realite -60 et -1000 issus de osrmTableFaceAFace) en 999999 
      # pour eviter qu ils ne se retrouvent en tete lors du classement de list_dtIdSrcMin
      res$duree[res$duree == -60.0]  <- 999999
      res$distance[res$distance == -1000.0] <- 999999
      if(nbDstMeasure > 0) # on filtre apres les calculs pour garder les n dst par src les plus proches en temps ou en distance
      {
        list_dtIdSrc <- split(res,res$idSrc)

        if(optiMeasure == "duree")
        {
          list_dtIdSrcMin <- lapply(1:length(list_dtIdSrc), function (x) list_dtIdSrc[[x]][order(list_dtIdSrc[[x]]$duree)[1:nbDstMeasure],])
        }else if(optiMeasure == "distance")
        {
          list_dtIdSrcMin <- lapply(1:length(list_dtIdSrc), function (x) list_dtIdSrc[[x]][order(list_dtIdSrc[[x]]$distance)[1:nbDstMeasure],])
        }else
        {
          stop(simpleError("optiMeasure doit etre 'duree' ou 'distance'."))
        }
        
        res <- do.call(rbind,list_dtIdSrcMin)
        # on remet les -999999 en -60 et -1000
        res$duree[res$duree == 999999]  <- -60.0
        res$distance[res$distance == 999999] <- -1000.0
      }
 
      if(any(is.na(res))) res <- res[!is.na(res$ID),]

      res$ID <- c(1:nrow(res))
      row.names(res) <- res$ID
    }else
    {
      res <- NULL
    }
  }else
  {
    res <- NULL
  }

  return(res)
}

#' @name mapRoutesProp
#'
#' @title Visualiser sur une carte les traces avec une epaisseur variable
#'
#' @description La fonction mapRoutesProp permet de visualiser les tracés avec une épaisseur variable selon le nombre de passages par tronçon de route.
#'
#' @param res liste d'objets sf ou data.frame. Les formats sp sont convertis en objet sf.
#' @param fonds liste d'objets sf.  Les formats sp sont convertis en objet sf.
#' @param nbLargeurs numérique. Nombre de tracés de largeurs différentes. Par défaut 5.
#' @param nbFlux vecteur numérique. Nombre de flux (ou de trajets) par tracé. Par défaut 1.
#' @param opaciteOSM numérique. Entre 0 et 1, opacité du fond OpenStreetMap. Par défaut 0.5.
#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
#' @param mapProxy objet leaflet ou leaflet_proxy. Pour l'intégration des fonctions leaflet dans les applications shiny. Par defaut NULL.
#'
#' @return une liste de deux éléments : un objet leaflet et un objet sf LINESTRING ou MULTILINESTRING.
#'
#' @details Plus le nombre de trajets à représenter est important, plus le temps de calcul sera élevé.
#'
#' En entrée, l'objet res doit être une liste de résultats de la fonction metricOsrmRoute. Les résultats peuvent être des objets sf ou data.frame selon le choix du paramètre returnclass de metricOsrmRoute.
#'
#' Pour optimiser les temps de calcul, il est préférable de choisir returnclass = NULL pour que la fonction metricOsrmRoute retourne un data.frame de coordonnées pour chaque trajet.
#'
#' En sortie, la fonction mapRoutesProp renvoie une liste de deux éléments :
#'
#' - la carte leaflet qu'il est possible d'afficher directement dans le viewer ;
#'
#' - un objet sf, qui indique le poids (colonne weight) de chaque tronçon de route et sa largeur (colonne classes).
#'
#' A partir de cet objet sf, il est possible de filtrer les poids pour ne représenter que des tronçons pertinents.
#' Par exemple, les routes étant empruntées plus de 5 fois (weight > 5).
#'
#' Pour une visualisation sur une carte des tracés de routes après avoir appliqué un filtre sur les poids, vous pouvez utiliser la fonction mapRoutes.
#'
#' La colonne classes permet de modifier la largeur des tronçons de route par poids.
#'
#' L'argument nbLargeurs permet de choisir le nombre de largeurs différentes pour l'ensemble des tracés.
#'
#' L'argument nbFlux permet de renseigner le nombre de flux pour chaque tracé. Par défaut, chaque tracé correspond à un trajet.
#'
#' @importFrom shiny showModal modalDialog HTML withProgress incProgress removeModal
#' @importFrom sf st_sf st_sfc st_as_sf st_transform st_bbox st_geometry st_length st_coordinates st_multilinestring st_linestring st_line_merge st_combine st_collection_extract
#' @importFrom leaflet leaflet invokeMethod fitBounds addScaleBar addPolygons addPolylines leafletOptions tileOptions getMapData pathOptions scaleBarOptions clearGroup
#' @importFrom methods is
#' @importFrom classInt classIntervals
#' @importFrom dplyr group_by summarise n '%>%' 
#' @importFrom rlang .data
#' @importFrom stringr str_split
#' @export
#'
#' @examples
#' # Specification d'un serveur osrm obligatoire pour executer les exemples
#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
#'
#' # Specification du profil
#' options(osrm.profile = "driving")
#'
#' # Calcul de deux traces de route.
#' dt1_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                 lat = 46.15),
#'                               dst = data.frame(lon = 4.72,
#'                                                 lat = 45.92),
#'                               overview = "full",
#'                               returnclass = NULL)
#'
#' dt2_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                 lat = 46.15),
#'                               dst = data.frame(lon = 4.82,
#'                                                 lat = 45.85),
#'                               overview = "full",
#'                               returnclass = NULL)
#'
#' # Visualisation des deux traces de route.
#' # Le 1er trace est emprunte 2 fois, le second 3 fois.
#' # Le trace commun est donc emprunte 5 fois.
#' mapRoutesProp(res = list(dt1_route_f[,c(ncol(dt1_route_f)-1,ncol(dt1_route_f))],
#'                          dt2_route_f[,c(ncol(dt2_route_f)-1,ncol(dt2_route_f))]),
#'               nbLargeurs = 3,
#'               nbFlux = c(2,3))
#'
mapRoutesProp <- function(res, fonds = NULL, nbLargeurs = 5, nbFlux = 1, opaciteOSM = 0.5, interactive = FALSE, mapProxy = NULL)
{
  if(!is.list(res))
  {
    stop(simpleError("res doit \u00eatre une liste d'objets sf ou data.frame."))
    
  }
  if(any(class(res[[1]])=="data.table") )
  {
    warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
    for(i in 1:length(res))
    {
      res[[i]] <- as.data.frame( res[[i]])
    }
  }  
  if(methods::is(res[[1]], "Spatial")|methods::is(fonds[[1]], "Spatial"))
  {
    warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
  }
  if(!any(class(res[[1]]) == "data.frame" | testSf(res[[1]]) |methods::is(res[[1]], "Spatial")))
  {
    stop(simpleError("res doit \u00eatre une liste d'objets sf ou data.frame."))
  }
  if(!is.null(fonds))
  {
    if(!is.list(fonds))
    {
      stop(simpleError("fonds doit \u00eatre une liste d'objets sf."))
    }
    for(i in 1:length(fonds))
    {
      # si fonds est un objet sp, on le transforme d'abord en objet sf
      if (methods::is(fonds[[i]], "Spatial"))
      {
        fonds[[i]] <- sf::st_as_sf(x = fonds[[i]])
      }
      fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)
    }
    if(!any(testSf(fonds[[1]]) ))
    {
      stop(simpleError("fonds doit \u00eatre une liste d'objets sf."))
    }
  }

  if(!is.null(mapProxy))
  {
    if(any(class(mapProxy) %in% "leaflet_proxy")) # Contexte shiny/proxy
    {
      leaflet::clearGroup(mapProxy,
                          group = "carte_routes_prop")
    }
  }

  if(is.null(mapProxy) | (!is.null(mapProxy) & is.character(mapProxy)))
  {
    if(!is.null(fonds))
    {
      for(i in 1:length(fonds))
      {
        # si fonds est un objet sp, on le transforme d'abord en objet sf
        if (methods::is(fonds[[i]], "Spatial"))
        {
          fonds[[i]] <- sf::st_as_sf(x = fonds[[i]])
        }
        fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)
      }
    }
    
    # si res est un objet sp, on le transforme d'abord en objet sf
    if (methods::is(res[[1]], "Spatial")) {
      for(i in 1:length(res))
      {
        res[[i]] <- sf::st_as_sf(x = res[[i]])
      }
    }
    
    if(methods::is(res[[1]], "sf"))
    {
      if(interactive)
      {
        shiny::showModal(shiny::modalDialog(shiny::HTML("<i class=\"fa fa-spinner fa-spin fa-2x fa-fw\"></i><font size=+1>Calcul des routes proportionnelles...</font> "), size = "m", footer = NULL, style = "color: #fff; background-color: #337ab7; border-color: #2e6da4"))

        shiny::withProgress(message = "Calculs en cours... ",{

          res <- do.call(rbind,res)

          geom_L93 <- sf::st_transform(res, crs=2154)
          geom_L93$length <- as.numeric(sf::st_length(geom_L93))
          geom_L93 <- geom_L93[order(geom_L93$length, decreasing = T),]
          geom_L93 <- sf::st_transform(res, crs=4326)

          couples <- lapply(1:(nrow(geom_L93)), function(x){

            shiny::incProgress(1/(nrow(geom_L93)+4))

            coord_un_trace <- as.data.frame(unique(sf::st_coordinates(geom_L93[x,])[,1:2]))

            couples_un_trace <- data.frame(id = x, cbind(coord_un_trace[-nrow(coord_un_trace),], coord_un_trace[-1,]))
            names(couples_un_trace) <- c("id", "X1", "Y1", "X2", "Y2")
            couples_un_trace
          })

          shiny::incProgress(1/(nrow(geom_L93)+4))

          couples <- do.call(rbind,couples)

          if(length(nbFlux) == 1 && nbFlux == 1){
            couples_poids <- couples %>%
              dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
              dplyr::summarise(NB = dplyr::n())

            couples_poids$IDS <- 0
            shiny::incProgress(1/(nrow(geom_L93)+4))
          }else{
            couples_poids <- couples %>%
              dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
              dplyr::mutate(IDS = paste(unique(.data$id), collapse = "-")) %>%
              dplyr::mutate(IDS = paste0(.data$IDS,"-0")) %>%
              dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2,.data$IDS) %>%
              dplyr::ungroup()

            list_ids <- lapply(sapply(stringr::str_split(couples_poids$IDS, "-"), function(x) x),FUN=as.numeric)
            nbs <- round(sapply(list_ids, function(x) sum(nbFlux[x], na.rm = TRUE)),0)

            couples_poids <- couples_poids %>% dplyr::mutate(NB = nbs)

            rm(list_ids,nbs)
            shiny::incProgress(1/(nrow(geom_L93)+4))
          }

          couples_poids <- couples_poids[order(couples_poids$NB),]
          poids_troncon <- unique(couples_poids[,c("IDS","NB")])
          graph_poids <- list()
          shiny::incProgress(1/(nrow(geom_L93)+4))

          graph_poids <- lapply(1:nrow(poids_troncon), function(x){

            un_poids <- couples_poids[couples_poids$NB %in% poids_troncon[x,"NB"],c("X1","Y1","X2","Y2")]
            aa <- unlist(apply(un_poids, 1, list), recursive=F)
            aa <- lapply(aa, function(y) matrix(as.numeric(y),byrow=T,ncol=2))

            sf::st_sf(geometry=sf::st_sfc(sf::st_line_merge(sf::st_combine(sf::st_geometry(sf::st_multilinestring(aa)))), crs=4326),weight=poids_troncon[x,"NB"],idTrace=poids_troncon[x,"IDS"])

          })

          graph_poids <- do.call(rbind,graph_poids)
          names(graph_poids) <- c("weight","idTrace","geometry")
          if(length(unique(graph_poids$idTrace)) == 1)
          {
            if(unique(graph_poids$idTrace) == 0) graph_poids <- graph_poids[,c("weight","geometry")]
          }
          graph_poids <- sf::st_transform(graph_poids, crs=4326)

          shiny::incProgress(1/(nrow(geom_L93)+4))
        })

        shiny::removeModal()
      }else
      {
        res <- do.call(rbind,res)

        geom_L93 <- sf::st_transform(res, crs=2154)
        geom_L93$length <- as.numeric(sf::st_length(geom_L93))
        geom_L93 <- geom_L93[order(geom_L93$length, decreasing = T),]
        geom_L93 <- sf::st_transform(res, crs=4326)

        pb3 <- progress::progress_bar$new(
          format = "Calcul des routes proportionnelles... : [:bar] :percent :elapsed",
          total = nrow(geom_L93)+4, clear = FALSE, width= 60
        )

        pb3$tick(0)

        couples <- lapply(1:(nrow(geom_L93)), function(x){

          coord_un_trace <- as.data.frame(unique(sf::st_coordinates(geom_L93[x,])[,1:2]))

          couples_un_trace <- data.frame(id = x, cbind(coord_un_trace[-nrow(coord_un_trace),], coord_un_trace[-1,]))
          names(couples_un_trace) <- c("id", "X1", "Y1", "X2", "Y2")

          pb3$tick()

          couples_un_trace
        })

        couples <- do.call(rbind,couples)

        if(length(nbFlux) == 1 && nbFlux == 1){
          couples_poids <- couples %>%
            dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
            dplyr::summarise(NB = dplyr::n())

          couples_poids$IDS <- 0

          pb3$tick()
        }else{
          couples_poids <- couples %>%
            dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
            dplyr::mutate(IDS = paste(unique(.data$id), collapse = "-")) %>%
            dplyr::mutate(IDS = paste0(.data$IDS,"-0")) %>%
            dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2,.data$IDS) %>%
            dplyr::ungroup()

          list_ids <- lapply(sapply(stringr::str_split(couples_poids$IDS, "-"), function(x) x),FUN=as.numeric)
          nbs <- round(sapply(list_ids, function(x) sum(nbFlux[x], na.rm = TRUE)),0)

          couples_poids <- couples_poids %>% dplyr::mutate(NB = nbs)

          rm(list_ids,nbs)

          pb3$tick()
        }

        couples_poids <- couples_poids[order(couples_poids$NB),]
        poids_troncon <- unique(couples_poids[,c("IDS","NB")])
        graph_poids <- list()
        pb3$tick()

        graph_poids <- lapply(1:nrow(poids_troncon), function(x){

          un_poids <- couples_poids[couples_poids$NB %in% poids_troncon[x,"NB"],c("X1","Y1","X2","Y2")]
          aa <- unlist(apply(un_poids, 1, list), recursive=F)
          aa <- lapply(aa, function(y) matrix(as.numeric(y),byrow=T,ncol=2))

          sf::st_sf(geometry=sf::st_sfc(sf::st_line_merge(sf::st_combine(sf::st_geometry(sf::st_multilinestring(aa)))), crs=4326),weight=poids_troncon[x,"NB"],idTrace=poids_troncon[x,"IDS"])

        })

        pb3$tick()

        graph_poids <- do.call(rbind,graph_poids)
        names(graph_poids) <- c("weight","idTrace","geometry")
        if(length(unique(graph_poids$idTrace)) == 1)
        {
          if(unique(graph_poids$idTrace) == 0) graph_poids <- graph_poids[,c("weight","geometry")]
        }
        graph_poids <- sf::st_transform(graph_poids, crs=4326)
        pb3$tick()
      }
    }

    if(any(class(res) %in% "list" & class(res[[1]]) %in% "data.frame"))
    {
      ### A partir d'un objet data.frame

      if(interactive)
      {
        shiny::showModal(shiny::modalDialog(shiny::HTML("<i class=\"fa fa-spinner fa-spin fa-2x fa-fw\"></i><font size=+1>Calcul des routes proportionnelles...</font> "), size = "m", footer = NULL, style = "color: #fff; background-color: #337ab7; border-color: #2e6da4"))

        shiny::withProgress(message = "Calculs en cours...  ",{

          couples <- lapply(1:length(res), function(x){

            shiny::incProgress(1/(length(res)+4))

            coord_un_trace <- unique(res[[x]][,c(ncol(res[[x]])-1, ncol(res[[x]]))])
            coord_un_trace <- data.frame(id=x,coord_un_trace[-nrow(coord_un_trace),],coord_un_trace[-1,])
            names(coord_un_trace) <- c("id","X1","Y1","X2","Y2")
            coord_un_trace

          })

          couples <- do.call(rbind,couples)

          shiny::incProgress(1/(length(res)+4))

          if(length(nbFlux) == 1 && nbFlux == 1){
            couples_poids <- couples %>%
              dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
              dplyr::summarise(NB = dplyr::n())

            couples_poids$IDS <- 0
            shiny::incProgress(1/(length(res)+4))
          }else{
            couples_poids <- couples %>%
              dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
              dplyr::mutate(IDS = paste(unique(.data$id), collapse = "-")) %>%
              dplyr::mutate(IDS = paste0(.data$IDS,"-0")) %>%
              dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2,.data$IDS) %>%
              dplyr::ungroup()

            list_ids <- lapply(sapply(stringr::str_split(couples_poids$IDS, "-"), function(x) x),FUN=as.numeric)
            nbs <- round(sapply(list_ids, function(x) sum(nbFlux[x], na.rm = TRUE)),0)

            couples_poids <- couples_poids %>% dplyr::mutate(NB = nbs)

            rm(list_ids,nbs)
            shiny::incProgress(1/(length(res)+4))
          }

          couples_poids <- couples_poids[order(couples_poids$NB),]
          poids_troncon <- unique(couples_poids[,c("IDS","NB")])
          graph_poids <- list()
          shiny::incProgress(1/(length(res)+4))

          graph_poids <- lapply(1:nrow(poids_troncon), function(x){

            un_poids <- couples_poids[couples_poids$NB %in% poids_troncon[x,"NB"],c("X1","Y1","X2","Y2")]
            aa <- unlist(apply(un_poids, 1, list), recursive=F)
            aa <- lapply(aa, function(y) matrix(as.numeric(y),byrow=T,ncol=2))

            sf::st_sf(geometry=sf::st_sfc(sf::st_line_merge(sf::st_combine(sf::st_geometry(sf::st_multilinestring(aa)))), crs=4326),weight=poids_troncon[x,"NB"],idTrace=poids_troncon[x,"IDS"])

          })

          graph_poids <- do.call(rbind,graph_poids)
          names(graph_poids) <- c("weight","idTrace","geometry")
          if(length(unique(graph_poids$idTrace)) == 1)
          {
            if(unique(graph_poids$idTrace) == 0) graph_poids <- graph_poids[,c("weight","geometry")]
          }
          graph_poids <- sf::st_transform(graph_poids, crs=4326)

          shiny::incProgress(1/(length(res)+4))
        })

        shiny::removeModal()
      }else
      {
        pb3 <- progress::progress_bar$new(
          format = "Calcul des routes proportionnelles... : [:bar] :percent :elapsed",
          total = length(res)+4, clear = FALSE, width= 60
        )

        pb3$tick(0)

        couples <- lapply(1:length(res), function(x){

          coord_un_trace <- unique(res[[x]][,c(ncol(res[[x]])-1, ncol(res[[x]]))])
          coord_un_trace <- data.frame(id=x,coord_un_trace[-nrow(coord_un_trace),],coord_un_trace[-1,])
          names(coord_un_trace) <- c("id","X1","Y1","X2","Y2")

          pb3$tick()
          coord_un_trace
        })

        couples <- do.call(rbind,couples)

        if(length(nbFlux) == 1 && nbFlux == 1){
          couples_poids <- couples %>%
            dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
            dplyr::summarise(NB = dplyr::n())

          couples_poids$IDS <- 0
          pb3$tick()
        }else{
          couples_poids <- couples %>%
            dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2) %>%
            dplyr::mutate(IDS = paste(unique(.data$id), collapse = "-")) %>%
            dplyr::mutate(IDS = paste0(.data$IDS,"-0")) %>%
            dplyr::group_by(.data$X1,.data$Y1,.data$X2,.data$Y2,.data$IDS) %>%
            dplyr::ungroup()

          list_ids <- lapply(sapply(stringr::str_split(couples_poids$IDS, "-"), function(x) x),FUN=as.numeric)
          nbs <- round(sapply(list_ids, function(x) sum(nbFlux[x], na.rm = TRUE)),0)

          couples_poids <- couples_poids %>% dplyr::mutate(NB = nbs)

          rm(list_ids,nbs)

          pb3$tick()
        }

        couples_poids <- couples_poids[order(couples_poids$NB),]
        poids_troncon <- unique(couples_poids[,c("IDS","NB")])
        graph_poids <- list()
        pb3$tick()

        graph_poids <- lapply(1:nrow(poids_troncon), function(x){

          un_poids <- couples_poids[couples_poids$NB %in% poids_troncon[x,"NB"],c("X1","Y1","X2","Y2")]
          aa <- unlist(apply(un_poids, 1, list), recursive=F)
          aa <- lapply(aa, function(y) matrix(as.numeric(y),byrow=T,ncol=2))

          sf::st_sf(geometry=sf::st_sfc(sf::st_line_merge(sf::st_combine(sf::st_geometry(sf::st_multilinestring(aa)))), crs=4326),weight=poids_troncon[x,"NB"],idTrace=poids_troncon[x,"IDS"])

        })
        pb3$tick()

        graph_poids <- do.call(rbind,graph_poids)
        names(graph_poids) <- c("weight","idTrace","geometry")
        if(length(unique(graph_poids$idTrace)) == 1)
        {
          if(unique(graph_poids$idTrace) == 0) graph_poids <- graph_poids[,c("weight","geometry")]
        }
        graph_poids <- sf::st_transform(graph_poids, crs=4326)

        pb3$tick()
      }
    }

    #################################
    ### Visualisation de la carte ###
    #################################

    if(is.null(getOption("urlTemplate")) | is.null(getOption("attribution")))
    {
      options(urlTemplate = "http://{s}.tile.openstreetmap.fr/osmfr/{z}/{x}/{y}.png")
      options(attribution = paste0("Insee, distancier Metric-OSRM, \u00a9 les contributeurs d'<a href='https://www.openstreetmap.org/copyright'>OpenStreetMap</a> et du <a href='http://project-osrm.org/'>projet OSRM</a>"))
    }

    m <- leaflet::leaflet(padding = 0,
                          options = leaflet::leafletOptions(
                            preferCanvas = TRUE,
                            transition = 2
                          )
    ) %>%

      leaflet::addTiles(urlTemplate = getOption("urlTemplate"),
                        attribution = getOption("attribution"),
                        options = leaflet::tileOptions(opacity = opaciteOSM)) %>%

      leaflet::fitBounds(lng1 = as.numeric(sf::st_bbox(graph_poids)[1]),
                         lat1 = as.numeric(sf::st_bbox(graph_poids)[2]),
                         lng2 = as.numeric(sf::st_bbox(graph_poids)[3]),
                         lat2 = as.numeric(sf::st_bbox(graph_poids)[4])) %>%

      leaflet::addScaleBar(position = 'bottomright',
                           options = leaflet::scaleBarOptions(metric = TRUE, imperial = FALSE))

    if(!is.null(fonds))
    {
      for(i in 1:length(fonds))
      {
        fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)

        m <- leaflet::addPolygons(map = m, data = fonds[[i]], opacity = 1,
                                  stroke = TRUE, color = "#606060", weight = 1,
                                  options = leaflet::pathOptions(clickable = F),
                                  fill = F,
                                  group = "carte_routes_prop_init")
      }
    }
  }else # Contexte shiny/proxy
  {
    graph_poids <- res[[1]]

    m <- mapProxy
  }

  if(interactive) shiny::showModal(shiny::modalDialog(shiny::HTML("<i class=\"fa fa-spinner fa-spin fa-2x fa-fw\"></i><font size=+1>Affichage de la carte...</font> "), size = "m", footer = NULL, style = "color: #fff; background-color: #337ab7; border-color: #2e6da4"))

  if(length(unique(graph_poids$weight)) > 1)
  {
    suppressWarnings(bornes <- classInt::classIntervals(as.numeric(graph_poids$weight),nbLargeurs,style="kmeans",rtimes=10,intervalClosure="left"))
    bornes <- bornes$brks

    for(i in 1:(length(bornes)-1))
    {
      graph_poids[graph_poids$weight>=bornes[i] & graph_poids$weight<bornes[i+1],"classes"] <- i
    }
    graph_poids[graph_poids$weight==bornes[i+1],"classes"] <- i
  }else
  {
    graph_poids[,"classes"] <- 1
  }

  graph_poids$col <- "#002C00"

  if("idTrace" %in% names(graph_poids))
  {
    graph_poids <- graph_poids[,c("weight","classes","col","idTrace","geometry")]
  }else
  {
    graph_poids <- graph_poids[,c("weight","classes","col","geometry")]
  }

  graph_poids <- suppressWarnings(sf::st_collection_extract(graph_poids, type = "LINESTRING"))

  m <- leaflet::addPolylines(map = m, data = graph_poids,
                             color = graph_poids$col,
                             weight = graph_poids$classes,
                             options = leaflet::pathOptions(clickable = T),
                             popup = paste0("Nombre de passages : ", graph_poids$weight),
                             opacity = 1,
                             group = "carte_routes_prop")

  if(interactive) shiny::removeModal()

  return(list(m, graph_poids))
}


# @name verifParamSrcDst
# @title Filtre la conformité des paramètres sources et destinations.
# @description Fonction interne qui réalise une grille si l'objet passé en paramètre est un objet sf.
# @param src Objet sf ou dataframe 2 ou 3 colonnes contenant deux vecteurs numériques sans valeurs manquantes.
# @param dst Objet sf ou dataframe 2 ou 3 colonnes contenant deux vecteurs numériques sans valeurs manquantes.
# @return Erreur si les paramètres ne sont pas conformes.
# @importFrom methods is
# @noRd
# @export
# @examples
# #erreur attendue car présence d'une 4 eme colonne pas autorisee
#  verifParamSrcDst(
#    src=data.frame(
#      code=c('adresse1','adresse2'),
#      lon=c(5.38589,5.41172),
#      lat=c(43.30134,43.27183),
#     aie=c('une_4eme_colonne','pas_autorisee')
# 
#    ),
#    dst=data.frame(
#      id='Traverse de la chapelle 13011 Marseille',
#      lon=c(5.51193), 
#      lat=c(43.30201)
#    )
#  )

verifParamSrcDst <- function(src,dst)
{
  msg_error1<-msg_error2<-msg_error3<-msg_error4<-msg_error5<-msg_error6<-msg_error7<-msg_error8<-msg_error9<-msg_error10 <- NULL
  msg_error11<-msg_error12<-msg_error13<-msg_error14 <- NULL
  
  if(is.vector(src))
  {
    if(length(src)!=3) msg_error1 <- "Le vecteur src doit comporter 3 valeurs (un identifiant puis les coordonnees lon, lat) / "
    if(any(is.na(src)) | !is.numeric(src)) msg_error2 <- "Le vecteur src doit \u00eatre numerique et sans valeur manquante / "
  }
  if(is.vector(dst))
  {
    if(length(dst)!=3) msg_error3 <- "Le vecteur dst doit comporter 3 valeurs (un identifiant puis les coordonnees lon, lat) / "
    if(any(is.na(dst)) | !is.numeric(dst)) msg_error4 <- "Le vecteur dst doit \u00eatre numerique et sans valeur manquante / "
  }
  if(any(class(src)=="data.frame") & length(class(src))==1)
  {
    if(ncol(src)!=3)
    {
      msg_error5 <- "Le data.frame src doit comporter 3 colonnes (un identifiant puis les coordonnees lon, lat) / "
    }else
    {
      if(any(is.na(src[,2])) | !is.numeric(src[,2])) msg_error6 <- "La colonne lon doit \u00eatre numerique et sans valeur manquante / "
      if(any(is.na(src[,3])) | !is.numeric(src[,3])) msg_error7 <- "La colonne lat doit \u00eatre numerique et sans valeur manquante / "
    }
  }
  if(any(class(dst)=="data.frame") & length(class(dst))==1)
  {
    if(ncol(dst)!=3)
    {
      msg_error8 <- "Le data.frame dst doit comporter 3 colonnes (un identifiant puis les coordonnees lon, lat) / "
    }else
    {
      if(any(is.na(dst[,2])) | !is.numeric(dst[,2])) msg_error9 <- "La colonne lon doit \u00eatre numerique et sans valeur manquante / "
      if(any(is.na(dst[,3])) | !is.numeric(dst[,3])) msg_error10 <- "La colonne lat doit \u00eatre numerique et sans valeur manquante / "
    }
  }
  if(testSf(src))
  {
    if(!any(class(sf::st_geometry(src)) %in% c("sfc_POINT","sfc_POLYGON","sfc_MULTIPOLYGON"))) msg_error11 <- "L'objet sf src doit etre un sfc_POINT, sfc_POLYGON ou sfc_MULTIPOLYGON / "
    if(ncol(src)<2) msg_error12 <- "L'objet sf src doit comporter au moins 2 colonnes (un identifiant et la geometry) / "
  }
  if(testSf(dst))
  {
    if(!any(class(sf::st_geometry(dst)) %in% c("sfc_POINT","sfc_POLYGON","sfc_MULTIPOLYGON"))) msg_error13 <- "L'objet sf dst doit etre un sfc_POINT, sfc_POLYGON ou sfc_MULTIPOLYGON / "
    if(ncol(dst)<2) msg_error14 <- "L'objet sf dst doit comporter au moins 2 colonnes (un identifiant et la geometry) / "
  }
 
  if(any(!is.null(msg_error1),!is.null(msg_error2),!is.null(msg_error3),!is.null(msg_error4),!is.null(msg_error5),!is.null(msg_error6),
         !is.null(msg_error7),!is.null(msg_error8),!is.null(msg_error9),!is.null(msg_error10),!is.null(msg_error11),!is.null(msg_error12),
         !is.null(msg_error13),!is.null(msg_error14)))
  {
    stop(simpleError(paste0(msg_error1,msg_error2,msg_error3,msg_error4,msg_error5,msg_error6,msg_error7,msg_error8,
                            msg_error9,msg_error10,msg_error11,msg_error12,msg_error13,msg_error14)))
  }
}

coordFormat <- function (res, src, dst, faceAFace = TRUE)
{
  sources <- data.frame()
  destinations <- data.frame()
  nbSrc <- length(res$sources)
  nbDst <- length(res$destinations)

  if(nbSrc==1)
  {
    aa <- lapply(1:nbSrc, function(x) sources <<- rbind(sources,data.frame(id=rep(src$id[x],nbDst),lon=rep(as.numeric(clean_coord(res$sources[[x]]$location[1])),nbDst),lat=rep(as.numeric(clean_coord(res$sources[[x]]$location[2])),nbDst), stringsAsFactors = FALSE)))
    aa <- lapply(1:nbDst, function(x) destinations <<- rbind(destinations,data.frame(id=dst$id[x],lon=as.numeric(clean_coord(res$destinations[[x]]$location[1])),lat=as.numeric(clean_coord(res$destinations[[x]]$location[2])), stringsAsFactors = FALSE)))
  }else if(nbDst==1)
  {
    aa <- lapply(1:nbSrc, function(x) sources <<- rbind(sources,data.frame(id=src$id[x],lon=as.numeric(clean_coord(res$sources[[x]]$location[1])),lat=as.numeric(clean_coord(res$sources[[x]]$location[2])), stringsAsFactors = FALSE)))
    aa <- lapply(1:nbDst, function(x) destinations <<- rbind(destinations,data.frame(id=rep(dst$id[x],nbSrc),lon=rep(as.numeric(clean_coord(res$destinations[[x]]$location[1])),nbSrc),lat=rep(as.numeric(clean_coord(res$destinations[[x]]$location[2]),nbSrc)), stringsAsFactors = FALSE)))
  }else{
    aa <- lapply(1:nbSrc, function(x) sources <<- rbind(sources,data.frame(id=src$id[x],lon=as.numeric(clean_coord(res$sources[[x]]$location[1])),lat=as.numeric(clean_coord(res$sources[[x]]$location[2])), stringsAsFactors = FALSE)))
    aa <- lapply(1:nbDst, function(x) destinations <<- rbind(destinations,data.frame(id=dst$id[x],lon=as.numeric(clean_coord(res$destinations[[x]]$location[1])),lat=as.numeric(clean_coord(res$destinations[[x]]$location[2])), stringsAsFactors = FALSE)))
  }

  if(!faceAFace)
  {
    sources <- sources[rep(1:nbSrc,nbDst),]
    destinations <- destinations[rep(1:nbDst, each=nbSrc),]
  }

  return(list(sources = sources, destinations = destinations))
}

#' @name mapRoutes
#'
#' @title Visualiser le trace des trajets sur une carte
#'
#' @description La fonction mapRoutes permet de visualiser les tracés des routes sur une carte.
#'
#' @param res liste d'objets sf (LINESTRING ou MULTILINESTRING). Les formats sp sont convertis en objet sf.
#' @param fonds liste d'objets sf. Les formats sp sont convertis en objet sf.
#' @param largeurRoute numérique. Largeur de la route.
#' @param opaciteOSM numérique. Entre 0 et 1, opacité du fond OpenStreetMap. Par défaut 0.5.
#' @param mapProxy objet leaflet ou leaflet_proxy. Pour l'intégration des fonctions leaflet dans les applications shiny. Par defaut NULL.
#' @return objet leaflet
#'
#' @details Plus le nombre de routes est important, plus le temps de calcul est élévé.
#'
#' En entrée, l'objet res doit être une liste d'objet sf avec une géométrie MULTILINESTRING.
#'
#' Cet objet peut être une liste de résultats (objets sf) de la fonction metricOsrmRoute renvoyant des tracés de route. 
#'
#' L'objet res peut également être le résultat de la fonction mapRoutesProp (2ème élément de la liste retournée).
#'
#' Cet objet comportera alors deux variables weight et classes (logiquement filtrés) pour représenter l'épaisseur des tracés sur la carte selon leur poids (voir fonction mapRoutesProp).
#' Dans ce cas, l'argument largeurRoute sera ignoré.
#'
#' En sortie, la fonction mapRoutes renvoie la carte leaflet qu'il est possible d'afficher directement dans le viewer.
#'
#' @importFrom sf st_as_sf st_bbox st_transform
#' @importFrom leaflet leaflet invokeMethod fitBounds addScaleBar addPolygons addPolylines leafletOptions tileOptions getMapData pathOptions scaleBarOptions clearGroup
#' @importFrom methods is
#' @export
#'
#' @examples
#' # Specification d'un serveur osrm obligatoire pour executer les exemples
#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
#'
#' # Specification du profil
#' options(osrm.profile = "driving")
#'
#' # Calcul de deux traces de route.
#' sf1_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                 lat = 46.15),
#'                               dst = data.frame(lon = 4.72,
#'                                                 lat = 45.92),
#'                               overview = "full",
#'                               returnclass = "sf")
#'
#' sf2_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                 lat = 46.15),
#'                               dst = data.frame(lon = 4.82,
#'                                                 lat = 45.85),
#'                               overview = "full",
#'                               returnclass = "sf")
#'
#' # Visualisation des deux traces de route.
#' mapRoutes(res = list(sf1_route_f, sf2_route_f))
#'
mapRoutes <- function(res, fonds = NULL, largeurRoute = 1, opaciteOSM = 0.5, mapProxy = NULL)
{
  
   if(!is.list(res))
   {
     stop(simpleError("res doit \u00eatre une liste (d'objets sf)"))
   }
   if (methods::is(fonds[[1]], "Spatial") | methods::is(res[[1]], "Spatial") )  {
     warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
   }
   if(!any(testSf(res[[1]])| methods::is(res[[1]], "Spatial")))
   {
     stop(simpleError("res doit \u00eatre une liste d'objets sf."))
   }
  if(!is.null(fonds))
  {
    if(!is.list(fonds))
    {
      stop(simpleError("fonds doit \u00eatre une liste (d'objets sf)."))
    }
    if(!any(testSf(fonds[[1]]) | methods::is(fonds[[1]], "Spatial")))
    {
      stop(simpleError("fonds doit \u00eatre une liste d'objets sf."))
    }
  }

  if(!is.null(mapProxy))
  {
    if(any(class(mapProxy) %in% "leaflet_proxy")) # Contexte shiny/proxy
    {
      leaflet::clearGroup(mapProxy,
                          group = "carte_routes")
    }
  }
  
  # si coord est un objet sp, on le transforme d'abord en objet sf
  for(i in 1:length(res))
  {
    # si fonds est un objet sp, on le transforme d'abord en objet sf
    if (methods::is(res[[i]], "Spatial"))
    {
      res[[i]] <- sf::st_as_sf(x = res[[i]])
    }
    res[[i]] <- sf::st_transform(res[[i]], crs = 4326)
  }
  
  res <- do.call(rbind,res)

  if(length(which(names(res) %in% c("weight", "classes"))) == 2)
  {
    weight <- res$classes
  }else
  {
    weight <- largeurRoute
  }

  if(length(which(names(res) %in% "col")) == 1)
  {
    col <- res$col
  }else
  {
    col <- "darkslateblue"
  }

  if(is.null(mapProxy) | (!is.null(mapProxy) & is.character(mapProxy)))
  {
    if(!is.null(fonds))
    {
      for(i in 1:length(fonds))
      {
        # si fonds est un objet sp, on le transforme d'abord en objet sf
        if (methods::is(fonds[[i]], "Spatial"))
        {
          fonds[[i]] <- sf::st_as_sf(x = fonds[[i]])
        }
        fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)
      }
    }

    if(is.null(getOption("urlTemplate")) | is.null(getOption("attribution")))
    {
      options(urlTemplate = "http://{s}.tile.openstreetmap.fr/osmfr/{z}/{x}/{y}.png")
      options(attribution = paste0("Insee, distancier Metric-OSRM, \u00a9 les contributeurs d'<a href='https://www.openstreetmap.org/copyright'>OpenStreetMap</a> et du <a href='http://project-osrm.org/'>projet OSRM</a>"))
    }

    m <- leaflet::leaflet(padding = 0,
                          options = leaflet::leafletOptions(
                                                            preferCanvas = TRUE,
                                                            transition = 2
                          )
        ) |>

    leaflet::addTiles(urlTemplate = getOption("urlTemplate"),
                      attribution = getOption("attribution"),
                      options = leaflet::tileOptions(opacity = opaciteOSM)) |>

    leaflet::fitBounds(lng1 = as.numeric(sf::st_bbox(res)[1]),
                       lat1 = as.numeric(sf::st_bbox(res)[2]),
                       lng2 = as.numeric(sf::st_bbox(res)[3]),
                       lat2 = as.numeric(sf::st_bbox(res)[4])) |>

    leaflet::addScaleBar(position = 'bottomright',
                         options = leaflet::scaleBarOptions(metric = TRUE, imperial = FALSE))

    if(!is.null(fonds))
    {
      for(i in 1:length(fonds))
      {
        fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)

        m <- leaflet::addPolygons(map = m, data = fonds[[i]], opacity = 1,
                                  stroke = TRUE, color = "#606060", weight = 1,
                                  options = leaflet::pathOptions(clickable = F),
                                  fill = F,
                                  group = "carte_routes_init")
      }
    }
  }else # Contexte shiny/proxy
  {
    m <- mapProxy
  }

  m <- leaflet::addPolylines(map = m, data = res, opacity = 100,
                             stroke = TRUE, color = col, weight = weight,
                             options = leaflet::pathOptions(clickable = F),
                             fill = F,
                             group = "carte_routes")

  return(m)
}

#' @name codeComToCoord
#'
#' @title Fonction de passage entre code commune INSEE et coordonnees au chef-lieu (chx) ou au centroide ou a un point sur la commune (pos).
#'
#' @description La fonction codeComToCoord permet de récupérer des coordonnées WGS84 (EPSG 4326) de plusieurs communes à partir des codes communes INSEE.
#'
#' Les points en sortie correspondent aux chefs-lieux de communes (chx), aux centroïdes ou à des points situés obligatoirement à l'intérieur de la commune,
#' calculés selon l'algorithme spécifique "point_on_surface".
#'
#' Selon la morphologie du contour de la commune, le centroïde peut être situé en-dehors de ses limites.
#' Pour que le point soit obligatoirement situé dans la commune, il faut alors spécifier type = "pos" (point_on_surface).
#'
#' Il est possible de choisir une géographie de 2017 à l'année de mise à jour du package.
#' Par exemple, si le package a été mis à jour en géographie 2024, 
#' il peut transformer en coordonnées lon/lat des codes communes des COG 2017 à 2024.
#' 
#' Pour information, il est possible de récupérer sous forme de table l'ensemble des codes communes Insee
#' d'un millésime donné avec leurs coordonnées centroïde, pos et chx. 
#' Pour ce faire il suffit de taper la commande metric.osrm:::tablePassage20xx 
#'
#' @param codeInsee vecteur texte.
#' @param geo texte. Par défaut, l'année courante.
#' @param type texte. Type de point souhaité. A choisir parmi "chx" par défaut (chef-lieu de la commune), "centroide" (barycentre) ou "pos" (point sur la surface).
#'
#' @return Un data.frame de trois colonnes "code", "lon" et "lat".
#'
#' @importFrom rio import
#' @export
#'
#' @examples
#' # Renvoie les coordonnees des chefs-lieux des communes de Montrouge (92049)
#' # et de Malakoff (92046) en geographie 2024.
#' codeComToCoord(codeInsee = c("92049","92046"),
#'                geo = "2024",
#'                type = "chx")
#'
#' # Renvoie les coordonnees des centroides des communes de Montrouge (92049)
#' # et de Malakoff (92046) en geographie 2024.
#' codeComToCoord(codeInsee = c("92049","92046"),
#'                geo = "2024",
#'                type = "centroide")
#'
#' # Renvoie les coordonnees "point_on_surface" des communes de Montrouge (92049)
#' # et de Malakoff (92046) en geographie 2024.
#' codeComToCoord(codeInsee = c("92049","92046"),
#'                geo = "2024",
#'                type = "pos")
#'
#' # Renvoie les coordonnees des chefs-lieux des communes d'Ancteville (50007)
#' # et de Saint-Sauveur-Lendelin (50550) en geographie 2018.
#' codeComToCoord(codeInsee = c("50007","50550"),
#'                geo = "2018",
#'                type = "chx")
#'
#' # Au 01/01/2019, les communes d'Ancteville (50007),
#' # de Saint-Sauveur-Lendelin (50550) et autres communes
#' # ont fusionne pour former Saint-Sauveur-Villages (50550).
#'
#' # Renvoie les coordonnees du chef-lieu de la commune
#' # de Saint-Sauveur-Villages (50550) en geographie 2019.
#' # et affiche un avertissement si le code commune est introuvable
#' # pour la geographie donnee.
#' codeComToCoord(codeInsee = c("50007","50550"),
#'                geo = "2019",
#'                type = "chx")
#'
codeComToCoord <- function(codeInsee, geo = "2024", type = "chx")
{
  # import de la table
  pointCom <- tryCatch({

    base::get(paste0("tablePassage",geo))

  },error = function(err){
    stop(simpleError(paste0("La g\u00e9ographie des communes n'est pas disponible pour le mill\u00e9sime ",geo)))
  })

  # filtre
  selectPoint <- pointCom[pointCom$code %in% unique(codeInsee),]

  # pour conserver l'ordre des codeInsee de la table en entree
  codeInsee <- data.frame(code=codeInsee, stringsAsFactors = FALSE)
  codeInsee$id <- c(1:nrow(codeInsee))
  coordCom <- merge(selectPoint, codeInsee, by = "code")
  coordCom <- coordCom[order(coordCom$id),]

  if(type == "centroide")
  {
    coordCom <- coordCom[c("code","centroid_lon","centroid_lat")]
  }else if(type == "pos")
  {
    coordCom <- coordCom[c("code","pos_lon","pos_lat")]
  }else
  {
    coordCom <- coordCom[c("code","chx_lon","chx_lat")]
  }

  names(coordCom) <- c("code","lon","lat")
  coordCom$lon <- round(coordCom$lon,5)
  coordCom$lat <- round(coordCom$lat,5)
  if(nrow(coordCom) > 0) row.names(coordCom) <- c(1:nrow(coordCom))

  if(nrow(codeInsee) != nrow(coordCom))
  {
    comNonGeoloc <- codeInsee[!codeInsee$code %in% coordCom$code, "code"]
    if(length(comNonGeoloc) == 1)
    {
      message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," commune non g\u00e9olocalis","\u00e9","e."))
      message(paste0("Veuillez v\u00e9rifier que le mill\u00e9sime de la g\u00e9ographie des codes communes "))
      message(paste0("correspond bien \u00e0 l'argument geo."))
    }
    if(length(comNonGeoloc) > 1)
    {
      message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," communes non g\u00e9olocalis","\u00e9","es."))
      message(paste0("Veuillez v\u00e9rifier que le mill\u00e9sime de la g\u00e9ographie des codes communes"))
      message(paste0("correspond bien \u00e0 l'argument geo. "))
    }
    message(paste0("Liste des codes communes non g\u00e9olocalis","\u00e9","es : "))
    message(paste(comNonGeoloc, collapse = ", "))
  }

  return(coordCom)
}

#' @name metricOsrmRoute
#'
#' @title Calculer le temps de trajet et la distance entre deux points ainsi que la geometrie du trace
#'
#' @description La fonction metricOsrmRoute permet de calculer le temps de trajet et la distance
#' entre deux points seulement et de récupérer le tracé de la route empruntée.#'
#' La fonction permet également d’ajouter des points intermédiaires entre la source (src) et 
#' la destination (dst) pour former un itinéraire.
#'
#' @param src vecteur numérique de longueur 2 (lon/lat) ou 3 (id/lon/lat), data.frame d'une ligne (colonnes lon/lat ou id/on/lat),
#' objet sf d'une ligne #'  
#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.

#' @param dst vecteur numérique de longueur 2 (lon/lat) ou 3 (id/lon/lat), data.frame d'une ligne (colonnes lon/lat ou id/on/lat),
#' objet sf d'une ligne   
#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.

#' @param loc data.frame (colonnes lon/lat ou id/on/lat), objet sf précisant les points intermédiaires du trajet.
#' #' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.

#' @param overview texte. "simplified" (par défaut), "full" ou NULL. Renvoie une géométrie simplifiée ou détaillée du tracé ou seulement le temps et la distance si NULL.
#' @param returnclass texte. "sf" ou NULL (par défaut). Renvoie un objet sf (LINESTRING) ou un data.frame de coordonnées si NULL.
#' @param exclude texte. Permet aux trajets d'éviter les autoroutes (“motorway”), les péages (“toll”) ou les ferries (“ferry”). Par défaut NULL.
#'
#' @return Un data.frame, un objet spatial sf (LINESTRING).
#'
#' @details Le choix de overview = "full" augmente le temps de calcul puisqu’il permet de renvoyer une géométrie
#' détaillée du tracé avec plus de coordonnées. Ce choix est toutefois obligatoire si l’on veut représenter
#' ensuite des routes proportionnelles à partir de la fonction routesProportionnelles.
#'
#' Pour cette usage, il est aussi conseillé de spécifier le paramètre returnclass = NULL pour diminuer le temps
#' de calcul. Les coordonnées des tronçons de route seront alors retournées sans la géométrie.
#'
#' L'argument loc peut être utilisé à la place de src et dst pour forcer le trajet à emprunter des points intermédiaires créant ainsi un itinéraire.
#' La première ligne de loc est le point de départ, la dernière ligne le point d’arrivée.
#' Ce dernier peut être identique au point de départ pour former une boucle de trajet.
#'
#' @importFrom sf st_sf st_as_sf st_as_sfc st_crs st_geometry st_centroid st_transform st_coordinates st_collection_extract
#' @importFrom RJSONIO fromJSON
#' @importFrom methods as
#' @importFrom gepaf decodePolyline
#' @export
#'
#' @examples
#' # Specification d'un serveur osrm obligatoire pour executer les exemples
#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
#'
#' # Specification du profil
#' options(osrm.profile = "driving")
#'
#' # Calcul d'un trace de route simplifie en data.frame.
#' dt_route_s <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                lat = 46.15),
#'                               dst = data.frame(lon = 4.72,
#'                                                lat = 45.92),
#'                               overview = "simplified")
#'
#' # Calcul d'un trace de route detaille en data.frame.
#' dt_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                lat = 46.15),
#'                               dst = data.frame(lon = 4.72,
#'                                                lat = 45.92),
#'                               overview = "full")
#'
#' # Calcul d'un trace de route simplifie en objet sf.
#' sf_route_s <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                lat = 46.15),
#'                               dst = data.frame(lon = 4.72,
#'                                                lat = 45.92),
#'                               overview = "simplified",
#'                               returnclass = "sf")
#'
#' plot(sf::st_geometry(sf_route_s), col = "red")
#'
#' # Calcul d'un trace de route detaille en objet sf.
#' sf_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
#'                                                lat = 46.15),
#'                               dst = data.frame(lon = 4.72,
#'                                                lat = 45.92),
#'                               overview = "full",
#'                               returnclass = "sf")
#'
#' plot(sf::st_geometry(sf_route_f), col = "blue", add = TRUE)
#'
#' # Calcul d'une boucle d'itineraire en trace simplifie et objet sf.
#' sf_route_s_boucle <- metricOsrmRoute(loc = data.frame(
#'                                              lon = c(4.92,4.83,4.72,4.89,4.92),
#'                                              lat = c(46.15,45.99,45.92,46.12,46.15)),
#'                                      overview = "simplified",
#'                                      returnclass = "sf")
#'
#' # boucle
#' plot(sf::st_geometry(sf_route_s_boucle))
#' # Points de depart et d'arrivee
#' plot(sf::st_point(c(4.92, 46.15)), col = "red", add = TRUE)
#' # Point intermediaire 1
#' plot(sf::st_point(c(4.83, 45.99)), col = "blue", add = TRUE)
#' # Point intermediaire 2
#' plot(sf::st_point(c(4.72, 45.92)), col = "green", add = TRUE)
#' # Point intermediaire 3
#' plot(sf::st_point(c(4.89, 46.12)), col = "orange", add = TRUE)
#'
metricOsrmRoute <-
function (src, dst, loc, overview = "simplified", returnclass = NULL, exclude = NULL)
  
{
  exclude_str <- ""
  if (missing(loc)) {
    src <- input_route(x = src, id = "src", single = TRUE)
    dst <- input_route(x = dst, id = "dst", single = TRUE)
    id1 <- src$id
    id2 <- dst$id
    if (!is.null(exclude)) {
      exclude <- paste(exclude, sep = "", collapse = ",")
      exclude_str <- paste("&exclude=", exclude, sep = "")
    }
    req <- paste(getOption("osrm.server"), "route/v1/",
                 getOption("osrm.profile"), "/", src$lon, ",", src$lat,
                 ";", dst$lon, ",", dst$lat, "?alternatives=false&geometries=polyline&steps=false&overview=",
                 tolower(overview), exclude_str, sep = "")
  }else{
    loc <- input_route(x = loc, single = FALSE)
    id1 <- loc$id1
    id2 <- loc$id2
    if (!is.null(exclude)) {
      exclude_str <- paste("&exclude=", exclude, sep = "")
    }
    req <- paste(getOption("osrm.server"), "route/v1/",
                 getOption("osrm.profile"), "/", paste0(apply(data.frame(loc$lon,
                                                                         loc$lat), MARGIN = 1, FUN = paste0, collapse = ","),
                                                        collapse = ";"), "?alternatives=false&geometries=polyline&steps=false&overview=",
                 tolower(overview), exclude_str, sep = "")
  }

  resRaw <- utils::URLencode(req)

  res <- RJSONIO::fromJSON(resRaw)

  if (overview == FALSE) {
    resultat <- c(duree = round(res$routes[[1]]$duration/60,2),
                  distance = round(res$routes[[1]]$distance/1000,3))
  }else{

    geodf <- gepaf::decodePolyline(res$routes[[1]]$geometry)[,c(2, 1)]
    resultat <- geodf

    if (!(is.null(returnclass))) {
      if (!(returnclass == "sf")){
        returnclass=NULL
        warning("le parametre returnclass a ete mis a sf. Les valeurs acceptes sont sf ou NULL")
      }
      rcoords <- paste0(geodf$lon, " ", geodf$lat, collapse = ", ")
      rgeom <- (sf::st_as_sfc(paste0("LINESTRING(", rcoords,
                                     ")")))
      rosf <- sf::st_sf(src = id1, dst = id2, duree = round(res$routes[[1]]$duration/60,2),
                        distance = round(res$routes[[1]]$distance/1000,3), geometry = rgeom,
                        crs = 4326, row.names = paste(id1, id2, sep = "_"), stringsAsFactors = FALSE)
      resultat <- rosf
    }else
    {
      resultat <- data.frame(src = id1, dst = id2, duree = round(res$routes[[1]]$duration/60,2),
                             distance = round(res$routes[[1]]$distance/1000,3), lon = resultat$lon, lat = resultat$lat,
                             stringsAsFactors = FALSE)
    }
  }

  return(resultat)
}

# @name osrmTableAllerRetour
# @title La fonction interne osrmTableAllerRetour.
# @description La fonction interne osrmTableAllerRetour permet de lancer osrmTableCartesien. 
# @inheritParams metriOsrmTable
# @return Un data.frame
# @noRd
# @export
# 
osrmTableAllerRetour <- function(src, dst, duree, distance, exclude, interactive)
{
  # Traitement des couples aller-retour

  src_comm <- src[src$id %in% dst$id,]
  dst_comm <- dst[dst$id %in% src$id,]

  if(nrow(src_comm) > 1)
  {
    # On calcule les couples AR puis sélection que des allers simples
    res_comm <- osrmTableCartesien(src = src_comm, dst = dst_comm, duree = duree, distance = distance, exclude = exclude, interactive = interactive)

    res_comm <- res_comm[order(res_comm$idSrc),]

    aa <- matrix(nrow = nrow(src_comm), ncol = nrow(src_comm))
    i <- 0
    for(j in 1:(nrow(src_comm)))
    {
      aa[,j] <- c(rep(1,i), rep(0,nrow(src_comm)-i))
      i <- i + 1
    }

    res_comm$id <- c(aa)
    res_comm <- res_comm[res_comm$id %in% 0,-ncol(res_comm)]
  }else
  {
    res_comm <- data.frame()
  }

  # Traitement des couples uniques

  src_diff <- src[!src$id %in% dst$id,]
  dst_diff <- dst[!dst$id %in% src$id,]

  if(nrow(src_diff) > 0 & nrow(dst_diff) > 0)
  {
    res_diff_diff <- osrmTableCartesien(src = src_diff, dst = dst_diff, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
  }else
  {
    res_diff_diff <- data.frame()
  }

  if(nrow(src_diff) > 0 & nrow(dst_comm) > 0)
  {
    res_diff_comm <- osrmTableCartesien(src = src_diff, dst = dst_comm, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
  }else
  {
    res_diff_comm <- data.frame()
  }

  if(nrow(src_comm) > 0 & nrow(dst_diff) > 0)
  {
    res_comm_diff <- osrmTableCartesien(src = src_comm, dst = dst_diff, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
  }else
  {
    res_comm_diff <- data.frame()
  }

  # Concaténation des tables

  res <- rbind(res_comm,res_comm_diff,res_diff_comm,res_diff_diff)

  res$ID <- 1:nrow(res)

  return(res)
}

# @name requeteOsrm_n1
# @title Calcul de la durée et/ou la distance.
# @description La fonction interne requeteOsrm_n1 permet de calculer la durée et la distance 
# entre un point et un groupe de points.
# @param src,dst data.frame n lignes et 3 colonnes id/lon/lat.
# @param idx_src valeur numérique.
# @param data.frame 1 ligne et 3 colonnes id/lon/lat.
# @param idx_dst vecteur numérique de longueur n où n est le nombre de couples pour la requête.
# @param measure vecteur caractères. Choix des options entre "duration" et "distance".
# @param exclude_str string. Exclu un type de route pour le calcul du trajet. 
# String formé pour la requête. Si exclude = NULL, exclude_str = "".
# @return list.
# @importFrom RJSONIO fromJSON
# @importFrom utils URLencode
# @noRd
# @export

requeteOsrm_1n <-
function(src, idx_src, dst, idx_dst, measure, exclude_str)
{
  if(!is.null(getOption("osrm.server")))
  {
    if(substr(getOption("osrm.server"),nchar(getOption("osrm.server")),nchar(getOption("osrm.server"))) == "/")
    {
      server <- getOption("osrm.server")
    }else
    {
      server <- paste0(getOption("osrm.server"), "/")
    }
  }else
  {
    server <- getOption("osrm.server")
  }

  req <- paste(paste0(server, "table/v1/",
                      getOption("osrm.profile"), "/"),
               paste0(clean_coord(as.numeric(src[,2])),",",clean_coord(as.numeric(src[,3])),";"),
               paste(clean_coord(as.numeric(dst[idx_dst,2])),clean_coord(as.numeric(dst[idx_dst,3])), sep = ",",collapse = ";"),
               "?sources=", paste(idx_src, collapse = ";"),
               "&destinations=", paste(idx_dst, collapse = ";"),
               "&annotations=", paste(measure, collapse = ","),
               exclude_str, sep = "")

  req <- utils::URLencode(req)

  res <- tryCatch({

    RJSONIO::fromJSON(req)

  },error = function(err){
    message("Un encombrement du r\u00e9seau a eu lieu mais le calcul continue.")

    # On attend 5 secondes que le réseau redevienne fluide avant de relancer la requête
    Sys.sleep(5)

    res <- tryCatch({

      RJSONIO::fromJSON(req)

    },error = function(err){
      message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x1.")

      # On attend maintenant 10 secondes que le réseau redevienne fluide avant de relancer la requête
      Sys.sleep(10)

      res <- tryCatch({

        RJSONIO::fromJSON(req)

      },error = function(err){
        message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x2.")

        # On attend 20 secondes que le réseau redevienne fluide avant de relancer la requête
        Sys.sleep(30)

        res <- tryCatch({

          RJSONIO::fromJSON(req)

        },error = function(err){
          message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x3.")

          # On attend 60 secondes que le réseau redevienne fluide avant de relancer la requête
          Sys.sleep(60)

          res <- tryCatch({

            RJSONIO::fromJSON(req)

          },error = function(err){
            message("Le r\u00e9seau ne s'est toujours pas lib\u00e9r\u00e9. Arr\u00eat du traitement.")
            message(err)
          })
        })
      })
    })
  })

  # Attente pour laisser le temps à la requête de faire l'aller-retour vers le serveur. Sinon risque de plantage de connexion.
  Sys.sleep(0.01)

  return(res)
}

calculs_faceaface <- function(couplesUniques, duree, distance, exclude, interactive)
{
  ### 1er groupe : groupes >= 1000 couples (1n ou n1) : calcul de 1 à n (n = 500 max)
  res_1g <- osrmTableGrpe1(couples = couplesUniques, duree = duree, distance = distance, exclude = exclude, interactive = interactive)

  if(!is.null(res_1g))
  {
    couplesUniques <- couplesUniques[-which(couplesUniques$ID %in% res_1g$ID),]
  }else
  {
    res_1g <- NULL
  }

  ### 2eme groupe : groupes entre 5 et 999 couples (1n ou n1) : calcul de 1 à n (n = 500 max)
  if(nrow(couplesUniques)>0)
  {
    res_2g <- osrmTableGrpe2(couples = couplesUniques, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
    if(!is.null(res_2g))
    {
      couplesUniques <- couplesUniques[-which(couplesUniques$ID %in% res_2g$ID),]
    }
  }else
  {
    res_2g <- NULL
  }

  ### 3eme groupe : groupes de 1 à 4 couple(s) en face a face (11) : calcul par croisement de n x n (n=100 max) puis conservation de la diagonale
  if(nrow(couplesUniques)>0)
  {
    nb_boucles <- (nrow(couplesUniques)%/%100)+1
    list_res_3g <- list()

    if(interactive)
    {
      shiny::withProgress(message = "Calculs en cours - 3/3 : ",{
        for(i in 1:nb_boucles)
        {
          if(nrow(couplesUniques)>=100)
          {
            nb_row <- 100
          }else
          {
            nb_row <- nrow(couplesUniques)%%100
          }
          if(nb_row > 0)
          {
            list_res_3g[[i]] <- osrmTableGrpe3(couples = couplesUniques[1:nb_row,], duree = duree, distance = distance, exclude = exclude)
            couplesUniques <- couplesUniques[-(1:nb_row),]
          }
          shiny::incProgress(1/nb_boucles)
        }
      })
    }else if(!interactive)
    {
      pb3 <- progress::progress_bar$new(
        format = "Calcul en cours - 3/3 : [:bar] :percent :elapsed",
        total = nb_boucles, clear = FALSE, width= 60
      )

      pb3$tick(0)

      for(i in 1:nb_boucles)
      {
        if(nrow(couplesUniques)>=100)
        {
          nb_row <- 100
        }else
        {
          nb_row <- nrow(couplesUniques)%%100
        }
        if(nb_row > 0)
        {
          list_res_3g[[i]] <- osrmTableGrpe3(couples = couplesUniques[1:nb_row,], duree = duree, distance = distance, exclude = exclude)
          couplesUniques <- couplesUniques[-(1:nb_row),]
        }
        pb3$tick()
      }
    }

    res_3g <- do.call(rbind,list_res_3g)
  }else
  {
    pb3 <- progress::progress_bar$new(
      format = "Calcul en cours - 3/3 : [:bar] :percent :elapsed",
      total = 2, clear = FALSE, width= 60
    )

    for (i in 1:2) {
      pb3$tick()
      Sys.sleep(0.2)
    }

    res_3g <- NULL
  }

  # Fusion des 3 tables
  res <- rbind(res_1g,res_2g)
  res <- rbind(res,res_3g)
  res <- res[order(res$ID),]
  row.names(res) <- c(1:nrow(res))

  return(res)
}

# @name osrmTable_11_nm
# @title La fonction interne osrmTable_11_nm Calcule la durée et/ou la distance en face à face ou par croisement.
# @description La fonction osrmTable_11_nm permet de calculer la durée et la distance 
# entre couples de points en face à face ou par croisement. 
# @inheritParams metriOsrmTable
# @return Un data.frame
# @noRd
# @export
# 
# @param faceAFace boolean. Si TRUE (par défaut), 
# Si FALSE, 
# 10000 couples max sont acceptés (nombre de points de src x nombre de points de dst < 10000),
# au-delà le traitement se fera en face à face.
#
# @return data.frame
osrmTable_11_nm <- function(src, dst, duree, distance, exclude, faceAFace = TRUE)
{
  list_res_duree <- list()
  list_res_distance <- list()
  res_destinations <- data.frame()
  res_sources <- data.frame()
  measure <- NULL
  if(duree) measure <- "duration"
  if(distance) measure <- c(measure,"distance")
  if(is.null(measure)) measure <- "duration"
  if(is.null(exclude))
  {
    exclude_str <- ""
  }else{
    exclude <- paste(exclude, sep = "", collapse = ",")
    exclude_str <- paste("&exclude=", exclude, sep = "")
  }

  if(!faceAFace) # produit cartesien
  {
    idx_src <- 1:nrow(src)
    idx_dst <- 1:nrow(dst)
  }else # couple a couple
  {
    if(nrow(src)<=nrow(dst)) # on cale sur src
    {
      idx_src <- 1:nrow(src)
      idx_dst <- 1:nrow(src)
    }else if(nrow(src)>nrow(dst))
    {
      idx_src <- 1:nrow(dst) # on cale sur dst
      idx_dst <- 1:nrow(dst)
    }
  }

  res <- requeteOsrm_11_nm(src = src, idx_src = idx_src, dst = dst, idx_dst = idx_dst, measure = measure, exclude_str = exclude_str)

  if(duree)
  {
    nc <- FALSE
    for(i in 1:length(res$durations))
    {
      for(j in 1:length(res$durations[[i]]))
      {
        if(!is.null(res$durations[[i]][[j]]))
        {
          if(res$durations[[i]][[j]] < 0)
          {
            res$durations[[i]][[j]] <- abs(res$durations[[i]][[j]])
          }
        }else
        {
          res$durations[[i]][[j]] <- -60
          nc <- TRUE
        }
      }
    }

    if(nc) res$durations <- lapply(res$durations, function(x)
                                  {
                                    if(is.list(x))
                                    {
                                      do.call(c,x)
                                    }else
                                    {
                                      x
                                    }
                                  })

    res_duree <- data.frame(res$durations)
    dimnames(res_duree) <- list(1:length(idx_dst),1:length(idx_src))
  }

  if(distance)
  {
    nc <- FALSE
    for(i in 1:length(res$distances))
    {
      for(j in 1:length(res$distances[[i]]))
      {
        if(!is.null(res$distances[[i]][[j]]))
        {
          if(res$distances[[i]][[j]] < 0)
          {
            res$distances[[i]][[j]] <- abs(res$distances[[i]][[j]])
          }
        }else
        {
          res$distances[[i]][[j]] <- -1000
          nc <- TRUE
        }
      }
    }

    if(nc) res$distances <- lapply(res$distances, function(x)
                                  {
                                    if(is.list(x))
                                    {
                                      do.call(c,x)
                                    }else
                                    {
                                      x
                                    }
                                  })

    res_distance <- data.frame(res$distances)
    dimnames(res_distance) <- list(1:length(idx_dst),1:length(idx_src))
  }

  coords <- coordFormat(res = res, src = src[1:length(idx_src),], dst = dst[1:length(idx_dst),], faceAFace = faceAFace)
  res_sources <- rbind(res_sources,coords$sources)
  res_destinations <- rbind(res_destinations,coords$destinations)

  names(res_sources) <- c("idSrc","lonSrc","latSrc")
  names(res_destinations) <- c("idDst","lonDst","latDst")

  if(duree)
  {
    if(faceAFace) # couple a couple
    {
      res_duree_save <- res_duree
      res_duree <- NULL
      for(i in 1:nrow(res_duree_save))
      {
        res_duree <- rbind(res_duree,data.frame(duree=res_duree_save[i,i]))
      }
    }
    else if(!faceAFace) # produit cartesien
    {
      res_duree <- data.frame(duree=do.call(c,list(t(res_duree))))
    }else
    {}
  }

  if(distance)
  {
    if(faceAFace) # couple a couple
    {
      res_distance_save <- res_distance
      res_distance <- NULL
      for(i in 1:nrow(res_distance_save))
      {
        res_distance <- rbind(res_distance,data.frame(distance=res_distance_save[i,i]))
      }
    }else if(!faceAFace) # produit cartesien
    {
      res_distance <- data.frame(distance=do.call(c,list(t(res_distance))))
    }else{}
  }

  res_11_nm <- cbind(res_sources,res_destinations)
  if(duree) res_11_nm <- cbind(res_11_nm,res_duree)
  if(distance) res_11_nm <- cbind(res_11_nm,res_distance)

  res_11_nm$idSrc <- as.character(res_11_nm$idSrc)
  res_11_nm$idDst <- as.character(res_11_nm$idDst)

  row.names(res_11_nm) <- c(1:nrow(res_11_nm))

  return(res_11_nm)
}

#' @name codeLauToCoord
#'
#' @title Fonction de passage entre code LAU de communes etrangeres et coordonnees au centroide ou a un point situe sur la commune.
#'
#' @description La fonction codeLauToCoord permet de récupérer des coordonnées WGS84 (EPSG 4326) de plusieurs communes étrangères à partir des codes LAU.
#'
#' Les points en sortie correspondent aux centroïdes ou à des points situés obligatoirement à l'intérieur de la commune,
#' calculés selon l'algorithme spécifique "point_on_surface". Selon la morphologie du contour de la commune, le centroïde peut être situé en-dehors de ses limites.
#' Pour que le point soit obligatoirement dans la commune, il faut alors spécifier type = "pos" (point_on_surface).
#'
#' Les codes pays, sur 2 caractères, sont consultables sur insee.fr (https://www.insee.fr/fr/information/2028273).
#'
#' Les codes LAU sont consultables sur le site d'eurostat (https://ec.europa.eu/eurostat/fr/web/nuts/local-administrative-units).
#' Les fonds de cartes des LAU sont disponibles ici (https://gisco-services.ec.europa.eu/distribution/v2/lau/download/).
#' Afin de garantir l'unicité du code, il est préférable d'utiliser le code GISCO, qui est la concaténation du code pays et du code LAU. 
#' En effet, un code LAU d'un pays peut être identique à celui d'un autre.
#' La liste exhaustive des codes gisco 2021 est disponibles en exécutant la commande :
#' code_gisco <- rio::import(system.file("extdata","listeCodesGISCO.csv", package = "metric.osrm"))
#' La table avec les coordonnees associées est disponibles en exécutant la commande :
#' coord_LAU2021 <- metric.osrm:::tablePassageLAU2021
#' 
#' Le champ couvert par codeLauToCoord contient les LAU des régions frontalières à la France, hors Andorre.
#' Les codes communes français sont ignorés. Utilisez, pour eux, la fonction codeComToCoord.
#'
#' @param codePays vecteur texte. Code pays sur 2 caractères selon la codification des pays et des territoires étrangers.
#' @param codeLau vecteur texte. Code LAU de communes étrangères.
#' @param geo texte. A choisir parmi "2020" ou "2021". Par défaut, l'année du dernier millésime disponible. 
#' @param type texte. Type de point souhaité. A choisir parmi "centroide" (barycentre de la commune) ou "pos" par défaut (point sur la commune).
#'
#' @return Un data.frame de trois colonnes "code", "lon" et "lat".
#'
#' @importFrom rio import
#' @export
#'
#' @examples
#' # Renvoie les coordonnees des points sur la surface des communes de Bruxelles (21004)
#' # de Liege (62063), de Luxembourg (0304) et de Stuttgard (08111000).
#' codeLauToCoord(codePays = c("BE","BE","LU","DE"),
#'                codeLau = c("21004","62063","0304","08111000"),
#'                geo = "2021",
#'                type = "pos")
#'
#' # Renvoie les coordonnees des centroides des communes des communes de Bruxelles (21004)
#' # de Liege (62063), de Luxembourg (0304) et de Stuttgard (08111000).
#' codeLauToCoord(codePays = c("BE","BE","LU","DE"),
#'                codeLau = c("21004","62063","0304","08111000"),
#'                geo = "2021",
#'                type = "centroide")
#'
#' # Ajout de Metz (57463) et de Strasbourg (67482).
#' codeLauToCoord(codePays = c("FR","FR","BE","BE","LU","DE"),
#'                codeLau = c("57463","67482","21004","62063","0304","08111000"),
#'                geo = "2021",
#'                type = "pos")
#'
#' # Ajout d'une commune etrangere hors champ de metric.osrm, Berlin (11000000).
#' codeLauToCoord(codePays = c("BE","BE","LU","DE","DE"),
#'                codeLau = c("21004","62063","0304","08111000","11000000"),
#'                geo = "2021",
#'                type = "pos")
#'
codeLauToCoord <- function(codePays, codeLau, geo = "2021", type = "pos")
{
  # import de la table
  pointCom <- tryCatch({
    
    base::get(paste0("tablePassageLAU",geo))
    
  },error = function(err){
    stop(simpleError(paste0("La g\u00e9ographie des LAU n'est pas disponible pour le mill\u00e9sime ",geo)))
  })

  # concatenation du code pays et du LAU : code gisco
  codeGisco <- paste0(codePays,"_",codeLau)

  # filtre
  selectPoint <- pointCom[pointCom$code %in% unique(codeGisco),]

  # pour conserver l'ordre des codeLau de la table en entree
  codeGisco <- data.frame(code=codeGisco, stringsAsFactors = FALSE)
  codeGisco$id <- c(1:nrow(codeGisco))
  coordCom <- merge(selectPoint, codeGisco, by = "code")
  coordCom <- coordCom[order(coordCom$id),]

  if(type == "pos")
  {
    coordCom <- coordCom[c("code","pos_lon","pos_lat")]
  }else
  {
    coordCom <- coordCom[c("code","centroid_lon","centroid_lat")]
  }

  names(coordCom) <- c("code","lon","lat")
  coordCom$lon <- round(coordCom$lon,5)
  coordCom$lat <- round(coordCom$lat,5)
  if(nrow(coordCom) > 0) row.names(coordCom) <- c(1:nrow(coordCom))

  if(nrow(codeGisco) != nrow(coordCom))
  {
    if(any(codePays %in% "FR"))
    {
      if(length(codePays[codePays %in% "FR"]) == 1)
      {
        message(paste0("[WARNING] Il y a ",length(codePays[codePays %in% "FR"])," commune fran","\u00e7","aise."))
        message(paste0("Pour elle seulement, veuillez utiliser la fonction codeComToCoord."))
      }
      if(length(codePays[codePays %in% "FR"]) > 1)
      {
        message(paste0("[WARNING] Il y a ",length(codePays[codePays %in% "FR"])," communes fran","\u00e7","aises."))
        message(paste0("Pour elles seulement, veuillez utiliser la fonction codeComToCoord."))
      }
    }

    comNonGeoloc <- codeGisco[!codeGisco$code %in% coordCom$code, "code"]
    comNonGeoloc <- comNonGeoloc[substr(comNonGeoloc,1,2) != "FR"]

    if(length(comNonGeoloc) > 0)
    {
      if(length(comNonGeoloc) == 1)
      {
        message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," commune non g\u00e9olocalis","\u00e9","e ou hors du champ de metric.osrm."))
      }
      if(length(comNonGeoloc) > 1)
      {
        message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," communes non g\u00e9olocalis","\u00e9","es ou hors du champ de metric.osrm."))
      }
      message(paste0("Liste des codes communes non g\u00e9olocalis","\u00e9","es ou hors-champ : "))
      message(paste(comNonGeoloc, collapse = ", "))
    }
  }

  return(coordCom)
}

#' @name statTable
#'
#' @title Calculer des statistiques sur les resultats de la fonction metricOsrmTable.
#'
#' @description La fonction statTable permet de calculer des statistiques simples sur les résultats de la fonction metricOsrmTable (comptages, valeurs min, valeurs max, moyennes, médianes).
#'
#' @param res data.frame. Résultat de la fonction metricOsrmTable avec les colonnes duree et/ou distance.
#'
#' @return Une liste de valeurs statistiques
#'
#' @details La table res doit correspondre à la table de résultats de la fonction metricOsrmTable avec les colonnes suivantes :
#' "ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst", "duree" et/ou "distance".
#'
#' Les statistiques calculées sont :
#'
#' - le nombre de couples calculés ;
#'
#' - le nombre de sources (src) ;
#'
#' - le nombre de destinations (dst).
#'
#' Pour la duree et la distance :
#'
#' - la valeur min ;
#'
#' - la valeur max ;
#'
#' - la moyenne ;
#'
#' - la médiane.
#'
#' @export
#'
#' @examples
#' # Reproduction d'une table de resultats avec la fonction metricOsrmTable
#' res <- data.frame(ID = c(1:4),
#'                   idSrc = c("1","2","3","4"),
#'                   lonSrc = c(5.39200,5.39242,5.37107,5.46476),
#'                   latSrc = c(43.28292,43.28368,43.47900,43.31246),
#'                   idDst = c("B","B","A","C"),
#'                   lonDst = c(5.38385,5.38385,5.47678,5.38219),
#'                   latDst = c(43.28571,43.28571,43.29028,43.44144),
#'                   duree = c(87.3,62.8,726.8,239.7),
#'                   distance = c(1103.3,942.7,8318.6,3252.6),
#'                   pop = c(1204,806,1164,976),
#'                   stringsAsFactors = FALSE)
#'
#' res_ind <- statTable(res = res)
#'
statTable <- function(res)
{
  measure <- c()
  if(any(names(res) %in% "duree")) measure <- c(measure,"duree")
  if(any(names(res) %in% "distance")) measure <- c(measure,"distance")

  if(!identical(names(res)[1:7], c("ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst"))) # si les 7 premieres colonnes ne correspondent pas, erreur
  {
    stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
  }
  if(is.null(measure)) # si il n'y a pas de colonnes duree et/ou distance, erreur
  {
    stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
  }
  if(!names(res)[8] %in% measure) # si la 8ème colonne n'est ni duree, ni distance, erreur
  {
    stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
  }

  if(any(measure %in% "duree") & any(measure %in% "distance"))
  {
    if(any(res$duree %in% -999999.00))
    {
      nbNonCalc <- length(res$duree[res$duree %in% -999999.00])
      if(nbNonCalc == 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (duree = -999999.00). Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs stats."))
      if(nbNonCalc > 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (duree = -999999.00). Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs stats."))

      res <- res[!res$duree %in% -999999.00,]
    }

    if(any(res$duree %in% 0) & any(res$distance %in% 0))
    {
      nbStables <- length(res$duree[res$duree %in% 0])
      if(nbStables == 1)
      {
        message(paste0("[INFO] Il y a ",nbStables," couple de stable dans la table de r\u00e9sultats (duree = 0)."))
        message(paste0("Il a \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
      }
      if(nbStables > 1)
      {
        message(paste0("[INFO] Il y a ",nbStables," couples de stables dans la table de r\u00e9sultats (duree = 0)."))
        message(paste0("Ils ont \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
      }
    }else
    {
      nbStables <- 0
    }
  }

  if(any(measure %in% "duree") & !any(measure %in% "distance"))
  {
    if(any(res$duree %in% -999999.00))
    {
      nbNonCalc <- length(res$duree[res$duree %in% -999999.00])
      if(nbNonCalc == 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (duree = -999999.00). Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs stats."))
      if(nbNonCalc > 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (duree = -999999.00). Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs stats."))

      res <- res[!res$duree %in% -999999.00,]
    }

    if(any(res$duree %in% 0))
    {
      nbStables <- length(res$duree[res$duree %in% 0])
      if(nbStables == 1)
      {
        message(paste0("[INFO] Il y a ",nbStables," couple de stable dans la table de r\u00e9sultats (duree = 0)."))
        message(paste0("Il a \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
      }
      if(nbStables > 1)
      {
        message(paste0("[INFO] Il y a ",nbStables," couples de stables dans la table de r\u00e9sultats (duree = 0)."))
        message(paste0("Ils ont \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
      }
    }else
    {
      nbStables <- 0
    }
  }

  if(any(measure %in% "distance") & !any(measure %in% "duree"))
  {
    if(any(res$distance %in% -999999.00))
    {
      nbNonCalc <- length(res$distance[res$distance %in% -999999.00])
      if(nbNonCalc == 1)
      {
        message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (distance = -999999.00)."))
        message(paste0("Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs stats."))
      }
      if(nbNonCalc > 1)
      {
        message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (distance = -999999.00)."))
        message(paste0("Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs stats."))
      }

      res <- res[!res$distance %in% -999999.00,]
    }

    if(any(res$distance %in% 0))
    {
      nbStables <- length(res$distance[res$distance %in% 0])
      if(nbStables == 1)
      {
        message(paste0("[INFO] Il y a ",nbStables," couple de stable dans la table de r\u00e9sultats (distance = 0)."))
        message(paste0("Il a \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
      }
      if(nbStables > 1)
      {
        message(paste0("[INFO] Il y a ",nbStables," couples de stables dans la table de r\u00e9sultats (distance = 0)."))
        message(paste0("Ils ont \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
      }
    }else
    {
      nbStables <- 0
    }
  }

  stats <- list()

  stats$nbCouples <- nrow(res)
  if(nbStables > 0) stats$nbStables <- nbStables
  stats$nbIdDep <- length(unique(as.data.frame(res)[,"idSrc"]))
  stats$nbIdArr <- length(unique(as.data.frame(res)[,"idDst"]))

  if(any(measure %in% "duree"))
  {
    if(nrow(res) > 0)
    {
      stats$tempsMax <- max(as.data.frame(res)[,"duree"], na.rm = TRUE)
      stats$tempsMin <- min(as.data.frame(res)[,"duree"], na.rm = TRUE)
      stats$tempsMoyenne <- round(mean(as.data.frame(res)[,"duree"], na.rm = TRUE),2)
      stats$tempsMediane <- round(stats::median(as.data.frame(res)[,"duree"], na.rm = TRUE),2)
    }else
    {
      stats$tempsMax <- "--"
      stats$tempsMin <- "--"
      stats$tempsMoyenne <- "--"
      stats$tempsMediane <- "--"
    }
  }

  if(any(measure %in% "distance"))
  {
    if(nrow(res) > 0)
    {
      stats$distanceMax <- max(as.data.frame(res)[,"distance"], na.rm = TRUE)
      stats$distanceMin <- min(as.data.frame(res)[,"distance"], na.rm = TRUE)
      stats$distanceMoyenne <- round(mean(as.data.frame(res)[,"distance"], na.rm = TRUE),3)
      stats$distanceMediane <- round(stats::median(as.data.frame(res)[,"distance"], na.rm = TRUE),3)
    }else
    {
      stats$distanceMax <- "--"
      stats$distanceMin <- "--"
      stats$distanceMoyenne <- "--"
      stats$distanceMediane <- "--"
    }
  }

  return(stats)
}

# @name requeteOsrm_n1
# @title Calcul de la durée et/ou la distance.
# @description La fonction interne requeteOsrm_n1 permet de calculer la durée et la distance 
# entre un groupe de points et un point.
# @param src,dst data.frame n lignes et 3 colonnes id/lon/lat.
# @param idx_src vecteur numérique de longueur n où n est le nombre de couples pour la requête.
# @param idx_dst valeur numérique.
# @param measure vecteur caractères. Choix des options entre "duration" et "distance".
# @param exclude_str string. Exclu un type de route pour le calcul du trajet. 
# String formé pour la requête. Si exclude = NULL, exclude_str = "".
# @return list.
# @importFrom RJSONIO fromJSON
# @importFrom utils URLencode
# @noRd
# @export
# 
requeteOsrm_n1 <-
function(src, idx_src, dst, idx_dst, measure, exclude_str)
{
  if(!is.null(getOption("osrm.server")))
  {
    if(substr(getOption("osrm.server"),nchar(getOption("osrm.server")),nchar(getOption("osrm.server"))) == "/")
    {
      server <- getOption("osrm.server")
    }else
    {
      server <- paste0(getOption("osrm.server"), "/")
    }
  }else
  {
    server <- getOption("osrm.server")
  }

  req <- paste(paste0(server, "table/v1/",
                      getOption("osrm.profile"), "/"),
               paste(clean_coord(src[idx_src,2]),clean_coord(src[idx_src,3]), sep = ",",collapse = ";"),
               paste0(";",clean_coord(dst[,2]),",",clean_coord(dst[,3])),
               "?sources=", paste(idx_src-1, collapse = ";"),
               "&destinations=", paste(idx_dst, collapse = ";"),
               "&annotations=", paste(measure, collapse = ","),
               exclude_str, sep = "")

  req <- utils::URLencode(req)

  res <- tryCatch({

    RJSONIO::fromJSON(req)

  },error = function(err){
    message("Un encombrement du r\u00e9seau a eu lieu mais le calcul continue.")

    # On attend 5 secondes que le réseau redevienne fluide avant de relancer la requête
    Sys.sleep(5)

    res <- tryCatch({

      RJSONIO::fromJSON(req)

    },error = function(err){
      message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x1.")

      # On attend maintenant 10 secondes que le réseau redevienne fluide avant de relancer la requête
      Sys.sleep(10)

      res <- tryCatch({

        RJSONIO::fromJSON(req)

      },error = function(err){
        message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x2.")

        # On attend 20 secondes que le réseau redevienne fluide avant de relancer la requête
        Sys.sleep(30)

        res <- tryCatch({

          RJSONIO::fromJSON(req)

        },error = function(err){
          message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x3.")

          # On attend 60 secondes que le réseau redevienne fluide avant de relancer la requête
          Sys.sleep(60)

          res <- tryCatch({

            RJSONIO::fromJSON(req)

          },error = function(err){
            message("Le r\u00e9seau ne s'est toujours pas lib\u00e9r\u00e9. Arr\u00eat du traitement.")
            message(err)
          })
        })
      })
    })
  })

  # Attente pour laisser le temps à la requête de faire l'aller-retour vers le serveur. Sinon risque de plantage de connexion.
  Sys.sleep(0.01)

  return(res)
}

# @name st_make_grid_metric
# @title Réalise une grille à partir d'un objet sf de géométrie POLYGON.
# @description Fonction interne qui réalise une grille si le paramètre est un objet sf.
# @param x Objet sf de géométrie POLYGON. 
# @return Objet sf sous forme de grille.
# @importFrom sf st_bbox st_crs st_polygon st_sf st_sfc
# @noRd
# @export
# 
st_make_grid_metric <- function (x,
                                 n = c(10, 10),
                                 offset = sf::st_bbox(x)[c("xmin", "ymin")],
                                 crs = sf::st_crs(x))
{
  bb <- sf::st_bbox(x)

  n <- rep(n, length.out = 2)
  nx <-n[1]
  ny <- n[2]

  xc <- seq(offset[1], bb[3], length.out = nx + 1)
  yc <- seq(offset[2], bb[4], length.out = ny + 1)

  ret <- vector("list", nx * ny)
  square <- function(x1, y1, x2, y2) sf::st_polygon(list(matrix(c(x1, x2, x2, x1, x1, y1, y1, y2, y2, y1), 5)))
  for (i in 1:nx) for (j in 1:ny) ret[[(j - 1) * nx +  i]] <- square(xc[i], yc[j], xc[i + 1], yc[j + 1])

  ret <- sf::st_sf(sf::st_sfc(ret, crs = crs))

  return(ret)
}

#' @name metricOsrmTable
#'
#' @title Calculer les temps de trajet et les distances entre deux groupes de points
#'
#' @description La fonction metricOsrmTable permet de calculer des temps de trajet et des distances entre deux points
#' ou deux groupes de points en face à face ou par croisement. 
#' Si le serveur ne répond pas trois fois alors que vous avez spécifié l'adresse d'un serveur et un profil, 
#' consultez l'article \href{https://metric-osrm.pages.lab.sspcloud.fr/metric-osrm-package/articles/G-installation.html}{installation}
#'
#' @param src,dst vecteur numérique de longueur 3 (id/lon/lat), data.frame (colonnes id/lon/lat) ou objet sf.
#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
#' @param duree booléen. Si TRUE (par défaut), la fonction retourne la durée.
#' @param distance booléen. Si TRUE (par défaut), la fonction retourne la distance.
#' @param faceAFace booléen. Si TRUE (par défaut), les couples de points sont pris en face à face
#' entre src et dst. Si src et dst n’ont pas la même dimension, les points en trop de la table la plus grande sont ignorés.
#' Si FALSE, les couples sont formés selon le croisement en produit cartésien entre src et dst.
#' @param allerRetour booléen. Si faceAFace = FALSE et allerRetour = TRUE (par défaut), tous les couples sont formés entre src et dst (hors stables). Ignoré si faceAFace = TRUE.
#' @param stable booléen. Si stable = FALSE (par défaut), les stables sont supprimés dans la table en sortie. Sinon (stable = TRUE), la durée et la distance renvoient 0.
#' @param rayonMax numérique. Si faceAFace = FALSE, distance maximale en kilomètres pour les couples formés entre src et dst.
#' @param nbDstVolOiseau numérique. Si faceAFace = FALSE, nombre maximal de dst par src les plus proches à vol d'oiseau.
#' @param nbDstMeasure numérique. Si faceAFace = FALSE, nombre maximal de dst par src les plus proches en temps ou en distance.
#' @param optiMeasure texte. Si faceAFace = FALSE et nbDstMeasure > 0, choix du critère des dst les plus proches par src : "duree" ou "distance".
#' @param emprise texte. Zone géographique contenant les coordonnées. A préciser si rayonMax > 0, sinon l'argument est ignoré.
#' A choisir parmi "FRM" (par défaut) pour la France métropolitaine et ses régions transfrontalières,
#' "971" pour la Guadeloupe, "972" pour la Martinique, "973" pour la Guyane, "974" pour la Réunion, "976" pour Mayotte ou "999" pour une autre zone.
#' @param exclude texte. Ce paramètre permet d'effectuer les calculs de trajet en évitant un type de route : 
#' les ferries ("ferry") option RECOMMANDEE car les données ne sont pas exhaustives, les autoroutes (“motorway”), les péages (“toll”) ou aucun type de route (exclude=NULL, paramètre par défaut). 
#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
#'
#' @return data.frame avec les colonnes "ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst", "duree" et/ou "distance".
#'
#' @details Les sources (src) correspondent aux points de départ et les destinations (dst) aux points d’arrivée.
#'
#' Les id doivent toujours être en 1ère position du vecteur ou en 1ère colonne du data.frame.
#'
#' Si src et dst sont des vecteurs ou des data.frame, les coordonnées doivent être dans le système
#' géographique non projeté WGS84 (longitude et latitude, EPSG : 4326).
#'
#' La fonction convertTo permet de convertir des coordonnees en WGS84 (EPSG : 4326).
#'
#' Les objets spatiaux sf peuvent être dans n’importe quel système, projeté ou non.
#' Mais en sortie, les coordonnées seront dans le système WGS84 (EPSG : 4326).
#'
#' Si faceAFace = FALSE et allerRetour = TRUE, tous les couples sont formés. Par exemple si scr = c(src_Pau,src_Agen) et dst = c(dst_Pau,dst_Agen),
#' alors les couples 'src_Pau' vers 'dst_Agen' et 'src_Agen' vers 'dst_Pau' seront calculés (hors stables 'src_Pau-dst_Pau' et 'src_Agen-dst_Agen').
#' Si faceAFace = FALSE et allerRetour = FALSE, un seul couple est calculé, de 'src_Pau' vers 'dst_Agen'.
#'
#' Les stables peuvent être supprimés de la table de résultats en spécifiant stable = FALSE. Si TRUE, les stables seront repérables avec les valeurs de durée et de distance à 0.
#'
#' Lorsque faceAFace = FALSE, les arguments rayonMax, nbDstVolOiseau, nbDstMeasure et optiMeasure permettent de filtrer les résultats selon la structure des src et dst.
#'
#' rayonMax et nbDstVolOiseau permettent de filtrer en amont les couples src->dst pour éviter des calculs vers le serveur inutiles et chronophages.
#'
#' nbDstMeasure et optiMeasure permettent de filtrer les résultats après le requêtage au serveur. Ne réduit donc pas les temps de calcul.
#'
#' Si faceAFace = TRUE, les arguments allerRetour, rayonMax, nbDstVolOiseau, nbDstMeasure et optiMeasure sont ignorés.
#'
#' Si le filtre rayonMax est utilisé (si rayonMax > 0), alors il est indispensable de préciser l'emprise de la zone couverte par les coordonnées.
#' Par défaut, l'emprise correspond à la France métropolitaine et ses régions transfrontalières (emprise = "FRM"). Le système de coordonnées projetées, utilisé alors pour effectuer
#' les calculs de distances à vol d'oiseau, est le Lambert93 (EPSG 2154). Pour les DOM, il faut préciser le code départemantal du DOM ("971","972","973","974" ou "976").
#' Pour information, les codes EPSG en vigueur dans les DOM sont 5490 pour la Guadeloupe et la Martinique, 2972 pour la Guyane, 2975 pour la Réunion et 4471 pour Mayotte.
#' Pour toutes autres zones, il faut alors préciser emprise = "999". Dans ce cas, la projection Mercator sera utilisée (EPSG 3395).
#'
#' Pour des besoins spécifiques, il est possible d’exclure un type de routes parmi les autoroutes, les
#' péages ou les ferries( ferries +bacs). Ces routes seront alors exclues des calculs de trajets.
#' Il est recommandé de toujours exclure les lignes de ferries présentes dans les données OpenStreetMap (option exclude="ferry") pour limiter
#' le champ aux trajets strictement par la route en voiture ; éviter les calculs entre îles et continent typiquement. 
#' Les données OSM assimilent  les bacs maritimes (bacs de Seine par exemple) et fluviaux à des lignes « classiques » de ferries.
#' Mais la complétude et la qualité des données OSM en termes de liaisons maritimes
#' et autres bacs de liaison ne sont pas garanties. Par ailleurs l’absence de données d’horaires de traversée
#'  fait que le temps de trajet est calculé sans attente (et sans temps de chargement/déchargement).

#' @importFrom sf st_as_sf st_crs st_collection_extract st_centroid st_transform st_coordinates st_geometry
#' @importFrom RJSONIO fromJSON
#' @importFrom RANN nn2
#' @export
#'
#' @examples
#' # Specification d'un serveur osrm obligatoire pour executer les exemples
#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
#'
#' # Specification du profil
#' options(osrm.profile = "driving")
#'
#' # Construction des sources et des destinations.
#' sources <-  data.frame(id = c("A","B","C"),
#'                        lon = c(4.92,4.86,4.72),
#'                        lat = c(46.15,46.08,45.92),
#'                        stringsAsFactors = FALSE)
#'
#' destinations <-data.frame(id = c("B","C","D"),
#'                           lon = c(4.86,4.72,4.67),
#'                           lat = c(46.08,45.92,45.83),
#'                           stringsAsFactors = FALSE)
#'
#' # 3 couples de points calcules en face a face.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 exclude = "ferry", # option recommandée
#'                 faceAFace = TRUE) # par defaut
#'
#' # 3 couples de points calcules selon le produit cartesien.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 exclude = "ferry", # option recommandée
#'                 faceAFace = FALSE)
#'
#' # 3 couples de points calcules selon le produit cartesien
#' # et avec les stables conserves.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 exclude = "ferry", # option recommandée
#'                 faceAFace = FALSE,
#'                 stable = TRUE)
#'
#' # 3 couples de points calcules selon le produit cartesien,
#' # sans les stables et sans aller-retour.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 faceAFace = FALSE,
#'                exclude = "ferry", # option recommandée
#'                 stable = FALSE,
#'                 allerRetour = FALSE)
#'
#' ### Utilisation des filtres
#'
#' # Construction des sources et des destinations.
#' sources <-  data.frame(id = c("C1","C2","C3"),
#'                        lon = c(4.92,4.86,4.72),
#'                        lat = c(46.15,46.08,45.92),
#'                        stringsAsFactors = FALSE)
#'
#' destinations <-data.frame(id = c("E1","E2","E3"),
#'                           lon = c(4.63,4.75,4.67),
#'                           lat = c(45.95,45.88,45.83),
#'                           stringsAsFactors = FALSE)
#'
#' ## Les sources et les destinations ne sont pas de meme nature.
#' ## Par exemple, les sources peuvent etre des carreaux
#' ## et les destinations des equipements.
#'
#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 exclude = "ferry",
#'                 faceAFace = FALSE,
#'                 stable = TRUE,
#'                 rayonMax = 40,
#'                 emprise = "FRM")
#' # Les distances calculees par la route peuvent etre superieures a 40km :
#' # le trajet par la route est forcement plus long en distance qu'a vol d'oiseau.
#'
#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src
#' # puis la plus proche parmi celles-ci.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 faceAFace = FALSE,
#'                 exclude = "ferry",
#'                 stable = TRUE,
#'                 rayonMax = 40,
#'                 nbDstVolOiseau = 1,
#'                 emprise = "FRM")
#' # Les stables, s'il y en a, doivent etre conserves
#' # car src et dst ne sont pas de meme nature.
#'
#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src
#' # puis les 2 dst les plus proches parmi celles-ci.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 faceAFace = FALSE,
#'                 exclude = "ferry",
#'                 stable = TRUE,
#'                 rayonMax = 40,
#'                 nbDstVolOiseau = 2,
#'                 emprise = "FRM")
#'
#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src
#' # puis les 2 dst les plus proches parmi celles-ci.
#' # Enfin, on conserve uniquement 1 dst la plus proche en temps de parcours par la route.
#' metricOsrmTable(src = sources,
#'                 dst = destinations,
#'                 faceAFace = FALSE,
#'                 exclude = "ferry",
#'                 stable = TRUE,
#'                 rayonMax = 40,
#'                 nbDstVolOiseau = 2,
#'                 nbDstMeasure = 1,
#'                 optiMeasure = "duree",
#'                 emprise = "FRM")
#'
metricOsrmTable <- function(src, dst, duree = TRUE, distance = TRUE, faceAFace = TRUE, allerRetour = TRUE, stable = FALSE, rayonMax = 0, nbDstVolOiseau = 0, nbDstMeasure = 0, optiMeasure = c("duree", "distance"), emprise = "FRM", exclude = NULL, interactive = FALSE)
{
  if(any(class(src)=="data.table") )
  {
    src<-as.data.frame(src)
    warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
  } 
  if(any(class(dst)=="data.table") )
  {
    dst<-as.data.frame(dst) 
    warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
  }  
  ### verification des parametres
  verifParamSrcDst(src = src, dst = dst)

  ### Conversion de src et dst en data.frame
  src <- convertToDf(objet = src)
  dst <- convertToDf(objet = dst)

  if(!faceAFace)
  {
    ### Suppression des points en doublon
    src <- unique(src)
    dst <- unique(dst)
  }

  if(faceAFace)
  {
    res <- osrmTableFaceAFace(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)

  }else if(!faceAFace & allerRetour & rayonMax == 0 & nbDstVolOiseau == 0)
  {
    res <- osrmTableCartesien(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)

  }else if(!faceAFace & !allerRetour & rayonMax == 0 & nbDstVolOiseau == 0)
  {
    res <- osrmTableAllerRetour(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)

  }else if(!faceAFace & (rayonMax > 0 | nbDstVolOiseau > 0))
  {
    ### Recuperation du code epsg a partir de l'emprise declaree
    code_epsg <- switch(emprise,
                        "FRM"="2154",# Lambert 93
                        "971"="5490",# UTM 20 N
                        "972"="5490",# UTM 20 N
                        "973"="2972",# UTM 22 N
                        "974"="2975",# UTM 40 S
                        "976"="4471",# UTM 38 S
                        "999"="3395") # Mercator

    res <- osrmTableFiltre(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, rayonMax = rayonMax, nbDstVolOiseau = nbDstVolOiseau, nbDstMeasure = nbDstMeasure, optiMeasure = optiMeasure, code_epsg = code_epsg, interactive = interactive)
  }

  if(is.null(res))
  {
    message(paste0("[WARNING] Aucun couple n'a \u00e9t\u00e9 calcul\u00e9."))
    message(paste0("V\u00e9rifiez que les filtres ne soient pas trop restrictifs"))
    message(paste0("ou que les sources et les destinations ne soient pas trop \u00e9loign","\u00e9","es."))
    return(NULL)
  }

  # Suppression des stables

  if(!stable)
  {
    if(any(res$duree %in% 0) & any(res$distance %in% 0)) res <- res[!res$duree == 0 & !res$distance == 0,]
  }

  if(nrow(res) > 0)
  {
    res <- res[order(res$idSrc),]
    res$ID <- 1:nrow(res)
    row.names(res) <- res$ID

    # Avertissement pour les couples non calculés

    message <- FALSE
    nbNonCalcules <- 0

    if(duree)
    {
      res$duree <- round(res$duree/60,2)

      if(!is.na(any(res$duree < 0)))
      {
        if(any(res$duree < 0))
        {
          nbNonCalcules <- nrow(res[res$duree < 0,])
          res[res$duree < 0, "duree"] <- -999999
          message <- TRUE
        }
      }
    }

    if(distance)
    {
      res$distance <- round(res$distance/1000,3)

      if(!is.na(any(res$distance < 0)))
      {
        if(any(res$distance < 0))
        {
          res[res$distance < 0, "distance"] <- -999999
          message <- TRUE
        }
      }
    }

    if(message)
    {
      if(nbNonCalcules == 1)
      {
        message(paste0("[WARNING] ",nbNonCalcules," couple n'a pas \u00e9t\u00e9 calcul\u00e9."))
        message(paste0("Il est rep\u00e9rable dans la table des r\u00e9sultats avec une dur","\u00e9","e et une distance \u00e0 -999999."))
        message(paste0("Pensez \u00e0 le retirer avant toute analyse de la table."))
      }
      if(nbNonCalcules > 1)
      {
        message(paste0("[WARNING] ",nbNonCalcules," couples n'ont pas \u00e9t\u00e9 calcul\u00e9s."))
        message(paste0("Ils sont rep\u00e9rables dans la table des r\u00e9sultats avec une dur","\u00e9","e et une distance \u00e0 -999999."))
        message(paste0("Pensez \u00e0 les retirer avant toute analyse de la table."))
      }
    }
  }else
  {
    message(paste0("[WARNING] Le table de r\u00e9sultats est vide."))
    message(paste0("Il n'y a que des couples de stables dans la table en entr","\u00e9","e et l'argument stable = FALSE."))
  }

  return(res)
}

# @name osrmTableGrpe2
# @title Calcul la durée et/ou la distance entre deux points.
# @description La fonction interne osrmTableGrpe2 permet de calculer la durée et la distance d'un point 
# vers un groupe de points ou d'un groupe de points vers un point. 
# Chaque groupe est composé d'au moins 2 points et moins de 1000 points.
# @param couples Un data.frame 7 colonnes "idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID".
# @param duree Un booleen. La fonction retourne la durée. Par défaut à TRUE.
# @param distance Un booleen. La fonction retourne la distance. Par défaut à TRUE.
# @param exclude Une chaine de carctère string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
# @return Un data.frame
# @importFrom shiny withProgress incProgress
# @importFrom progress progress_bar
# @noRd
# @export
osrmTableGrpe2 <-function(couples, duree, distance, exclude, interactive)
{
  names(couples) <- c("idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID")

  # on détermine laquelle des 2 colonnes on fera les calculs pour id unique
  # en plus de l'ID, il faut aussi les coordonnées pour s'assurer du bon nombre distinct de points
  lengthSrcId <- nrow(unique(couples[,c(1,2,3)]))
  lengthDstId <- nrow(unique(couples[,c(4,5,6)]))

  # on garde la liste la plus petite pour avoir un minimum de requêtes à envoyer
  if(lengthSrcId>=lengthDstId)
  {
    id <- 4
  }else if(lengthSrcId<lengthDstId)
  {
    id <- 1
  }else{}

  # Création de l'index
  count <- as.numeric(table(couples[,id]))
  table_idx <- data.frame(id=unique(sort(couples[,id])),COUNT=count, stringsAsFactors=F)
  table_idx_5_999 <- table_idx[table_idx$COUNT>=5,]

  list_res_1n_n1 <- list()

  if(nrow(table_idx_5_999)>0)
  {
    table_idx_5_999$ID2 <- c(1:nrow(table_idx_5_999))

    # Fusion de base avec table_idx pour récupérer l'idx
    couples_5_999 <- merge(couples,table_idx_5_999,by.x = names(couples)[id], by.y = "id")
    couples_5_999 <- couples_5_999[order(couples_5_999$COUNT),]

    list_id <- split(couples_5_999[,c("ID","idSrc","lonSrc","latSrc","idDst","lonDst",'latDst')],couples_5_999[,names(couples)[id]])

    table_idx_5_999 <- table_idx_5_999[rev(order(table_idx_5_999$COUNT)),]

    list_id <- list_id[table_idx_5_999$ID]

    if(interactive)
    {
      shiny::withProgress(message = "Calculs en cours - 2/3 : ",{
        for(i in 1:length(list_id))
        {
          list_res_1n_n1[[i]] <- calculs_faceaface_groupe2(id, dt_id = list_id[[i]], duree, distance, exclude)

          shiny::incProgress(1/length(list_id))
        }
      })
    }else if(!interactive)
    {
      pb2 <- progress::progress_bar$new(
        format = "Calcul en cours - 2/3 : [:bar] :percent :elapsed",
        total = length(list_id), clear = FALSE, width= 60
      )

      pb2$tick(0)

      for(i in 1:length(list_id))
      {
        list_res_1n_n1[[i]] <- calculs_faceaface_groupe2(id, dt_id = list_id[[i]], duree, distance, exclude)

        pb2$tick()
      }
    }else
    {}
  }

  res_2g <- do.call(rbind,list_res_1n_n1)

  if(is.null(res_2g))
  {
    pb2 <- progress::progress_bar$new(
      format = "Calcul en cours - 2/3 : [:bar] :percent :elapsed",
      total = 2, clear = FALSE, width= 60
    )

    for (i in 1:2) {
      pb2$tick()
      Sys.sleep(0.2)
    }
  }

  return(res_2g)
}

# @name osrmTableCartesien
# @title La fonction interne osrmTableCartesien.
# @description La fonction interne osrmTableCartesien permet de lancer osrmTable_11_nm.
# les couples sont formés à partir du croisement en produit cartésien entre src et dst. 10000 couples max sont acceptés (nombre de points de src x nombre de points de dst < 10000),
# au-delà le traitement se fera en face à face
# @inheritParams metriOsrmTable
# @importFrom shiny withProgress
# @importFrom progress progress_bar
# @return Un data.frame
# @noRd
# @export
# 
osrmTableCartesien <- function(src, dst, duree, distance, exclude, interactive)
{
  nb_boucles_src <- nrow(src)%/%100
  nb_boucles_dst <- nrow(dst)%/%100
  reste_src <- nrow(src)%%100
  reste_dst <- nrow(dst)%%100

  if(nrow(src) < 100)
  {
    nb_src <- nrow(src)
  }else
  {
    nb_src <- 100
  }

  if(nrow(dst) < 100)
  {
    nb_dst <- nrow(dst)
  }else
  {
    nb_dst <- 100
  }

  if(interactive)
  {
    shiny::withProgress(message = "Patientez le temps des calculs",{

      list_res <- list()
      k <- 1
      i <- 0
      if(nb_boucles_src > 0)
      {
        for(i in 1:nb_boucles_src)
        {
          j <- 0
          if(nb_boucles_dst > 0)
          {
            for(j in 1:nb_boucles_dst)
            {
              shiny::incProgress(1/(nb_boucles_src*nb_boucles_dst))

              list_res[[k]] <- osrmTable_11_nm(src[((i-1)*nb_src+1):(i*nb_src),],
                                               dst[((j-1)*nb_dst+1):(j*nb_dst),],
                                               duree,
                                               distance,
                                               exclude,
                                               faceAFace = FALSE)

              k <- k + 1
            }
          }
          if(reste_dst > 0)
          {
            list_res[[k]] <- osrmTable_11_nm(src[((i-1)*nb_src+1):(i*nb_src),],
                                             dst[(j*nb_dst+1):(j*nb_dst+reste_dst),],
                                             duree,
                                             distance,
                                             exclude,
                                             faceAFace = FALSE)

            k <- k + 1
          }
        }
      }
      if(reste_src > 0)
      {
        j <- 0
        if(nb_boucles_dst > 0)
        {
          for(j in 1:nb_boucles_dst)
          {
            list_res[[k]] <- osrmTable_11_nm(src[(i*nb_src+1):(i*nb_src+reste_src),],
                                             dst[((j-1)*nb_dst+1):(j*nb_dst),],
                                             duree,
                                             distance,
                                             exclude,
                                             faceAFace = FALSE)

            k <- k + 1
          }
        }
        if(reste_dst > 0)
        {
          list_res[[k]] <- osrmTable_11_nm(src[(i*nb_src+1):(i*nb_src+reste_src),],
                                           dst[(j*nb_dst+1):(j*nb_dst+reste_dst),],
                                           duree,
                                           distance,
                                           exclude,
                                           faceAFace = FALSE)

          k <- k + 1
        }
      }
    })
  }else if(!interactive)
  {
    pb <- progress::progress_bar$new(
            format = "Calcul en cours [:bar] :percent :elapsed",
            total = nb_boucles_src*nb_boucles_dst, clear = FALSE, width= 60
          )

    pb$tick(0)

    list_res <- list()
    k <- 1
    i <- 0
    if(nb_boucles_src > 0)
    {
      for(i in 1:nb_boucles_src)
      {
        j <- 0
        if(nb_boucles_dst > 0)
        {
          for(j in 1:nb_boucles_dst)
          {
            pb$tick()
            list_res[[k]] <- osrmTable_11_nm(src[((i-1)*nb_src+1):(i*nb_src),],
                                             dst[((j-1)*nb_dst+1):(j*nb_dst),],
                                             duree,
                                             distance,
                                             exclude,
                                             faceAFace = FALSE)

            k <- k + 1
          }
        }
        if(reste_dst > 0)
        {
          list_res[[k]] <- osrmTable_11_nm(src[((i-1)*nb_src+1):(i*nb_src),],
                                           dst[(j*nb_dst+1):(j*nb_dst+reste_dst),],
                                           duree,
                                           distance,
                                           exclude,
                                           faceAFace = FALSE)

          k <- k + 1
        }
      }
    }
    if(reste_src > 0)
    {
      j <- 0
      if(nb_boucles_dst > 0)
      {
        for(j in 1:nb_boucles_dst)
        {
          list_res[[k]] <- osrmTable_11_nm(src[(i*nb_src+1):(i*nb_src+reste_src),],
                                           dst[((j-1)*nb_dst+1):(j*nb_dst),],
                                           duree,
                                           distance,
                                           exclude,
                                           faceAFace = FALSE)

          k <- k + 1
        }
      }
      if(reste_dst > 0)
      {
        list_res[[k]] <- osrmTable_11_nm(src[(i*nb_src+1):(i*nb_src+reste_src),],
                                         dst[(j*nb_dst+1):(j*nb_dst+reste_dst),],
                                         duree,
                                         distance,
                                         exclude,
                                         faceAFace = FALSE)

        k <- k + 1
      }
    }

  }else{}

  res <- do.call(rbind,list_res)
  res$idSrc <- as.character(res$idSrc)
  res$idDst <- as.character(res$idDst)

  # On cree un identifiant par couple
  res$ID <- c(1:nrow(res)) # ID : identifiant de couples
  res <- res[,c("ID",names(res)[-ncol(res)])]

  return(res)
}

isopoly <-
function (x, breaks, xcoords = "COORDX", ycoords = "COORDY", var = "OUTPUT")
{
  vmin <- min(x[[var]], na.rm = TRUE)
  vmax <- max(x[[var]], na.rm = TRUE)
  breaks <- sort(unique(c(vmin, breaks[breaks > vmin & breaks <
                                         vmax], vmax)))
  m <- matrix(data = x[[var]], nrow = length(unique(x[[xcoords]])),
              dimnames = list(unique(x[[xcoords]]), unique(x[[ycoords]])))
  lev_low = breaks[1:(length(breaks) - 1)]
  lev_high = breaks[2:length(breaks)]
  raw <- isoband::isobands(x = as.numeric(rownames(m)), y = as.numeric(colnames(m)),
                           z = t(m), levels_low = lev_low, levels_high = c(lev_high[-length(lev_high)],
                                                                           vmax + 1e-10))
  bands <- isoband::iso_to_sfg(raw)
  iso <- sf::st_sf(id = 1:length(bands), min = lev_low, max = lev_high,
               geometry = sf::st_sfc(bands), crs = sf::st_crs(x))
  iso[1, "min"] <- 0
  iso$center = iso$min + (iso$max - iso$min)/2
  sf::st_geometry(iso) <- sf::st_make_valid(sf::st_geometry(iso))
  if (methods::is(sf::st_geometry(iso), c("sfc_GEOMETRYCOLLECTION"))) {
    sf::st_geometry(iso) <- sf::st_collection_extract(sf::st_geometry(iso),
                                                  "POLYGON")
  }else if (methods::is(sf::st_geometry(iso), c("sfc_GEOMETRY"))) {
    sf::st_geometry(iso) <- sf::st_collection_extract(sf::st_geometry(iso),
                                                      "POLYGON")
  }
  iso <- iso[-nrow(iso), ]
  return(iso)
}

# @name requeteOsrm_11_nm
# @title Calcul la durée et/ou la distance en face à face ou par croisement.
# @description La fonction interne requeteOsrm_11_nm permet de calculer
# la durée et la distance entre couples de points en face à face ou par croisement.
# @param src,dst Undata.frame 3 colonnes id/lon/lat.
# @param idx_src,idx_dst  Un vecteur numérique de 1 à n où n est le nombre de couples pour la requête.
# @param measure Un vecteur caractères. Choix des options entre "duration" et "distance".
# @param exclude_str Chaine de caractères string. Exclu un type de route pour le calcul du trajet. 
# String formé pour la requête. Si exclude = NULL, exclude_str = "".
# @return list.
# @importFrom RJSONIO fromJSON
# @noRd
# @export
# 
requeteOsrm_11_nm <-
function(src, idx_src, dst, idx_dst, measure, exclude_str)
{
  if(!is.null(getOption("osrm.server")))
  {
    if(substr(getOption("osrm.server"),nchar(getOption("osrm.server")),nchar(getOption("osrm.server"))) == "/")
    {
      server <- getOption("osrm.server")
    }else
    {
      server <- paste0(getOption("osrm.server"), "/")
    }
  }else
  {
    server <- getOption("osrm.server")
  }

  req <- paste(paste0(server, "table/v1/",
                      getOption("osrm.profile"), "/"),
               paste(clean_coord(src[idx_src,2]),clean_coord(src[idx_src,3]), sep = ",",collapse = ";"),";",
               paste(clean_coord(dst[idx_dst,2]),clean_coord(dst[idx_dst,3]), sep = ",",collapse = ";"),
               "?sources=", paste(idx_src-1, collapse = ";"),
               "&destinations=", paste(length(idx_src):(length(idx_src)+length(idx_dst)-1), collapse = ";"),
               "&annotations=", paste0(measure, collapse = ","),
               exclude_str, sep = "")

  req <- utils::URLencode(req)

  res <- tryCatch({

    RJSONIO::fromJSON(req)

  },error = function(err){
    message("Un encombrement du r\u00e9seau a eu lieu mais le calcul continue.")

    # On attend 5 secondes que le réseau redevienne fluide avant de relancer la requête
    Sys.sleep(5)

    res <- tryCatch({

      RJSONIO::fromJSON(req)

    },error = function(err){
      message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x1.")

      # On attend maintenant 10 secondes que le réseau redevienne fluide avant de relancer la requête
      Sys.sleep(10)

      res <- tryCatch({

        RJSONIO::fromJSON(req)

      },error = function(err){
        message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x2.")

        # On attend 20 secondes que le réseau redevienne fluide avant de relancer la requête
        Sys.sleep(30)

        res <- tryCatch({

          RJSONIO::fromJSON(req)

        },error = function(err){
          message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x3.")

          # On attend 60 secondes que le réseau redevienne fluide avant de relancer la requête
          Sys.sleep(60)

          res <- tryCatch({

            RJSONIO::fromJSON(req)

          },error = function(err){
            message("Le r\u00e9seau ne s'est toujours pas lib\u00e9r\u00e9. Arr\u00eat du traitement.")
            message(err)
          })
        })
      })
    })
  })

  # Attente pour laisser le temps à la requête de faire l'aller-retour vers le serveur. Sinon risque de plantage de connexion.
  Sys.sleep(0.01)

  return(res)
}

# @name requeteOsrm_11_nm
# @title Calcul la durée et/ou la distance entre deux points.
# @description La fonction interne osrmTableGrpe3 permet de calculer la durée et la distance entre deux points.
# @param couples Un data.frame 7 colonnes "idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID".
# @param duree Un booleen. La fonction retourne la durée. Par défaut à TRUE.
# @param distance Un booleen. La fonction retourne la distance. Par défaut à TRUE.
# @param exclude Une chaine de carctère string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
# @return Un data.frame
# @noRd
# @export
# 
osrmTableGrpe3 <-
function(couples, duree, distance, exclude)
{
  ID_11_nm <- data.frame(ID=couples$ID)
  src_11_nm <- couples[,c("idSrc","lonSrc","latSrc")]
  dst_11_nm <- couples[,c("idDst","lonDst","latDst")]

  res_11_nm <- osrmTable_11_nm(src = src_11_nm, dst = dst_11_nm, duree = duree, distance = distance, exclude = exclude, faceAFace = TRUE)
  res_3g <- cbind(ID_11_nm,res_11_nm)

  return(res_3g)
}

# @name osrmTableFaceAFace
# @title La fonction interne osrmTableFaceAFace.
# @description La fonction interne osrmTableFaceAFace permet de lancer calculs_faceaface. 
# Les couples de points sont pris en face à face entre src et dst. 
# Les points en trop, si src et dst n’ont pas la même dimension, sont ignorés.
# @inheritParams metriOsrmTable
# @return Un data.frame
# @noRd
# @export
# 
osrmTableFaceAFace <- function(src, dst, duree, distance, exclude, interactive)
{
  if(nrow(src)>nrow(dst) & nrow(dst)>1)
  {
    src <- src[1:nrow(dst),]
  }else if(nrow(dst)>nrow(src) & nrow(src)>1)
  {
    dst <- dst[1:nrow(src),]
  }else # nrow(src)==nrow(dst)
  {}

  # on cree une table avec les couples uniques en face a face
  couplesUniques <- unique(cbind(src,dst))
  names(couplesUniques) <- c("idSrc","lonSrc","latSrc","idDst","lonDst","latDst")

  # On cree un identifiant par couple
  couplesUniques$ID <- c(1:nrow(couplesUniques)) # ID : identifiant de couples

  res <- calculs_faceaface(couplesUniques, duree, distance, exclude, interactive)

  return(res)
}

convertToDf <- function(objet)
{
  # Si objet est un vecteur
  if(is.vector(objet))
  {
    objet <- vectorToDf(vector = objet)
  }
  
  # si objet est un objet sp, on le transforme d'abord en objet sf
  if (methods::is(objet, "Spatial")) {
    objet <- sf::st_as_sf(x = objet)
    warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
  }
  # si objet est un objet sf, on le transforme en data.frame
  if (testSf(x = objet)) {
    objet <- sfToDf(x = objet)
  }

  names(objet) <- c("id", "lon", "lat")

  return(objet)
}

# @name vectorToDf
# @title Transforme une liste de 3 vecteurs de même longueur en dataframe.
# @description Fonction interne qui transforme une liste de 3 vecteurs de même longueur en dataframe.
# @param src,dst objet sf ou dataframe 2 ou 3 colonnes contenant deux vecteurs numériques sans valeurs manquantes.
# @return Erreur si les paramètres ne sont pas conformes.
# @noRd
# @export
#  
vectorToDf <-
function(vector)
{
  dt <- data.frame(id=vector[1],lon=vector[2],lat=vector[3])
  return(dt)
}

# @name sfToDf
# @title Transforme un objet sf en data.frame.
# @description La fonction interne sfToDf permet de transformer un objet sf en data.frame.
# @param x objet sf POINT, MULTIPOINT, POLYGON, MULTIPOLYGON, GEOMETRY ou GEOMETRYCOLLECTION.
# @return data.frame avec les longitude et latitude en systeme de projection 4326.
# @importFrom sf st_crs st_collection_extract st_geometry st_transform st_coordinates st_centroid
# @importFrom methods is
# @noRd
# @export
#
sfToDf <- function (x)
{
  if (is.na(sf::st_crs(x))) {
    stop(paste0("L'entr","\u00e9","e ne dispose pas d'un syst\u00e8me de r","\u00e9","f\u00e9rence de coordonn","\u00e9","es valide."))
  }
  
  if (methods::is(sf::st_geometry(x), c("sfc_GEOMETRY"))) {
    x <- sf::st_collection_extract(x, "POLYGON", warn = FALSE)
  }else if (methods::is(sf::st_geometry(x), c("sfc_GEOMETRYCOLLECTION"))) {
    x <- sf::st_collection_extract(x, "POLYGON", warn = FALSE)
  }else if (methods::is(sf::st_geometry(x), c("sfc_POLYGON"))) {
    sf::st_geometry(x) <- suppressWarnings(sf::st_centroid(x = sf::st_geometry(x),
                                          of_largest_polygon = T))
  }else if (methods::is(sf::st_geometry(x), c("sfc_MULTIPOLYGON"))) {
    sf::st_geometry(x) <- suppressWarnings(sf::st_centroid(x = sf::st_geometry(x),
                                                           of_largest_polygon = T))
  }else{}
  x <- sf::st_transform(x = x, crs = 4326)
  coords <- sf::st_coordinates(x)
  x <- data.frame(id = as.data.frame(x)[,1], lon = as.numeric(clean_coord(coords[,1])), lat = as.numeric(clean_coord(coords[, 2])), stringsAsFactors = FALSE)
  if (any(names(x)!=c("id","lon","lat"))) {
    stop(paste0("L'entr","\u00e9","e ne dispose pas d'identifiant."))
  }
  return(x)
}

calculs_faceaface_groupe2 <- function(id, dt_id, duree, distance, exclude){

  if(id==4)
  {
    src_1n_n1 <- dt_id[,c("idSrc","lonSrc","latSrc")]
    dst_1n_n1 <- dt_id[1,c("idDst","lonDst","latDst")]
  }else if(id==1)
  {
    src_1n_n1 <- dt_id[1,c("idSrc","lonSrc","latSrc")]
    dst_1n_n1 <- dt_id[,c("idDst","lonDst","latDst")]
  }else
  {
    src_1n_n1 <- NULL
    dst_1n_n1 <- NULL
  }

  res_1n_n1 <- osrmTable_1n_n1(src = src_1n_n1, dst = dst_1n_n1, duree = duree, distance = distance, exclude = exclude)
  res_1n_n1 <- cbind(data.frame(ID=dt_id$ID),res_1n_n1)

  return(res_1n_n1)
}

calculs_faceaface_groupe1 <- function(cptSrc, cptDst, couples, duree, distance, exclude)
{
  if(cptSrc[which.max(cptSrc)]>=cptDst[which.max(cptDst)])
  {
    id <- names(cptSrc[which.max(cptSrc)])
    couplesMax <- couples[couples[,1] %in% id,]
    src_1n_n1 <- couplesMax[1,c(1:3)]
    dst_1n_n1 <- couplesMax[,c(4:6)]
    ID_1n_n1 <- data.frame(ID=couplesMax$ID)
  }else
  {
    id <- names(cptDst[which.max(cptDst)])
    couplesMax <- couples[couples[,4] %in% id,]
    src_1n_n1 <- couplesMax[,c(1:3)]
    dst_1n_n1 <- couplesMax[1,c(4:6)]
    ID_1n_n1 <- data.frame(ID=couplesMax$ID)
  }

  res_1n_n1 <- osrmTable_1n_n1(src = src_1n_n1, dst = dst_1n_n1, duree = duree, distance = distance, exclude = exclude)
  res_1n_n1 <- cbind(ID_1n_n1,res_1n_n1)

  return(res_1n_n1)
}

# @name testSf
# @title Test si l'objet est un objet sf.
# @description La fonction interne testSf permet de tester si l'objet passé en paramètre 
# est un objet sf.
# @param x Objet sf. Si autre, ignoré.
# @return Booléen TRUE ou FALSE.
# @importFrom methods is
# @importFrom sf st_crs
# @noRd
# @export
# 
testSf <-
function (x)
{
  if (methods::is(x, "sf")) {
    if (is.na(sf::st_crs(x))) {
      stop(paste("Your input (", quote(x), ") does not have a valid coordinate reference system.",
                 sep = ""), call. = F)
    }
    return(TRUE)
  }
  return(FALSE)
}

# @name rgrid
# @title Transforme un objet sf de géomertie POINT en grille sf.
# @description La fonction interne rgrid permet de transformer un objet sf de géomertie POINT en grille.
# @param loc objet sf de géométrie POINT.
# @param dmax numérique distance max autour d'un point.
# @param res resolution de la grille. Un entier positif.
# @importFrom sf st_coordinates st_as_sf st_crs
# @noRd
# @export
#
rgrid <-
function (loc, dmax, res)
{
  boxCoordX <- seq(from = sf::st_coordinates(loc)[1,1] - dmax,
                   to = sf::st_coordinates(loc)[1,1] + dmax,
                   length.out = res)
  boxCoordY <- seq(from = sf::st_coordinates(loc)[1,2] - dmax,
                   to = sf::st_coordinates(loc)[1,2] + dmax,
                   length.out = res)
  sgrid <- expand.grid(boxCoordX, boxCoordY)
  sgrid <- data.frame(ID = seq(1, nrow(sgrid), 1), COORDX = sgrid[,1], COORDY = sgrid[, 2])
  sgrid <- sf::st_as_sf(sgrid, coords = c("COORDX", "COORDY"), crs = sf::st_crs(loc), remove = FALSE)
  return(sgrid)
}

1		clean_coord <-
2		function (x)
3		{
4	3903x	format(round(as.numeric(x), 5), scientific = FALSE, justify = "none",
5	3903x	trim = TRUE, nsmall = 5, digits = 5)
6		}

1		# @name osrmTableGrpe1
2		# @title Calcul la durée et/ou la distance entre deux points.
3		# @description La fonction osrmTableGrpe1 permet de calculer la durée et la distance d'un point
4		# vers un groupe de points ou d'un groupe de points vers un point.
5		# Chaque groupe est composé d'au moins 1000 points
6		# @param couples Un data.frame 7 colonnes "idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID".
7		# @param duree Un booleen. La fonction retourne la durée. Par défaut à TRUE.
8		# @param distance Un booleen. La fonction retourne la distance. Par défaut à TRUE.
9		# @param exclude Une chaine de carctère string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
10		# @return Un data.frame
11		# @importFrom shiny withProgress incProgress
12		# @importFrom progress progress_bar
13		# @noRd
14		# @export
15		#
16		osrmTableGrpe1 <-
17		function(couples, duree, distance, exclude, interactive)
18		{
19	40x	list_res_1n_n1 <- list()
20	40x	cpt <- 0
21
22	40x	couples_save <- couples
23
24	40x	cptSrc <- table(couples[,1])
25	40x	cptDst <- table(couples[,4])
26
27	40x	while(any(cptSrc[which.max(cptSrc)]>=1000 \| cptDst[which.max(cptDst)]>=1000))
28		{
29	!	if(cptSrc[which.max(cptSrc)]>=cptDst[which.max(cptDst)])
30		{
31	!	id <- names(cptSrc[which.max(cptSrc)])
32	!	couplesMax <- couples[couples[,1] %in% id,]
33		}else
34		{
35	!	id <- names(cptDst[which.max(cptDst)])
36	!	couplesMax <- couples[couples[,4] %in% id,]
37		}
38
39	!	couples <- couples[-which(couples$ID %in% couplesMax$ID),]
40
41	!	cptSrc <- table(couples[,1])
42	!	cptDst <- table(couples[,4])
43
44	!	cpt <- cpt + 1
45		}
46
47	40x	cpt <- cpt - 1
48
49	40x	if(cpt > 0)
50		{
51	!	couples <- couples_save
52
53	!	cptSrc <- table(couples[,1])
54	!	cptDst <- table(couples[,4])
55
56	!	if(interactive)
57		{
58	!	shiny::withProgress(message = "Calculs en cours - 1/3 : ",{
59	!	for(i in 1:cpt)
60		{
61	!	list_res_1n_n1[[i]] <- calculs_faceaface_groupe1(cptSrc, cptDst, couples, duree, distance, exclude)
62
63	!	couples <- couples[-which(couples$ID %in% list_res_1n_n1[[i]][,1]),]
64
65	!	cptSrc <- table(couples[,1])
66	!	cptDst <- table(couples[,4])
67
68	!	shiny::incProgress(1/cpt)
69		}
70		})
71	!	}else if(!interactive)
72		{
73	!	pb1 <- progress::progress_bar$new(
74	!	format = "Calcul en cours - 1/3 : [:bar] :percent :elapsed",
75	!	total = cpt, clear = FALSE, width= 60
76		)
77
78	!	pb1$tick(0)
79
80	!	for(i in 1:cpt)
81		{
82	!	list_res_1n_n1[[i]] <- calculs_faceaface_groupe1(cptSrc, cptDst, couples, duree, distance, exclude)
83
84	!	couples <- couples[-which(couples$ID %in% list_res_1n_n1[[i]][,1]),]
85
86	!	cptSrc <- table(couples[,1])
87	!	cptDst <- table(couples[,4])
88
89	!	pb1$tick()
90		}
91		}else
92		{
93	!	pb1 <- progress::progress_bar$new(
94	!	format = "Calcul en cours - 1/3 : [:bar] :percent :elapsed",
95	!	total = 2, clear = FALSE, width= 60
96		)
97
98	!	for (i in 1:2) {
99	!	pb1$tick()
100	!	Sys.sleep(0.2)
101		}
102
103	!	res_1g <- NULL
104		}
105
106	!	res_1g <- do.call(rbind,list_res_1n_n1)
107
108		}else
109		{
110	40x	pb1 <- progress::progress_bar$new(
111	40x	format = "Calcul en cours - 1/3 : [:bar] :percent :elapsed",
112	40x	total = 2, clear = FALSE, width= 60
113		)
114
115	40x	for (i in 1:2) {
116	80x	pb1$tick()
117	80x	Sys.sleep(0.2)
118		}
119
120	40x	res_1g <- NULL
121		}
122
123	40x	return(res_1g)
124		}

1		#' @name adresseToCoord
2		#'
3		#' @title Geolocaliser des adresses et renvoyer leurs coordonnees en WGS84 (EPSG 4326)
4		#'
5		#' @description La fonction adresseToCoord permet de récupérer les coordonnées WGS84 (longitude/latitude code epsg 4326) de plusieurs adresses.
6		#'
7		#' La fonction utilise l'API Adresses (documentation : https://geo.api.gouv.fr/adresse).
8		#'
9		#' @param adresses vecteur texte Adresses à géolocaliser.
10		#' @param nbEchos valeur numérique. Nombre de résultats maximum par adresse en cas de doute sur la géolocalisation. Par défaut 1.
11		#' @param codePostal vecteur texte. Par défaut NULL.
12		#' @param codeInsee vecteur texte. Par défaut NULL.
13		#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
14		#'
15		#' @return Un data.frame
16		#'
17		#' @details En plus des coordonnées lon et lat, un score entre 0 et 1 est proposé, indiquant la pertinence de la géolocalisation.
18		#'
19		#' Le codePostal et le codeInsee sont des arguments optionnels qui permettent d'améliorer la géolocalisation en cas de doute sur un libellé d'adresse.
20		#'
21		#' Le code postal peut aussi être mentionné directement dans les libellés d'adresses.
22		#'
23		#' Le nombre d'echos permet à la fonction de retourner jusqu'à n echos si la géolocalisation renvoie plusieurs possibilités. Seuls les échos les plus pertinents sont proposés.
24		#'
25		#' @importFrom RJSONIO fromJSON
26		#' @importFrom shiny withProgress incProgress
27		#' @importFrom progress progress_bar
28		#' @export
29		#'
30		#' @examples
31		#' # Exemple 1 : avec une seule adresse
32		#' adresseToCoord(adresses = "88 avenue Verdier Montrouge",
33		#' nbEchos = 1)
34		#'
35		#' # Exemple 2 : avec un vecteur d'adresses
36		#' adresses <- c("1 Rue des Abeilles 13001 Marseille",
37		#' "1 Allee des Abeilles 13016 Marseille",
38		#' "1 Impasse Abeille 13003 Marseille",
39		#' "1 Impasse de la Chapelle 13013 Marseille",
40		#' "1 Boulevard de la Chapelle 13009 Marseille",
41		#' "1 Boulevard de la Chapelle 13014 Marseille")
42		#'
43		#' adresseToCoord(adresses = adresses,
44		#' nbEchos = 1) # un resultat par adresse
45		#'
46		#' adresseToCoord(adresses = adresses,
47		#' nbEchos = 2) # 2 resultats max possibles par adresse
48		#'
49		adresseToCoord <- function(adresses, nbEchos = 1, codePostal = NULL, codeInsee = NULL, interactive = FALSE)
50		{
51	12x	msg_error1 <- msg_error2 <- msg_error3 <- msg_error4 <- NULL
52
53	3x	if(!is.character(adresses)) msg_error1 <- "Le parametre adresses doit etre un vecteur caractere / "
54	1x	if(!is.numeric(nbEchos)) msg_error2 <- "Le parametre nbEchos doit etre une valeur numerique / "
55	1x	if(!is.null(codePostal)) if(!is.character(codePostal)) msg_error3 <- "Le parametre codePostal doit etre un vecteur caractere / "
56	1x	if(!is.null(codeInsee)) if(!is.character(codeInsee)) msg_error4 <- "Le parametre codeInsee doit etre un vecteur caractere / "
57
58	12x	if(any(!is.null(msg_error1),!is.null(msg_error2),!is.null(msg_error3),!is.null(msg_error4)))
59		{
60	5x	stop(simpleError(paste0(msg_error1,msg_error2,msg_error3,msg_error4)))
61		}
62
63	7x	options(adresse.server = "https://api-adresse.data.gouv.fr/")
64
65	7x	supprAccent <- function(text) {
66	7x	text <- gsub("['`^~\"]", " ", text)
67	7x	text <- iconv(text, from = "UTF-8", to = "ASCII//TRANSLIT//IGNORE")
68	7x	text <- gsub("['`^~\"]", "", text)
69	7x	return(text)
70		}
71
72	7x	dt_adresses <- data.frame(ADRESSES=adresses, stringsAsFactors = FALSE)
73
74		# Conversion en UTF-8 uniquement si les libellés d'adresses n'y sont pas déjà
75	7x	if(!"UTF-8" %in% Encoding(dt_adresses$ADRESSES)){
76	6x	dt_adresses$ADRESSES <- iconv(dt_adresses$ADRESSES, to = "UTF-8")
77		}
78
79		# Suppression des accents en entree pour que la fonction RJSONIO::fromjson puisse traiter la requete
80	7x	dt_adresses$ADRESSES <- supprAccent(dt_adresses$ADRESSES)
81
82	!	if(!is.null(codePostal)) dt_codePostal <- data.frame(codePostal=codePostal, stringsAsFactors = FALSE)
83	!	if(!is.null(codeInsee)) dt_codeInsee <- data.frame(codeInsee=codeInsee, stringsAsFactors = FALSE)
84
85	7x	if(!interactive)
86		{
87	7x	pb <- progress::progress_bar$new(
88	7x	format = paste0("G\u00e9olocalisation en cours de ",nrow(dt_adresses)," adresses - [:bar] :percent :elapsed"),
89	7x	total = nrow(dt_adresses), clear = FALSE, width= 80
90		)
91
92	7x	pb$tick(0)
93
94	7x	res <- t(lapply(1:nrow(dt_adresses),function(x) {
95
96	11x	pb$tick()
97
98	11x	if(nchar(dt_adresses[x,]) == 0)
99		{
100	1x	return(data.frame(ADRESSES = dt_adresses[x,],
101	1x	ADRESSES_GEOLOC = "unknown",
102	1x	LON = 0,
103	1x	LAT = 0,
104	1x	SCORE = 0,
105	1x	stringsAsFactors = FALSE))
106		}
107
108	10x	if(!is.null(codePostal))
109		{
110	!	req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&postcode=",dt_codePostal[x,],"&limit=",nbEchos)
111	10x	}else if(!is.null(codeInsee))
112		{
113	!	req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&citycode=",dt_codeInsee[x,],"&limit=",nbEchos)
114		}else
115		{
116	10x	req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&limit=",nbEchos)
117		}
118
119		# On specifie explicitement que l'encodage en sortie doit etre du latin1, sinon il considere qu'il est unknown meme si implicitement c'est du latin1.
120		# Sinon, cela qui peut generer des caracteres non reconnus a l'affichage si la reponse contient des caracteres speciaux.
121		# MAJ 2023 - suppression de cette rustine, on précise désormais UTF8 pour RJSONIO
122		#a <- RJSONIO::fromJSON(req, encoding = "latin1")
123
124	10x	a <- RJSONIO::fromJSON(req, encoding = "UTF-8")
125	10x	if(length(a[["features"]])>0)
126		{
127	9x	res <- lapply(1:length(a[["features"]]),function(y){
128	13x	data.frame(ADRESSES = dt_adresses[x,],
129	13x	ADRESSES_GEOLOC = a[["features"]][[y]][["properties"]][["label"]],
130	13x	LON = a[["features"]][[y]][["geometry"]][["coordinates"]][1],
131	13x	LAT = a[["features"]][[y]][["geometry"]][["coordinates"]][2],
132	13x	SCORE = a[["features"]][[y]][["properties"]][["score"]],
133	13x	stringsAsFactors = FALSE)
134		})
135
136	9x	res <- do.call("rbind", res)
137
138		# On convertit la sortie latin1 en UTF-8
139		#res$ADRESSES_GEOLOC <- iconv(res$ADRESSES_GEOLOC, from = "latin1", to = "UTF-8")
140
141	9x	return(res)
142		}else{
143	1x	return(data.frame(ADRESSES = dt_adresses[x,],
144	1x	ADRESSES_GEOLOC = "unknown",
145	1x	LON = 0,
146	1x	LAT = 0,
147	1x	SCORE = 0,
148	1x	stringsAsFactors = FALSE))
149		}
150
151
152		}))
153		}else
154		{
155	!	shiny::withProgress(message = paste0("G\u00e9olocalisation en cours de ",nrow(dt_adresses)," adresses"),{
156
157	!	res <- t(lapply(1:nrow(dt_adresses),function(x) {
158
159	!	shiny::incProgress(1/nrow(dt_adresses))
160
161	!	if(nchar(dt_adresses[x,]) == 0)
162		{
163	!	return(data.frame(ADRESSES = dt_adresses[x,],
164	!	ADRESSES_GEOLOC = "unknown",
165	!	LON = 0,
166	!	LAT = 0,
167	!	SCORE = 0,
168	!	stringsAsFactors = FALSE))
169		}
170
171	!	if(!is.null(codePostal))
172		{
173	!	req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&postcode=",dt_codePostal[x,],"&limit=",nbEchos)
174	!	}else if(!is.null(codeInsee))
175		{
176	!	req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&citycode=",dt_codeInsee[x,],"&limit=",nbEchos)
177		}else
178		{
179	!	req <- paste0(getOption("adresse.server"),"search/?q=",paste(unlist(strsplit(as.character(tolower(dt_adresses[x,]))," ")),collapse="+"),"&limit=",nbEchos)
180		}
181
182		# On specifie explicitement que l'encodage en sortie doit etre du latin1, sinon il considere qu'il est unknown meme si implicitement c'est du latin1.
183		# Sinon, cela qui peut generer des caracteres non reconnus a l'affichage si la reponse contient des caracteres speciaux.
184		# MAJ 2023 - suppression de cette rustine, on précise désormais UTF8 pour RJSONIO
185
186	!	a <- RJSONIO::fromJSON(req, encoding = "UTF-8")
187
188	!	if(length(a[["features"]])>0)
189		{
190	!	res <- lapply(1:length(a[["features"]]),function(y){
191	!	data.frame(ADRESSES = dt_adresses[x,],
192	!	ADRESSES_GEOLOC = a[["features"]][[y]][["properties"]][["label"]],
193	!	LON = a[["features"]][[y]][["geometry"]][["coordinates"]][1],
194	!	LAT = a[["features"]][[y]][["geometry"]][["coordinates"]][2],
195	!	SCORE = a[["features"]][[y]][["properties"]][["score"]],
196	!	stringsAsFactors = FALSE)
197		})
198
199	!	res <- do.call("rbind", res)
200
201		# On convertit la sortie latin1 en UTF-8
202		#res$ADRESSES_GEOLOC <- iconv(res$ADRESSES_GEOLOC, from = "latin1", to = "UTF-8")
203
204	!	return(res)
205		}else{
206	!	return(data.frame(ADRESSES = dt_adresses[x,],
207	!	ADRESSES_GEOLOC = "unknown",
208	!	LON = 0,
209	!	LAT = 0,
210	!	SCORE = 0,
211	!	stringsAsFactors = FALSE))
212		}
213		}))
214		})
215		}
216
217	7x	coordAdresses <- do.call("rbind", res)
218
219	7x	coordAdresses$LON <- as.numeric(clean_coord(coordAdresses$LON))
220	7x	coordAdresses$LAT <- as.numeric(clean_coord(coordAdresses$LAT))
221	7x	coordAdresses$SCORE <- as.numeric(clean_coord(coordAdresses$SCORE))
222
223	7x	return(coordAdresses)
224		}

1		#' @name convertTo
2		#'
3		#' @title Convertir des coordonnees d'un systeme geographique a un autre et dans un format different (sf ou data.frame)
4		#'
5		#' @description La fonction convertTo permet de convertir un objet sf ou un data.frame de coordonnées dans un système géographique différent et dans un autre format, au choix entre sf ou data.frame.
6		#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
7		#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
8		#'
9		#' @param from objet sf avec un CRS valide, ou un data.frame de deux colonnes (coordonnées) ou 3 colonnes (id en 1ère colonne puis les coordonnées).
10		#' Conversion implicite des data.table en data.frame et des objets sp en objet sf
11		#' @param to texte. Type d'objet souhaité en sortie : "sf" ou "data.frame". Si NULL (par défaut), le type de sortie sera le même que celui de l'objet en entrée.
12		#' @param fromEpsg texte ou numérique. Si from est un data.frame, fromEpsg doit correspondre au code EPSG des coordonnées à convertir.
13		#' @param toEpsg texte ou numérique. Code EPSG souhaité pour l'objet à convertir.
14		#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
15		#'
16		#' @return Un objet sf ou un data.frame
17		#'
18		#' @details Le code EPSG du système WGS84 est communément 4326.
19		#'
20		#' En France métropolitaine, le système de projection en vigueur est le Lambert 93, code EPSG 2154.
21		#'
22		#' Pour la Guadeloupe et la Martinique, le code EPSG est 5490 pour la projection UTM 20 N.
23		#'
24		#' Pour la Guyane, le code EPSG est 2972 pour la projection UTM 22 N.
25		#'
26		#' Pour la Réunion, le code EPSG est 2975 pour la projection UTM 40 S.
27		#'
28		#' Pour Mayotte, le code EPSG est 4471 pour la projection UTM 38 S.
29		#'
30		#' La projection Mercator pour représenter la mappemonde a pour code EPSG 3395.
31		#'
32		#' @importFrom sf st_sf st_sfc st_as_sf st_crs st_geometry st_transform st_coordinates st_point as_Spatial
33		#' @importFrom shiny withProgress incProgress
34		#' @importFrom methods is
35		#' @export
36		#'
37		#' @examples
38		#' # Creation d'un data.frame de 4 coordonnees en Lambert 93.
39		#' coord <- data.frame(id = c(1:4),
40		#' X = c(897740.5,901367.8,874261.9,897740.5),
41		#' Y = c(6272912,6251706,6291801,6272912),
42		#' stringsAsFactors = FALSE)
43		#'
44		#' # Conversion des coordonnees en WGS84 (EPSG 4326).
45		#' # Transformation du data.frame en objet spatial sf.
46		#' coord_sf_WGS84 <- convertTo(from = coord,
47		#' to = "sf",
48		#' fromEpsg = 2154,
49		#' toEpsg = 4326)
50		#'
51		#'
52		#' # Creation d'un objet sf : un point en coordonnees Lambert93 (EPSG 2154).
53		#' objet_sf_points <- sf::st_sf(geometry = sf::st_sfc(
54		#' sf::st_geometry(
55		#' sf::st_point(
56		#' c(897740.5,6272912.0)
57		#' )),
58		#' crs=2154))
59		#'
60		#' # Transformation de l'objet sf en data.frame.
61		#' # Conversion implicite des coordonnees en WGS84 (EPSG 4326).
62		#' coord_dt_WGS84 <- convertTo(from = objet_sf_points,
63		#' to = "data.frame")
64
65		convertTo <- function(from, to = NULL, fromEpsg = NULL, toEpsg = 4326, interactive = FALSE)
66		{
67	116x	if(any(class(from)=="data.table"))
68		{
69	7x	from<-as.data.frame(from)
70	7x	warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
71		}
72	116x	if(methods::is(from, "Spatial"))
73		{
74	!	from <- sf::st_as_sf(x = from)
75	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
76		}
77
78	116x	if(testSf(from)){
79	20x	typeFrom <- "sf"
80
81		} else
82	95x	if(length(class(from))==1 & any(class(from)=="data.frame"))
83		{
84	94x	typeFrom <- "data.frame"
85		}else
86		{
87	1x	stop(simpleError(paste0("from doit \u00eatre un objet sf avec un CRS renseign\u00e9,
88	1x	ou un data.frame de 2 colonnes (coordonn","\u00e9","es) ou 3 colonnes (id et coordonn","\u00e9","es).")))
89		}
90
91	114x	if(typeFrom == "data.frame")
92		{
93	94x	if(!is.null(fromEpsg))
94		{
95	93x	fromEpsg <- as.numeric(fromEpsg)
96		}else # fromEpsg est obligatoire si from est une liste
97		{
98	1x	stop(simpleError(paste0("Veuillez pr","\u00e9","ciser un code epsg dans fromEpsg correspondant \u00e0 un syst\u00e8me de projection.")))
99		}
100		}
101
102	113x	if(!is.null(toEpsg))
103		{
104	112x	toEpsg <- as.numeric(toEpsg)
105		}else
106		{
107	1x	stop(simpleError(paste0("Veuillez pr","\u00e9","ciser un code epsg dans toEpsg correspondant \u00e0 un syst\u00e8me de projection.")))
108		}
109
110		# si from est un data.frame de coordonnees
111	112x	if(typeFrom=="data.frame")
112		{
113	92x	if(ncol(from)<2 \| ncol(from)>3)
114		{
115	2x	stop(simpleError(paste0("Le data.frame doit \u00eatre compos\u00e9 de 2 colonnes (les coordonn","\u00e9","es en type num\u00e9rique) ou de 3 colonnes (un id et les coordonn","\u00e9","es en type num\u00e9rique).")))
116	90x	}else if(ncol(from)==2)
117		{
118	18x	col <- 0
119	72x	}else if(ncol(from)==3)
120		{
121	72x	col <- 1
122		}else
123		{}
124
125	90x	if(!is.numeric(from[,col+1]) \| !is.numeric(from[,col+2]))
126		{
127	2x	stop(simpleError(paste0("Le data.frame doit \u00eatre compos\u00e9 de 2 colonnes (les coordonn","\u00e9","es en type num\u00e9rique) ou de 3 colonnes (un id et les coordonn","\u00e9","es en type num\u00e9rique).")))
128		}
129
130	88x	st_un_multipoint = function(x) {
131	88x	oprj <- sf::st_crs(x)
132	88x	g <- sf::st_geometry(x)
133	88x	j <- rep(seq_len(nrow(x)), sapply(g, nrow))
134	88x	x <- x[j,]
135	88x	sf::st_geometry(x) <- sf::st_sfc(do.call(c, lapply(g, function(geom) lapply(1:nrow(geom), function(i) sf::st_point(geom[i,])))))
136	88x	x <- sf::st_sf(x, crs = oprj)
137	88x	x
138		}
139
140	88x	nb_boucles <- nrow(from) %/% 10000
141	88x	reste <- nrow(from) %% 10000
142	88x	list_pts_coord <- list()
143	88x	i <- 0
144
145	88x	if(!interactive)
146		{
147	88x	pb <- progress::progress_bar$new(
148	88x	format = "Calcul en cours - \u00e9tape 1 [:bar] :percent :elapsed",
149	88x	total = nb_boucles, clear = FALSE, width= 60
150		)
151
152	88x	pb$tick(0)
153
154	88x	if(nb_boucles > 0)
155		{
156	!	for(i in 1:nb_boucles)
157		{
158	!	pb$tick()
159	!	subset_from <- from[((i-1)10000+1):(i10000),]
160	!	pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
161	!	list_pts_coord[[i]] <- st_un_multipoint(pts_coord)
162		}
163		}
164	88x	if(reste > 0)
165		{
166	88x	subset_from <- from[(i10000+1):(i10000+reste),]
167	88x	pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
168	88x	list_pts_coord[[i+1]] <- st_un_multipoint(pts_coord)
169		}
170	!	}else if(interactive)
171		{
172	!	shiny::withProgress(message = "Patientez le temps des calculs - \u00e9tape 1",{
173
174	!	if(nb_boucles > 0)
175		{
176	!	for(i in 1:nb_boucles)
177		{
178	!	shiny::incProgress(1/nb_boucles)
179	!	subset_from <- from[((i-1)10000+1):(i10000),]
180	!	pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
181	!	list_pts_coord[[i]] <- st_un_multipoint(pts_coord)
182		}
183		}
184	!	if(reste > 0)
185		{
186	!	subset_from <- from[(i10000+1):(i10000+reste),]
187	!	pts_coord <- sf::st_sf(geometry=sf::st_sfc(sf::st_geometry(sf::st_multipoint(matrix(c(as.numeric(subset_from[[col+1]]),as.numeric(subset_from[[col+2]])),ncol=2)))), crs=fromEpsg)
188	!	list_pts_coord[[i+1]] <- st_un_multipoint(pts_coord)
189		}
190		})
191		}
192
193	88x	if(length(list_pts_coord) > 10)
194		{
195	!	nb_boucles <- length(list_pts_coord) %/% 10
196	!	reste <- length(list_pts_coord) %% 10
197	!	list2_pts_coord <- list()
198	!	i <- 0
199
200	!	if(!interactive)
201		{
202	!	pb <- progress::progress_bar$new(
203	!	format = "Calcul en cours - \u00e9tape 2 [:bar] :percent :elapsed",
204	!	total = nb_boucles, clear = FALSE, width= 60
205		)
206
207	!	pb$tick(0)
208
209	!	if(nb_boucles > 0)
210		{
211	!	for(i in 1:nb_boucles)
212		{
213	!	pb$tick()
214	!	list2_pts_coord[[i]] <- do.call(rbind,list_pts_coord[((i-1)10+1):(i10)])
215		}
216		}
217	!	if(reste > 0)
218		{
219	!	list2_pts_coord[[i+1]] <- do.call(rbind,list_pts_coord[(i10+1):(i10+reste)])
220		}
221	!	}else if(interactive)
222		{
223	!	shiny::withProgress(message = "Patientez le temps des calculs - \u00e9tape 2",{
224
225	!	if(nb_boucles > 0)
226		{
227	!	for(i in 1:nb_boucles)
228		{
229	!	shiny::incProgress(1/nb_boucles)
230	!	list2_pts_coord[[i]] <- do.call(rbind,list_pts_coord[((i-1)10+1):(i10)])
231		}
232		}
233	!	if(reste > 0)
234		{
235	!	list2_pts_coord[[i+1]] <- do.call(rbind,list_pts_coord[(i10+1):(i10+reste)])
236		}
237		})
238		}
239		}else
240		{
241	88x	list2_pts_coord <- list_pts_coord
242		}
243
244	88x	pts_coord <- do.call(rbind,list2_pts_coord)
245
246	88x	if(col==1)
247		{
248	71x	pts_coord$id <- as.data.frame(from)[,1]
249	71x	pts_coord <- pts_coord[,c("id","geometry")]
250	71x	from <- pts_coord
251	17x	}else if(col == 0)
252		{
253	17x	from <- pts_coord
254		}else
255		{}
256		}
257
258	108x	coordWGS84 <- sf::st_transform(from, crs = toEpsg)
259
260	108x	if(any(to == "data.frame") \| (typeFrom == "data.frame" & is.null(to)))
261		{
262	54x	if(!any(class(sf::st_geometry(coordWGS84)) %in% "sfc_MULTIPOLYGON"))
263		{
264	50x	if(ncol(coordWGS84)==1)
265		{
266	13x	coordWGS84 <- data.frame(lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,2])), stringsAsFactors = FALSE)
267	37x	}else if(ncol(coordWGS84) > 1)
268		{
269	37x	coordWGS84 <- data.frame(id = as.data.frame(coordWGS84)[,1], lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,2])), stringsAsFactors = FALSE)
270		}else
271		{}
272	4x	}else if(any(class(sf::st_geometry(coordWGS84)) %in% "sfc_MULTIPOLYGON"))
273		{
274	4x	if(ncol(coordWGS84)==1)
275		{
276	2x	coordWGS84 <- data.frame(lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84)[,2])), stringsAsFactors = FALSE)
277	2x	}else if(ncol(coordWGS84) > 1)
278		{
279	2x	list_coordWGS84 <- list()
280	2x	for(i in 1:nrow(coordWGS84))
281		{
282	2x	list_coordWGS84[[i]] <- data.frame(id = as.data.frame(coordWGS84)[i,1], lon = as.numeric(clean_coord(sf::st_coordinates(coordWGS84[i,])[,1])), lat = as.numeric(clean_coord(sf::st_coordinates(coordWGS84[i,])[,2])), stringsAsFactors = FALSE)
283		}
284	2x	coordWGS84 <- do.call(rbind,list_coordWGS84)
285		}else
286		{}
287		}
288	54x	} else if(any(to == "sf") \| (typeFrom == "sf" & is.null(to)))
289		{ }else # coordWGS84 est deja un objet sf
290		{
291	6x	stop(simpleError(paste0("L'argument to doit \u00eatre \u00e9gal \u00e0 sf, data.frame ou laiss\u00e9 \u00e0 NULL.")))
292		}
293
294	102x	return(coordWGS84)
295		}

1		#' @name metricOsrmIso
2		#'
3		#' @title Calculer des isochrones ou des isodistances autour d'un ou plusieurs points
4		#'
5		#' @description La fonction metricOsrmIso permet de créer des courbes d’isochrones ou d'isodistances mesurant l’accessibilité
6		#' en temps de parcours ou en distance autour d’un ou plusieurs points.
7		#'
8		#' @param loc vecteur numérique (id/lon/lat ou lon/lat), data.frame (3 colonnes id/lon/lat ou 2 colonnes lon/lat), objet sf précisant le(s) point(s)
9		#' de départ, centre(s) des isochrones.
10		#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
11		#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
12		#' @param breaks vecteur numérique. Séquence de valeurs numériques indiquant les temps en minutes relatifs aux courbes isochrones ou les distances en kilomètres relatives aux courbes isodistances.
13		#' @param res numérique. Valeur numérique indiquant la résolution des courbes isochrones, la précision des contours.
14		#' @param fusion booléen. Si TRUE (par défaut), fusion des courbes isochrones si il y a plusieurs points loc (voir details).
15		#' @param courbes texte. "isochrones" (par défaut) ou "isodistances". Choix des courbes iso : isochrones ou isodistances.
16		#' @param exclude texte. Permet aux trajets d'éviter les autoroutes (“motorway”), les péages (“toll”) ou les ferries (“ferry”). Par défaut NULL.
17		#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
18		#'
19		#' @return Une liste d'un ou plusieurs objets sf (MULTIPOLYGON).
20		#'
21		#' @details Le temps de calcul peut être important si le nombre de points de départ (loc) et la résolution (res) sont élevés.
22		#'
23		#' Le nombre de couples calculé est égal au nombre de points de départ x (résolution)².
24		#'
25		#' Si fusion = TRUE, une résolution élevée peut être nécessaire si les points de départ sont très distants.
26		#'
27		#' Le nombre de breaks n’influe pas sur le temps de calcul.
28		#'
29		#' Si fusion = TRUE (par défaut), les courbes d'isochrones ou d'isodistances fusionnent pour former autant de polygones que de classes (nombre de breaks).
30		#' Cas d'utilisation : pour mesurer l'accessibilité d'un type d'équipement le plus proche en temps.
31		#'
32		#' Si fusion = FALSE, les courbes d'isochrones ou d'isodistances sont calculées autour de chaque point.
33		#' Cas d'utilisation : pour mesurer séparément l'accessibilité d'un ou plusieurs équipements.
34		#'
35		#' @importFrom sf st_sf st_sfc st_as_sf st_crs st_centroid st_geometry read_sf st_transform st_bbox st_coordinates st_distance st_buffer st_union st_intersects st_point st_polygon st_contains st_dimension st_make_valid st_collection_extract
36		#' @importFrom RJSONIO fromJSON
37		#' @importFrom methods is as
38		#' @importFrom progress progress_bar
39		#' @importFrom isoband iso_to_sfg
40		#' @export
41		#'
42		#' @examples
43		#' # Specification d'un serveur osrm obligatoire pour executer les exemples
44		#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
45		#'
46		#' # Specification du profil
47		#' options(osrm.profile = "driving")
48		#'
49		#' # Calcul d'isochrones a partir d'un point.
50		#' iso1 <- metricOsrmIso(loc = data.frame(lon = 4.92,
51		#' lat = 46.15),
52		#' courbes = "isochrones")
53		#'
54		#' plot(sf::st_geometry(iso1[[1]]))
55		#'
56		#' # Calcul de deux isochrones separees.
57		#' iso2 <- metricOsrmIso(loc = data.frame(lon = c(4.92,4.98),
58		#' lat = c(46.15,46.30)),
59		#' breaks = c(0,30,60),
60		#' res = 20,
61		#' fusion = FALSE,
62		#' courbes = "isochrones")
63		#'
64		#' plot(sf::st_geometry(iso2[[2]]), border = "blue")
65		#' plot(sf::st_geometry(iso2[[1]]), border = "red", add = TRUE)
66		#'
67		#' # Calcul d'isochrones fusionnees a partir de deux points.
68		#' iso3 <- metricOsrmIso(loc = data.frame(lon = c(4.92,4.98),
69		#' lat = c(46.15,46.30)),
70		#' breaks = c(0,30,60),
71		#' res = 20,
72		#' fusion = TRUE,
73		#' courbes = "isochrones")
74		#'
75		#' plot(sf::st_geometry(iso3[[1]]))
76		#'
77		#' # Calcul d'isodistances fusionnees a partir de deux points.
78		#' iso4 <- metricOsrmIso(loc = data.frame(lon = c(4.92,4.98),
79		#' lat = c(46.15,46.30)),
80		#' breaks = c(0,30,60),
81		#' res = 20,
82		#' fusion = TRUE,
83		#' courbes = "isodistances")
84		#'
85		#' plot(sf::st_geometry(iso4[[1]]))
86		#'
87		metricOsrmIso <-
88		function (loc, breaks = seq(from = 0, to = 60, length.out = 5), res = 30, fusion = TRUE, courbes = "isochrones", exclude = NULL, interactive = FALSE)
89		{
90	23x	oprj <- NA
91	23x	if (methods::is(loc, "Spatial")) {
92	!	loc <- sf::st_as_sf(loc)
93	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
94		}
95	23x	if (testSf(loc)) {
96	1x	oprj <- sf::st_crs(loc)
97	1x	loc <- suppressWarnings(sf::st_centroid(loc))
98	22x	}else if (methods::is(loc, "data.frame")){
99	12x	if (methods::is(loc, "data.table")){
100	3x	warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
101	3x	loc<-as.data.frame(loc)
102		}
103	12x	if(dim(loc)[2]==2)
104		{
105	5x	loc <- sf::st_sf(id = 1, geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[,1], lat = loc[,2]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
106	7x	}else if(dim(loc)[2]==3)
107		{
108	6x	loc <- sf::st_sf(id = loc[,1], geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[,2], lat = loc[,3]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
109		}else
110		{
111	1x	e <- "Le data.frame doit comporter 2 colonnes lon et lat ou 3 colonnes id, lon et lat."
112	1x	stop(e, call. = FALSE)
113		}
114	10x	}else if (methods::is(loc, "numeric")){
115	9x	if(length(loc)==2)
116		{
117	4x	loc <- sf::st_sf(id = 1, geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[1], lat = loc[2]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
118	5x	}else if(length(loc)==3)
119		{
120	4x	loc <- sf::st_sf(id = loc[1], geometry = sf::st_geometry(sf::st_as_sf(data.frame(lon = loc[2], lat = loc[3]), coords = c("lon", "lat"), crs = 4326)), stringsAsFactors = FALSE)
121		}else
122		{
123	1x	e <- "Le vecteur numeric doit comporter 2 valeurs lon et lat ou 3 valeurs id, lon et lat."
124	1x	stop(e, call. = FALSE)
125		}
126		}else
127		{
128	1x	e <- "loc doit \u00eatre un objet sf, data.frame ou vecteur numeric"
129	1x	stop(e, call. = FALSE)
130		}
131
132	20x	loc_dt <- sfToDf(loc)
133
134	20x	loc <- sf::st_transform(loc, 3857)
135	20x	breaks <- unique(sort(breaks))
136	20x	tmax <- max(breaks)
137	20x	if (options("osrm.profile") %in% c("walk","foot","walking","routed-foot")) {
138	!	speed = 10 * 1000/60
139		}
140	20x	if (options("osrm.profile") %in% c("bike","bicycle","cycling","routed-bike")) {
141	!	speed = 20 * 1000/60
142		}
143	20x	if (options("osrm.profile") %in% c("car","driving","routed-car")) {
144	20x	speed = 130 * 1000/60
145		}
146	20x	dmax <- tmax * speed
147
148	20x	if(!is.null(getOption("osrm.server")))
149		{
150	20x	if(getOption("osrm.server") %in% url)
151		{
152	20x	emprisePbf <- emprise_pbf
153	20x	suppressWarnings(sf::st_crs(emprisePbf) <- 3857)
154		}else
155		{
156	!	emprisePbf <- NULL
157		}
158		}else
159		{
160	!	emprisePbf <- NULL
161		}
162
163	20x	if(nrow(loc)>1)
164		{
165	3x	bbox <- sf::st_bbox(loc)
166	3x	long_x <- bbox[3]-bbox[1]
167	3x	long_y <- bbox[4]-bbox[2]
168	3x	cote <- max(long_x,long_y)
169
170	3x	lon <- bbox[1]+long_x/2
171	3x	lat <- bbox[2]+long_y/2
172		}else
173		{
174	17x	lon <- sf::st_coordinates(loc)[1]
175	17x	lat <- sf::st_coordinates(loc)[2]
176	17x	cote <- 0
177		}
178
179	20x	grid <- data.frame(lon = lon, lat = lat)
180	20x	grid <- sf::st_as_sf(grid, coords = c("lon", "lat"), crs = 3857)
181
182	20x	sgrid <- rgrid(loc = grid[1,], dmax = dmax+cote/2, res = res)
183
184	20x	if(!is.null(emprisePbf))
185		{
186	20x	sgrid_keep <- sf::st_intersects(sgrid, emprisePbf)
187	20x	sgrid_select <- sgrid[lengths(sgrid_keep) > 0,]
188		}else
189		{
190	!	sgrid_select <- sgrid
191		}
192
193	20x	lsgr <- nrow(sgrid_select)
194	20x	f500 <- lsgr%/%500
195	20x	r500 <- lsgr%%500
196
197	20x	matDurDist <- matrix(nrow = nrow(loc_dt), ncol = nrow(sgrid_select))
198
199	20x	if(!interactive)
200		{
201	20x	pb <- progress::progress_bar$new(
202	20x	format = paste0("Etape 1/2 : calcul en cours de ",nrow(loc_dt)*nrow(sgrid_select)," couples - [:bar] :percent :elapsed"),
203	20x	total = nrow(loc_dt), clear = FALSE, width= 80
204		)
205
206	20x	pb$tick(0)
207
208	20x	if(any(courbes %in% "isochrones"))
209		{
210	16x	measure <- "duree"
211	4x	}else if(length(courbes) == 1)
212		{
213	3x	if(courbes == "isodistances")
214		{
215	1x	measure <- "distance"
216		}else
217		{
218	2x	measure <- "duree"
219		}
220		}else
221		{
222	1x	courbes <- "isochrones"
223	1x	measure <- "duree"
224		}
225
226	20x	for(i in 1:nrow(loc_dt))
227		{
228	23x	listDurDist <- list()
229	23x	listDest <- list()
230
231	23x	if (f500 > 0) {
232
233	!	for (j in 1:f500) {
234
235	!	st <- (j - 1) * 500 + 1
236	!	en <- j * 500
237
238	!	dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,]), duree = TRUE, distance = TRUE, exclude = exclude)
239
240	!	if(any(dmat$duree < 0))
241		{
242	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
243	!	if(any(is.na(dmat$duree)))
244		{
245	!	list_dmat <- list()
246	!	for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + 500), ])))
247		{
248	!	list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
249		}
250	!	dmat <- do.call(rbind, list_dmat)
251	!	if(any(dmat$duree < 0))
252		{
253	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
254		}
255		}
256		}
257
258	!	listDurDist[[j]] <- dmat[,measure]
259	!	listDest[[j]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
260		}
261	!	if (r500 > 0) {
262
263	!	dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ]), duree = TRUE, distance = TRUE, exclude = exclude)
264
265	!	if(any(dmat$duree < 0))
266		{
267	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
268	!	if(any(is.na(dmat$duree)))
269		{
270	!	list_dmat <- list()
271	!	for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + r500), ])))
272		{
273	!	list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
274		}
275	!	dmat <- do.call(rbind, list_dmat)
276	!	if(any(dmat$duree < 0))
277		{
278	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
279		}
280		}
281		}
282
283	!	listDurDist[[j+1]] <- dmat[,measure]
284	!	listDest[[j+1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
285		}
286		}else {
287
288	23x	dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select), duree = TRUE, distance = TRUE, exclude = exclude)
289
290	23x	if(any(dmat$duree < 0))
291		{
292	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
293	!	if(any(is.na(dmat$duree)))
294		{
295	!	list_dmat <- list()
296	!	for(k in 1:nrow(sfToDf(sgrid_select)))
297		{
298	!	list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select)[k,], duree = TRUE, distance = TRUE, exclude = exclude)
299		}
300	!	dmat <- do.call(rbind, list_dmat)
301	!	if(any(dmat$duree < 0))
302		{
303	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
304		}
305		}
306		}
307
308	23x	listDurDist[[1]] <- dmat[,measure]
309	23x	listDest[[1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
310		}
311	23x	matDurDist[i,] <- do.call(c, listDurDist)
312	23x	destinations <- do.call(rbind, listDest)
313
314	23x	pb$tick()
315		}
316		}else
317		{
318	!	shiny::withProgress(message = paste0("Etape 1/2 : calcul en cours de ",nrow(loc_dt)*nrow(sgrid_select)," couples"),{
319
320	!	shiny::incProgress(1/nrow(loc_dt))
321
322	!	if(any(courbes %in% "isochrones"))
323		{
324	!	measure <- "duree"
325	!	}else if(length(courbes) == 1)
326		{
327	!	if(courbes == "isodistances")
328		{
329	!	measure <- "distance"
330		}else
331		{
332	!	measure <- "duree"
333		}
334		}else
335		{
336	!	courbes <- "isochrones"
337	!	measure <- "duree"
338		}
339
340	!	for(i in 1:nrow(loc_dt))
341		{
342	!	listDurDist <- list()
343	!	listDest <- list()
344
345	!	if (f500 > 0) {
346	!	for (j in 1:f500) {
347
348	!	st <- (j - 1) * 500 + 1
349	!	en <- j * 500
350
351	!	dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,]), duree = TRUE, distance = TRUE, exclude = exclude)
352
353	!	if(any(dmat$duree < 0))
354		{
355	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
356	!	if(any(is.na(dmat$duree)))
357		{
358	!	list_dmat <- list()
359	!	for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + 500), ])))
360		{
361	!	list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[st:en,])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
362		}
363	!	dmat <- do.call(rbind, list_dmat)
364	!	if(any(dmat$duree < 0))
365		{
366	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
367		}
368		}
369		}
370
371	!	listDurDist[[j]] <- dmat[,measure]
372	!	listDest[[j]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
373		}
374	!	if (r500 > 0) {
375
376	!	dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ]), duree = TRUE, distance = TRUE, exclude = exclude)
377
378	!	if(any(dmat$duree < 0))
379		{
380	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
381	!	if(any(is.na(dmat$duree)))
382		{
383	!	list_dmat <- list()
384	!	for(k in 1:nrow(sfToDf(sgrid_select[(en + 1):(en + r500), ])))
385		{
386	!	list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select[(en + 1):(en + r500), ])[k,], duree = TRUE, distance = TRUE, exclude = exclude)
387		}
388	!	dmat <- do.call(rbind, list_dmat)
389	!	if(any(dmat$duree < 0))
390		{
391	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
392		}
393		}
394		}
395
396	!	listDurDist[[j+1]] <- dmat[,measure]
397	!	listDest[[j+1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
398		}
399		}else {
400
401	!	dmat <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select), duree = TRUE, distance = TRUE, exclude = exclude)
402
403	!	if(any(dmat$duree < 0))
404		{
405	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
406	!	if(any(is.na(dmat$duree)))
407		{
408	!	list_dmat <- list()
409	!	for(k in 1:nrow(sfToDf(sgrid_select)))
410		{
411	!	list_dmat[[k]] <- osrmTable_1n_n1(src = loc_dt[i,], dst = sfToDf(sgrid_select)[k,], duree = TRUE, distance = TRUE, exclude = exclude)
412		}
413	!	dmat <- do.call(rbind, list_dmat)
414	!	if(any(dmat$duree < 0))
415		{
416	!	dmat[dmat$duree < 0, c("duree", "distance")] <- NA
417		}
418		}
419		}
420
421	!	listDurDist[[1]] <- dmat[,measure]
422	!	listDest[[1]] <- data.frame(lon = dmat$lonDst, lat = dmat$latDst, stringsAsFactors = FALSE)
423		}
424	!	matDurDist[i,] <- do.call(c, listDurDist)
425	!	destinations <- do.call(rbind, listDest)
426
427	!	shiny::incProgress(1/nrow(loc_dt))
428		}
429		})
430		}
431
432	20x	if(measure == "duree")
433		{
434	19x	if(fusion)
435		{
436	17x	measures <- suppressWarnings(matrix(apply(matDurDist, 2, function(x) min(x, na.rm=T))/60, nrow=1))
437	!	if(any(measures %in% "Inf")) measures[measures %in% "Inf"] <- NA
438		}else
439		{
440	2x	measures <- matDurDist/60
441		}
442		}else
443		{
444	1x	if(fusion)
445		{
446	!	measures <- suppressWarnings(matrix(apply(matDurDist, 2, function(x) min(x, na.rm=T))/1000, nrow=1))
447	!	if(any(measures %in% "Inf")) measures[measures %in% "Inf"] <- NA
448		}else
449		{
450	1x	measures <- matDurDist/1000
451		}
452		}
453
454	20x	if(!interactive)
455		{
456	20x	pb <- progress::progress_bar$new(
457	20x	format = paste0("Etape 2/2 : formation de ",dim(measures)[1]," ", courbes," - [:bar] :percent :elapsed"),
458	20x	total = dim(measures)[1], clear = FALSE, width= 80
459		)
460
461	20x	pb$tick(0)
462
463	20x	list_iso <- list()
464
465	20x	for(i in 1:dim(measures)[1])
466		{
467	20x	rpt <- sf::st_as_sf(destinations, coords = c("lon", "lat"), crs = 4326)
468	20x	rpt <- sf::st_transform(rpt, sf::st_crs(loc))
469	20x	rpt$measures <- measures[i,]
470	!	if(any(is.na(rpt$measures))) rpt <- rpt[!is.na(rpt$measures),]
471	20x	b <- as.numeric(sf::st_distance(sgrid[1, ], sgrid[2, ])/2)
472	20x	xx <- st_make_grid_metric(x = sf::st_buffer(sf::st_union(sgrid), b), n = c(res,res))
473	20x	bbox_rpt <- sf::st_bbox(rpt)
474	20x	sfbbox_rpt <- sf::st_sfc(sf::st_polygon(list(rbind(c(bbox_rpt[1]-50000, bbox_rpt[2]-50000),
475	20x	c(bbox_rpt[3]+50000, bbox_rpt[2]-50000),
476	20x	c(bbox_rpt[3]+50000, bbox_rpt[4]+50000),
477	20x	c(bbox_rpt[1]-50000, bbox_rpt[4]+50000),
478	20x	c(bbox_rpt[1]-50000, bbox_rpt[2]-50000)))),
479	20x	crs = sf::st_crs(xx))
480
481	20x	inter <- sf::st_intersects(xx, sfbbox_rpt)
482	20x	xx <- xx[lengths(inter) > 0,]
483	20x	if(length(xx) == 0)
484		{
485	!	e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
486	!	stop(e, call. = FALSE)
487		}
488	20x	inter <- sf::st_intersects(sgrid, xx)
489	20x	sgrid2 <- sgrid[lengths(inter) > 0,]
490	20x	inter <- sf::st_contains(xx, rpt)
491	20x	sgrid2$measures <- unlist(lapply(inter, function(x) mean(rpt[["measures"]][x], na.rm = TRUE)))
492
493	20x	if(nrow(sgrid2) > 0)
494		{
495	20x	sgrid2[is.nan(sgrid2$measures), "measures"] <- tmax + 1
496	20x	sgrid2[sgrid2$measures > tmax, "measures"] <- tmax + 1
497		}else
498		{
499	!	e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
500	!	stop(e, call. = FALSE)
501		}
502
503	20x	if(min(sgrid2$measures) > tmax) {
504	1x	e <- "Utilisez des 'breaks' plus faibles ou augmenter 'res'"
505	1x	stop(e, call. = FALSE)
506		}
507	19x	iso <- isopoly(x = sgrid2, breaks = breaks, var = "measures")
508	19x	if (!is.na(oprj)) {
509	1x	iso <- sf::st_transform(x = iso, oprj)
510		}else {
511	18x	iso <- sf::st_transform(x = iso, 4326)
512		}
513
514	19x	list_iso[[i]] <- iso
515
516	19x	pb$tick()
517		}
518		}else
519		{
520	!	shiny::withProgress(message = paste0("Etape 2/2 : formation de ",dim(measures)[1]," ", courbes),{
521
522	!	shiny::incProgress(1/dim(measures)[1])
523
524	!	list_iso <- list()
525
526	!	for(i in 1:dim(measures)[1])
527		{
528	!	rpt <- sf::st_as_sf(destinations, coords = c("lon", "lat"), crs = 4326)
529	!	rpt <- sf::st_transform(rpt, sf::st_crs(loc))
530	!	rpt$measures <- measures[i,]
531	!	if(any(is.na(rpt$measures))) rpt <- rpt[!is.na(rpt$measures),]
532	!	b <- as.numeric(sf::st_distance(sgrid[1, ], sgrid[2, ])/2)
533	!	xx <- st_make_grid_metric(x = sf::st_buffer(sf::st_union(sgrid), b), n = c(res,res))
534	!	bbox_rpt <- sf::st_bbox(rpt)
535	!	sfbbox_rpt <- sf::st_sfc(sf::st_polygon(list(rbind(c(bbox_rpt[1]-50000, bbox_rpt[2]-50000),
536	!	c(bbox_rpt[3]+50000, bbox_rpt[2]-50000),
537	!	c(bbox_rpt[3]+50000, bbox_rpt[4]+50000),
538	!	c(bbox_rpt[1]-50000, bbox_rpt[4]+50000),
539	!	c(bbox_rpt[1]-50000, bbox_rpt[2]-50000)))),
540	!	crs = sf::st_crs(xx))
541
542	!	inter <- sf::st_intersects(xx, sfbbox_rpt)
543	!	xx <- xx[lengths(inter) > 0,]
544	!	if(length(xx) == 0)
545		{
546	!	e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
547	!	stop(e, call. = FALSE)
548		}
549	!	inter <- sf::st_intersects(sgrid, xx)
550	!	sgrid2 <- sgrid[lengths(inter) > 0,]
551
552	!	inter <- sf::st_contains(xx, rpt)
553	!	sgrid2$measures <- unlist(lapply(inter, function(x) mean(rpt[["measures"]][x], na.rm = TRUE)))
554	!	if(nrow(sgrid2) > 0)
555		{
556	!	sgrid2[is.nan(sgrid2$measures), "measures"] <- tmax + 1
557	!	sgrid2[sgrid2$measures > tmax, "measures"] <- tmax + 1
558		}else
559		{
560	!	e <- "Aucun r\u00e9seau routier n'est disponible pour le calcul d'isocourbes"
561	!	stop(e, call. = FALSE)
562		}
563	!	if (min(sgrid2$measures) > tmax) {
564	!	e <- "Utilisez des 'breaks' plus faibles ou augmenter 'res'"
565	!	stop(e, call. = FALSE)
566		}
567	!	iso <- isopoly(x = sgrid2, breaks = breaks, var = "measures")
568	!	if (!is.na(oprj)) {
569	!	iso <- sf::st_transform(x = iso, oprj)
570		}else {
571	!	iso <- sf::st_transform(x = iso, 4326)
572		}
573
574	!	list_iso[[i]] <- iso
575
576	!	shiny::incProgress(1/dim(measures)[1])
577		}
578		})
579		}
580
581	19x	return(list_iso)
582		}

1		#' @name indTableSrcDst
2		#'
3		#' @title Calculer des indicateurs en volume par source (src) ou par destination (dst)
4		#'
5		#' @description La fonction indTableSrcDst permet de calculer par destination (dst) la somme d'une ou plusieurs variables en volume issues des sources (src), la population par exemple.
6		#'
7		#' La fonction permet également de calculer la part des variables en volume pour chaque source dans l'ensemble des sources ayant une même destination.
8		#'
9		#' @param res data.frame. Résultat de la fonction metricOsrmTable avec nbDstVolOiseau = 1 ou nbDstMeasure = 1.
10		#'
11		#' @return liste de deux objets sf.
12		#'
13		#' Le 1er élément comporte une source (src) par observation. Les variables en volume sont couplées à une variable indiquant la part de ce volume dans l'ensemble des sources ayant la même destination (en pourcentage).
14		#'
15		#' Le 2ème élément comporte une destination (dst) par observation (voir details).
16		#'
17		#' @details La table res doit etre calculée à partir de la fonction metricOsrmTable avec les arguments nbDstVolOiseau = 1 ou nbDstMeasure = 1.
18		#' En effet, il ne faut qu'un seul résultat par source : la destination la plus proche d'une source à vol d'oiseau, en temps ou en distance.
19		#'
20		#' L'ordre des colonnes de res en entrée de indTableSrcDst doit être obligatoirement le même que celui obtenu en sortie de la fonction metricOsrmTable.
21		#'
22		#' Pour calculer les indicateurs, il faut ajouter des variables en volume à la suite du tableau de résultats (la population par source par exemple).
23		#'
24		#' En sortie, le 2ème élément de la liste indique les indicateurs en volume par destination. Il s'agit de la somme de toutes les variables de sources pour chaque destination.
25		#' Il donne également un comptage du nombre de sources allant vers chaque destination.
26		#' Si il n'y a pas de variable en volume ajoutée au tableau de résultats, seul l'indicateur de comptage est indiqué.
27		#'
28		#' Les deux éléments sont des objets sf. Il est alors possible, par exemple, de réaliser une carte en ronds proportionnels par destination selon un indicateur calculé.
29		#'
30		#' @importFrom stats aggregate
31		#' @export
32		#'
33		#' @examples
34		#' # Reproduction d'une table de resultats avec la fonction metricOsrmTable
35		#' res <- data.frame(ID = c(1:4),
36		#' idSrc = c("1","2","3","4"),
37		#' lonSrc = c(5.39200,5.39242,5.37107,5.46476),
38		#' latSrc = c(43.28292,43.28368,43.47900,43.31246),
39		#' idDst = c("B","B","A","C"),
40		#' lonDst = c(5.38385,5.38385,5.47678,5.38219),
41		#' latDst = c(43.28571,43.28571,43.29028,43.44144),
42		#' duree = c(87.3,62.8,726.8,239.7),
43		#' distance = c(1103.3,942.7,8318.6,3252.6),
44		#' pop = c(1204,806,1164,976),
45		#' stringsAsFactors = FALSE)
46		#'
47		#' res_ind <- indTableSrcDst(res = res)
48		#'
49		indTableSrcDst <- function(res)
50		{
51	24x	measure <- c()
52	18x	if(any(names(res) %in% "duree")) measure <- c(measure,"duree")
53	8x	if(any(names(res) %in% "distance")) measure <- c(measure,"distance")
54
55	24x	if(!identical(names(res)[1:7], c("ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst"))) # si les 7 premieres colonnes ne correspondent pas, erreur
56		{
57	4x	if(identical(names(res)[1:7], c("idSrc","ID","lonSrc","latSrc","idDst","lonDst","latDst")))
58		{
59	1x	res <- res[,c(2,1,3:ncol(res))] # si merge de la table de resultat, les 2 premieres colonnes seront inversees, dc on les met dans le bon ordre si l'utilisateur ne l'a pas deja fait.
60		}else
61		{
62	3x	stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
63		}
64		}
65	21x	if(is.null(measure)) # si il n'y a pas de colonnes duree et/ou distance, erreur
66		{
67	2x	stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
68		}
69	19x	if(length(measure)==1)
70		{
71	15x	if(!names(res)[8] %in% measure) # si la 8ème colonne n'est ni duree, ni distance, erreur
72		{
73	1x	stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
74		}
75		}
76
77	18x	if(any(measure %in% "duree"))
78		{
79	15x	if(any(res$duree %in% -999999.00))
80		{
81	2x	nbNonCalc <- length(res$duree[res$duree %in% -999999.00])
82	2x	if(nbNonCalc == 1)
83		{
84	1x	message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (duree = -999999.00)."))
85	1x	message(paste0("Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs par source et par destination"))
86		}
87	2x	if(nbNonCalc > 1)
88		{
89	1x	message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (duree = -999999.00)."))
90	1x	message(paste0("Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs par source et par destination."))
91		}
92	2x	res <- res[!res$duree %in% -999999.00,]
93		}
94		}
95
96	18x	if(any(measure %in% "distance") & !any(measure %in% "duree"))
97		{
98	3x	if(any(res$distance %in% -999999.00))
99		{
100	2x	nbNonCalc <- length(res$distance[res$distance %in% -999999.00])
101	2x	if(nbNonCalc == 1)
102		{
103	1x	message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (distance = -999999.00)."))
104	1x	message(paste0("Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs par source et par destination."))
105		}
106	2x	if(nbNonCalc > 1)
107		{
108	1x	message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (distance = -999999.00)."))
109	1x	message(paste0("Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs par source et par destination."))
110		}
111	2x	res <- res[!res$distance %in% -999999.00,]
112		}
113		}
114
115	18x	if(length(res$idSrc) != length(unique(res$idSrc)))
116		{
117	1x	message(paste0("[WARNING] Il existe plusieurs sources identiques alors qu'il n'en faut qu'une seule pour le calcul de l'indicateur."))
118	1x	message(paste0("Veuillez filtrer la table de r\u00e9sultats ou r","\u00e9","ex","\u00e9","cutez la fonction metricOsrmTable "))
119	1x	message(paste0("avec les arguments nbDstVolOiseau = 1 ou nbDstMeasure = 1."))
120	1x	return(NULL)
121		}
122
123	17x	sf_src <- unique(convertTo(from = res[,c(2:4)], to = "sf", fromEpsg = 4326))
124	17x	sf_src[,names(res)[8:length(names(res))]] <- res[,8:ncol(res)]
125	17x	names(sf_src)[1] <- "idSrc"
126	17x	names(attr(sf_src, "agr"))[1] <- "idSrc"
127
128	17x	sf_dst <- unique(convertTo(from = res[,c(5:7)], to = "sf", fromEpsg = 4326))
129	17x	names(sf_dst)[1] <- "idDst"
130	17x	names(attr(sf_dst, "agr"))[1] <- "idDst"
131
132	17x	parSrc <- merge(sf_src, res[,c("idSrc","idDst")], by = "idSrc")
133	17x	parSrc <- parSrc[,c(1,ncol(parSrc)-1,2:(ncol(parSrc)-2),ncol(parSrc))]
134
135	17x	parDstNb <- stats::aggregate(parSrc$idDst, by = list(parSrc$idDst), FUN = length)
136	17x	names(parDstNb) <- c("idDst","nbSrc")
137
138	17x	if(ncol(parSrc) > 5 \| (ncol(parSrc) > 4 & length(measure) == 1))
139		{
140	5x	parDstSum <- stats::aggregate(parSrc[,(3+length(measure)):(ncol(parSrc)-1)], by = list(parSrc$idDst), FUN = sum)
141	4x	names(parDstSum) <- c("idDst",names(parSrc)[(3+length(measure)):(length(names(parSrc))-1)],"geometry")
142	4x	parDst <- merge(parDstNb, as.data.frame(parDstSum)[,c(1,2:(ncol(parDstSum)-1))], by = "idDst")
143	4x	parDst <- merge(sf_dst, parDst, by = "idDst")
144		}else
145		{
146	12x	parDst <- merge(sf_dst, parDstNb, by = "idDst")
147		}
148
149	16x	if(ncol(parDst) > 3)
150		{
151	4x	var <- names(parDst)[3:(ncol(parDst)-1)]
152
153	4x	parSrc <- merge(parSrc, as.data.frame(parDst)[,c("idDst",var)], by = "idDst")
154	4x	names(parSrc) <- c("idDst","idSrc",measure,var,paste0("tot_",var),"geometry")
155
156	4x	parSrc[,paste0("part_",var)] <- round(as.data.frame(parSrc)[,var] / as.data.frame(parSrc)[,paste0("tot_",var)]*100,3)
157
158	4x	parSrc <- parSrc[,c("idSrc","idDst",measure,as.vector(sapply(1:length(var), function(x) c(var[x],paste0("part_",var)[x]))),"geometry")]
159	4x	names(attr(parSrc, "agr")) <- names(parSrc)[-length(names(parSrc))]
160		}
161
162	16x	return(list(parSrc,parDst))
163		}

1		#' @name indIsoSpatial
2		#'
3		#' @title Calculer des indicateurs en volume par regroupement de mailles selon leur appartenance spatiale
4		#'
5		#' @description La fonction indIsoSpatial permet de sommer une ou plusieurs variables (la population par exemple)
6		#' d'une maille (maille communale ou grille par exemple) selon leur appartenance spatiale à une zone particulière (polygones d'isochrones par exemple).
7		#'
8		#' @param pol,maille objet sf (POLYGON ou MULTIPOLYGON).
9		#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
10		#' @param var vecteur texte. Noms des variables en volume à sommer de l'objet maille.
11		#' @param pond vecteur numérique. Noms des variables de pondération de l'objet maille. A appliquer aux variables à sommer. Par défaut NULL.
12		#' @param choixIntersect numérique. 1, 2 ou 3 (voir details). Par défaut 1.
13		#' @param return vecteur texte. "pol", "maille" ou c("pol","maille") (voir details). Par défaut "pol".
14		#' @param idGroup texte. Nom de la variable identifiant les pol et constituant les groupes de maille si return contient "maille". Par défaut NULL.
15		#'
16		#' @return Si return == "pol", l'objet pol, enrichi des variables sommées issues de l'objet maille.
17		#'
18		#' Si return == "maille", l'objet maille, enrichi d'une variable indiquant le groupe d'appartenance de la maille à pol et les valeurs sommées pour chaque groupe.
19		#'
20		#' Si return == c("pol","maille"), une liste contenant pol et maille est renvoyée, enrichie des variables décrites ci-dessus.
21		#'
22		#' @details Si les variables de pondérations sont renseignées, le vecteur des variables de pondérations doit respecter le même ordre que le vecteur des variables à sommer.
23		#'
24		#' Le paramètre choixIntersect vaut 1, 2 ou 3. Si une maille intersecte pol :
25		#'
26		#' choix 1 : la totalité de la variable de la maille intersectée est comptabilisée dans la somme.
27		#'
28		#' choix 2 : la maille est tronquée selon le découpage de pol. Les valeurs à sommer sont recalculées selon le prorata de la surface de la maille tronquée.
29		#'
30		#' choix 3 : la totalité de la variable de la maille intersectée est exclue de la somme.
31		#'
32		#' Les arguments pol et maille doivent être dans le même système de projection, peu importe le système.
33		#'
34		#' @importFrom sf st_as_sf st_transform st_cast st_intersects st_intersection st_area
35		#' @importFrom methods is
36		#' @export
37		#'
38		#' @examples
39		#' # Specification d'un serveur osrm obligatoire pour executer les exemples
40		#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
41		#'
42		#' # Specification du profil
43		#' options(osrm.profile = "driving")
44		#'
45		#' # Appel a la fonction metricOsrmIso
46		#' iso <- metricOsrmIso(loc = data.frame(lon = 4.92,lat = 46.15))
47		#'
48		#' # Conversion en projection metrique Lambert 93 (EPSG 2154)
49		#' iso_L93 <- convertTo(from = iso[[1]],
50		#' toEpsg = 2154)
51		#'
52		#' # Construction d'une grille
53		#' grille <- sf::st_as_sf(x = sf::st_make_grid(iso_L93, cellsize = 52000))
54		#'
55		#' # Ajout d'une variable en volume a la grille
56		#' grille$vol <- c(15,11,26,5,3,17)
57		#'
58		#' # Calcul de l'indicateur spatial
59		#' ind_res <- indIsoSpatial(pol = iso_L93,
60		#' maille = grille,
61		#' var = "vol",
62		#' choixIntersect = 1,
63		#' return = c("pol","maille"),
64		#' idGroup = "id")
65		#'
66		indIsoSpatial <- function(pol, maille, var, pond = NULL, choixIntersect = 1, return = "pol", idGroup = NULL)
67		{
68	30x	if(any(!return %in% c("pol","maille")))
69		{
70	1x	stop(simpleError("return doit etre 'pol', 'maille' ou c('pol','maille')."))
71		}
72
73	29x	if(!choixIntersect %in% c(1,2,3))
74		{
75	1x	stop(simpleError("choixIntersect doit etre 1, 2 ou 3."))
76		}
77
78	28x	if(methods::is(pol, "Spatial")) {
79	!	pol <- sf::st_as_sf(pol)
80	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
81		}
82	28x	if(methods::is(maille, "Spatial")) {
83	!	maille <- sf::st_as_sf(maille)
84	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
85		}
86
87	28x	if(length(which(names(maille) %in% var)) != length(var))
88		{
89	2x	stop(simpleError("Toutes les variables du vecteur var doivent \u00eatre presentes dans l'objet maille."))
90		}
91
92	26x	if(any(return %in% "maille") & !any(names(pol) %in% idGroup))
93		{
94	1x	stop(simpleError("Si return contient 'maille', idGroup doit \u00eatre la variable identifiant de pol."))
95		}
96
97	25x	if(!is.null(pond))
98		{
99	14x	if(length(var) != length(pond))
100		{
101	1x	stop(simpleError("Le vecteur var doit \u00eatre de m\u00eame longueur que le vecteur pond"))
102		}
103	13x	if(length(which(names(maille) %in% pond)) != length(pond))
104		{
105	1x	stop(simpleError("Toutes les variables du vecteur pond doivent \u00eatre presentes dans l'objet maille."))
106		}
107	12x	pondNULL <- FALSE
108	11x	}else if(is.null(pond))
109		{
110	11x	for(i in 1:length(var))
111		{
112	17x	maille[,paste0("pond",i)] <- 1
113	17x	pond <- c(pond,paste0("pond",i))
114		}
115	11x	pondNULL <- TRUE
116		}else
117		{}
118
119	23x	pol <- sf::st_transform(pol, crs = 2154)
120	23x	maille <- sf::st_transform(maille, crs = 2154)
121
122	23x	for(i in 1:length(var))
123		{
124	38x	pol[,var[i]] <- NA
125		}
126
127	9x	if(any(return %in% "maille")) listMaille <- list()
128
129	23x	pb <- progress::progress_bar$new(
130	23x	format = paste0("Calcul en cours pour ",nrow(pol)," polygones - [:bar] :percent :elapsed"),
131	23x	total = nrow(pol), clear = FALSE, width= 80
132		)
133
134	23x	pb$tick(0)
135
136	23x	for(i in 1:nrow(pol))
137		{
138		# on garde tous les carreaux inclus dans le polygone et ceux qui touchent
139	23x	carr_intersects <- as.numeric(sf::st_intersects(maille,pol[i,]))
140	23x	carr_intersects <- data.frame(i=carr_intersects,idx=1:length(carr_intersects), stringsAsFactors = FALSE)
141	!	if(any(is.na(carr_intersects$i))) carr_intersects <- carr_intersects[!is.na(carr_intersects$i),]
142
143	23x	if(choixIntersect == 1)
144		{
145	9x	maille_1 <- maille[carr_intersects$idx,]
146
147	9x	calcul_1 <- round(apply(as.data.frame(as.data.frame(maille_1)[,var])*as.data.frame(as.data.frame(maille_1)[,pond]),2,sum),1)
148	9x	calcul_2 <- 0
149	9x	calcul_3 <- 0
150
151	9x	if(any(return %in% "maille"))
152		{
153	3x	maille_1$groupe_pol <- as.data.frame(pol)[i,idGroup]
154	3x	for(j in 1:length(var))
155		{
156	6x	maille_1[,paste0("sum_",var[j])] <- calcul_1[j]
157		}
158	3x	maille_2 <- NULL
159	3x	maille_3 <- NULL
160		}
161		}
162
163	23x	if(choixIntersect %in% c(2,3))
164		{
165		# On repère d'abord les carreaux qui touchent ...
166	14x	carr_touches <- sf::st_cast(pol[i,], to = "MULTILINESTRING")
167	14x	carr_touches <- as.numeric(sf::st_intersects(maille,carr_touches))
168	14x	carr_touches <- data.frame(i=carr_touches,idx=1:length(carr_touches), stringsAsFactors = FALSE)
169	14x	if(any(is.na(carr_touches$i))) carr_touches <- carr_touches[!is.na(carr_touches$i),]
170	14x	maille_4 <- maille[carr_touches$idx,]
171
172		# ... puis on les enlève du résultat d'intersects
173	14x	carr_contains <- carr_intersects[!carr_intersects$idx %in% carr_touches$idx,]
174	14x	maille_3 <- maille[carr_contains$idx,]
175
176	14x	calcul_3 <- round(apply(as.data.frame(as.data.frame(maille_3)[,var])*as.data.frame(as.data.frame(maille_3)[,pond]),2,sum),1)
177
178	14x	if(choixIntersect == 3)
179		{
180	7x	calcul_1 <- 0
181	7x	calcul_2 <- 0
182
183	7x	maille_1 <- NULL
184	7x	maille_2 <- NULL
185
186	7x	if(any(return %in% "maille"))
187		{
188	3x	maille_3$groupe_pol <- as.data.frame(pol)[i,idGroup]
189	3x	for(j in 1:length(var))
190		{
191	6x	maille_3[,paste0("sum_",var[j])] <- calcul_3[j]
192		}
193		}
194		}
195		}
196
197	23x	if(choixIntersect == 2)
198		{
199		# On tronque les carreaux qui touchent à partir de maille_4
200	7x	suppressWarnings(carr_intersection <- sf::st_intersection(maille_4,pol[i,]))
201	7x	carr_intersection <- carr_intersection[,names(maille_4)]
202	7x	surf_intersection <- as.numeric(sf::st_area(carr_intersection))
203	7x	surf_carr_entier <- max(as.numeric(sf::st_area(maille_3)))
204	7x	rapport_surf_intersection <- surf_intersection/surf_carr_entier
205
206	7x	calcul_1 <- 0
207	7x	calcul_2 <- round(calcul_3 + apply(as.data.frame(as.data.frame(maille_4)[,var])as.data.frame(as.data.frame(maille_4)[,pond])rapport_surf_intersection,2,sum),1)
208	7x	calcul_3 <- 0
209
210	7x	if(any(return %in% "maille"))
211		{
212	3x	maille_1 <- NULL
213
214		# On colle à tous les carreaux inclus entièrement dans le polygone (maille_3)
215	3x	maille_2 <- rbind(carr_intersection,maille_3)
216
217	3x	maille_2$groupe_pol <- as.data.frame(pol)[i,idGroup]
218	3x	for(j in 1:length(var))
219		{
220	6x	maille_2[,paste0("sum_",var[j])] <- calcul_2[j]
221		}
222
223	3x	maille_3 <- NULL
224		}
225		}
226
227	23x	if(any(return %in% "pol"))
228		{
229	17x	pol[i,var] <- calcul_1 + calcul_2 + calcul_3
230	17x	attr(pol, "agr") <- c("id","min","max","center",var)
231		}
232
233	23x	if(any(return %in% "maille"))
234		{
235	9x	listMaille[[i]] <- rbind(maille_1,maille_2,maille_3)
236		}
237
238	23x	pb$tick()
239		}
240
241	23x	if(any(return %in% "maille"))
242		{
243	9x	maille <- do.call(rbind, listMaille)
244	9x	maille <- maille[order(as.numeric(row.names(maille))),]
245
246	3x	if(pondNULL) maille <- maille[,-which(names(maille) %in% pond)]
247		}
248
249	14x	if(length(return) == 1 & any(return %in% "pol")) return(pol)
250	6x	if(length(return) == 1 & any(return %in% "maille")) return(maille)
251	3x	if(length(return) == 2) return(list(pol,maille))
252		}

1		input_route <-
2		function (x, id, single = TRUE)
3		{
4	64x	if (single) {
5	58x	if (is.vector(x)) {
6	42x	if (length(x) == 2) {
7	4x	id <- id
8	4x	i <- 0
9		}
10		else {
11	38x	i <- 1
12	38x	id <- x[i]
13		}
14	42x	lon <- clean_coord(x[i + 1])
15	42x	lat <- clean_coord(x[i + 2])
16		}
17	58x	if (methods::is(x, "Spatial")) {
18	!	x <- sf::st_as_sf(x[1, ])
19	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf.")
20		}
21	58x	if (is.data.frame(x)) {
22	16x	if (methods::is(x, "data.table")) {
23	4x	warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame.")
24	4x	x <- as.data.frame(x)
25		}
26	16x	if (methods::is(x, "sf")) {
27	4x	x <- sfToDf(x)
28	4x	i <- 1
29	4x	id <- x[1, i]
30		}
31		else {
32	12x	if (length(x) == 2) {
33	4x	i <- 0
34	4x	id <- id
35		}
36		else {
37	8x	i <- 1
38	8x	id <- x[1, i]
39		}
40		}
41	16x	lon <- clean_coord(x[1, i + 1])
42	16x	lat <- clean_coord(x[1, i + 2])
43		}
44	58x	return(list(id = id, lon = lon, lat = lat))
45		}
46		else {
47	6x	if (methods::is(x, "Spatial")) {
48	!	x <- sf::st_as_sf(x)
49	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf.")
50		}
51	6x	if (methods::is(x, "data.table")) {
52	!	warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame.")
53	!	x <- as.data.frame(x)
54		}
55	6x	if (is.data.frame(x)) {
56	6x	if (methods::is(x, "sf")) {
57	2x	x <- sfToDf(x)
58	2x	i <- 1
59	2x	id1 <- x[1, 1]
60	2x	id2 <- x[nrow(x), 1]
61		}
62		else {
63	4x	if (length(x) == 2) {
64	1x	i <- 0
65	1x	id1 <- "src"
66	1x	id2 <- "dst"
67		}
68		else {
69	3x	i <- 1
70	3x	id1 <- x[1, 1]
71	3x	id2 <- x[nrow(x), 1]
72		}
73		}
74	6x	lon <- clean_coord(x[, i + 1])
75	6x	lat <- clean_coord(x[, i + 2])
76		}
77	6x	return(list(id1 = id1, id2 = id2, lon = lon, lat = lat))
78		}
79		}

1		# Calcul la durée et/ou la distance
2		#
3		# La fonction osrmTable_1n_n1 permet de calculer la durée et la distance d'un point vers un groupe de points
4		# ou d'un groupe de points vers un point.
5		#
6		# @param src data.frame (3 colonnes id/lon/lat).
7		# @param dst data.frame (3 colonnes id/lon/lat).
8		# @param duree booleen. La fonction retourne la durée. Par défaut à TRUE.
9		# @param distance booleen. La fonction retourne la distance. Par défaut à TRUE.
10		# @param exclude string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
11		#
12		# @return data.frame
13		osrmTable_1n_n1 <- function(src, dst, duree, distance, exclude)
14		{
15	51x	nb_row <- 500 # nombre de couples max par requete 1->n ou n->1
16	51x	res_duree <- data.frame()
17	51x	res_distance <- data.frame()
18	51x	res_destinations <- data.frame()
19	51x	res_sources <- data.frame()
20	51x	measure <- NULL
21	49x	if(duree) measure <- "duration"
22	49x	if(distance) measure <- c(measure,"distance")
23	1x	if(is.null(measure)) measure <- "duration"
24	50x	if(is.null(exclude))
25		{
26	49x	exclude_str <- ""
27		}else{
28	1x	exclude <- paste(exclude, sep = "", collapse = ",")
29	1x	exclude_str <- paste("&exclude=", exclude, sep = "")
30		}
31	50x	src_seul <- FALSE
32	50x	dst_seul <- FALSE
33
34	50x	if(nrow(src)==1)
35		{
36	44x	if(nrow(dst)==nb_row)
37		{
38	!	nb_boucle <- 0
39		}else
40		{
41	44x	nb_boucle <- nrow(dst)%/%nb_row
42		}
43	44x	src_seul <- TRUE
44	4x	}else if(nrow(dst)==1)
45		{
46	4x	if(nrow(src)==nb_row)
47		{
48	!	nb_boucle <- 0
49		}else
50		{
51	4x	nb_boucle <- nrow(src)%/%nb_row
52		}
53	4x	dst_seul <- TRUE
54		}else{}
55
56	48x	list_res_1n_n1 <- list()
57	48x	for(i in 0:nb_boucle)
58		{
59	48x	if(dst_seul & nrow(src) > 0)
60		{
61	4x	if(nrow(src)<nb_row)
62		{
63	4x	idx_src <- 1:nrow(src)
64		}else
65		{
66	!	idx_src <- 1:nb_row
67		}
68
69	4x	idx_dst <- idx_src[length(idx_src)]
70
71	4x	res <- requeteOsrm_n1(src = src, idx_src = idx_src, dst = dst, idx_dst = idx_dst, measure = measure, exclude_str = exclude_str)
72
73	44x	}else if(src_seul & nrow(dst) > 0)
74		{
75	42x	idx_src <- 0
76
77	42x	if(nrow(dst)<nb_row)
78		{
79	42x	idx_dst <- 1:nrow(dst)
80		}else
81		{
82	!	idx_dst <- 1:nb_row
83		}
84
85	42x	res <- requeteOsrm_1n(src = src, idx_src = idx_src, dst = dst, idx_dst = idx_dst, measure = measure, exclude_str = exclude_str)
86
87		}else{}
88
89	47x	if(nrow(src) > 0 & nrow(dst) > 0)
90		{
91	45x	if(duree)
92		{
93		# Cas des couples non calculés
94	44x	if(length(which(sapply(res$durations, function(x) is.null(x[[1]])))) > 0)
95		{
96	!	idx_0 <- which(sapply(res$durations, function(x) is.null(x[[1]])))
97	!	for(j in 1:length(idx_0))
98		{
99	!	res$durations[[idx_0[j]]] <- -60
100		}
101		}
102		# Cas des valeurs négatives
103	44x	if(length(which(sapply(res$durations, function(x) x[[1]] < 0))) > 0)
104		{
105	!	idx_0 <- which(sapply(res$durations, function(x) x[[1]] < 0))
106	!	for(j in 1:length(idx_0))
107		{
108	!	if(any(res$durations[[idx_0[j]]] != -60)) res$durations[[idx_0[j]]] <- abs(res$durations[[idx_0[j]]])
109		}
110		}
111
112	44x	aa <- lapply(1:length(res$durations[[1]]), function(x) if(is.null(res$durations[[1]][[x]])) res$durations[[1]][[x]] <<- -60)
113	44x	rm(aa)
114	44x	res_duree <- data.frame(duree=unlist(res$durations))
115		}
116	45x	if(distance)
117		{
118		# Cas des couples non calculés
119	44x	if(length(which(sapply(res$distances, function(x) is.null(x[[1]])))) > 0)
120		{
121	!	idx_0 <- which(sapply(res$distances, function(x) is.null(x[[1]])))
122	!	for(j in 1:length(idx_0))
123		{
124	!	res$distances[[idx_0[j]]] <- -1000
125		}
126		}
127
128		# Cas des valeurs négatives
129	44x	if(length(which(sapply(res$distances, function(x) x[[1]] < 0))) > 0)
130		{
131	!	idx_0 <- which(sapply(res$distances, function(x) x[[1]] < 0))
132	!	for(j in 1:length(idx_0))
133		{
134	!	if(any(res$distances[[idx_0[j]]] != -1000)) res$distances[[idx_0[j]]] <- abs(res$distances[[idx_0[j]]])
135		}
136		}
137
138	44x	aa <- lapply(1:length(res$distances[[1]]), function(x) if(is.null(res$distances[[1]][[x]])) res$distances[[1]][[x]] <<- -1000)
139	44x	rm(aa)
140	44x	res_distance <- data.frame(distance=unlist(res$distances))
141		}
142	45x	coords <- coordFormat(res = res, src = src[1:length(idx_src),], dst = dst[1:length(idx_dst),])
143	45x	res_sources <- coords$sources
144	45x	res_destinations <- coords$destinations
145
146	45x	names(res_sources) <- c("idSrc","lonSrc","latSrc")
147	45x	names(res_destinations) <- c("idDst","lonDst","latDst")
148
149	45x	res_1n_n1 <- cbind(res_sources,res_destinations)
150	44x	if(duree) res_1n_n1 <- cbind(res_1n_n1,res_duree)
151	44x	if(distance) res_1n_n1 <- cbind(res_1n_n1,res_distance)
152
153	45x	list_res_1n_n1[[i+1]] <- res_1n_n1
154
155	45x	if(dst_seul)
156		{
157	4x	src <- src[-idx_src,]
158	41x	}else if(src_seul)
159		{
160	41x	dst <- dst[-idx_dst,]
161		}
162		}
163		}
164
165	47x	res_1n_n1 <- do.call(rbind,list_res_1n_n1)
166	47x	res_1n_n1$idSrc <- as.character(res_1n_n1$idSrc)
167	47x	res_1n_n1$idDst <- as.character(res_1n_n1$idDst)
168
169	47x	row.names(res_1n_n1) <- c(1:nrow(res_1n_n1))
170
171	45x	return(res_1n_n1)
172		}

1		# @name osrmTableFiltre
2		# @title La fonction interne osrmTableFiltre.
3		# @description La fonction interne osrmTableFiltre permet de filtrer n destinations les plus proche d'une source dans un rayonMax.
4		# @param code_epsg Entier numérique de longueur 4.
5		# @inheritParams metriOsrmTable -code_epsg
6		# @return Un data.frame
7		# @noRd
8		# @export
9		#
10		osrmTableFiltre <- function(src, dst, duree, distance, exclude, rayonMax, nbDstVolOiseau, nbDstMeasure, optiMeasure, code_epsg, interactive)
11		{
12	20x	src <- unique(src)
13	20x	dst <- unique(dst)
14
15	20x	if(any(duplicated(as.data.frame(dst)[,1])))
16		{
17	1x	message(paste0("[WARNING] Attention, il y a des doublons dans les identifiants des destinations. Ils devraient \u00eatre unique si rayonMax ou nbDstVolOiseau > 0."))
18		}
19
20	20x	rayonMax <- rayonMax*1000
21
22	20x	coord_src <- convertTo(from = src, fromEpsg = 4326, toEpsg = code_epsg)
23
24	19x	coord_dst <- convertTo(from = dst, fromEpsg = 4326, toEpsg = code_epsg)
25
26	19x	mat <- NULL
27
28	19x	if(rayonMax > 0 & nbDstVolOiseau > 0) # n dst par src les plus proches dans un rayon de x km max
29		{
30	!	if(nbDstVolOiseau > nrow(dst)) nbDstVolOiseau <- nrow(dst)
31	7x	res <- tryCatch({
32	7x	mat <- RANN::nn2(coord_dst[,-1], coord_src[,-1], k = nbDstVolOiseau, searchtype = 'radius', radius = rayonMax)
33	7x	},error = function(err){
34	!	message(paste0("Aucun point n'a \u00e9t\u00e9 trouv\u00e9 \u00e0 moins de ",rayonMax/1000," km \u00e0 vol d'oiseau"))
35		})
36	12x	}else if(rayonMax == 0 & nbDstVolOiseau > 0) # n dst par src les plus proches dans l'ensemble des src
37		{
38	!	if(nbDstVolOiseau > nrow(dst)) nbDstVolOiseau <- nrow(dst)
39	2x	res <- tryCatch({
40	2x	mat <- RANN::nn2(coord_dst[,-1], coord_src[,-1], k = nbDstVolOiseau)
41	2x	},error = function(err){
42	!	message(paste0("Aucun point n'a \u00e9t\u00e9 trouv\u00e9"))
43		})
44	10x	}else if(rayonMax > 0 & nbDstVolOiseau == 0) # tous les dst par src dans un rayon de x km max
45		{
46	9x	res <- tryCatch({
47	9x	mat <- RANN::nn2(coord_dst[,-1], coord_src[,-1], k = nrow(dst), searchtype = 'radius', radius = rayonMax)
48	9x	},error = function(err){
49	!	message(paste0("Aucun point n'a \u00e9t\u00e9 trouv\u00e9 \u00e0 moins de ",rayonMax/1000," km \u00e0 vol d'oiseau"))
50		})
51		}else
52		{
53		# tous les dst dans l'ensemble des src
54		# rayonMax == 0 & nbPlusProche == 0 --> fct osrmTableCartesien
55	1x	stop(simpleError("Veuillez svp utiliser la fonction osrmTableCartesien."))
56		}
57
58	18x	if(!is.null(mat))
59		{
60	18x	idx <- lapply(1:ncol(mat$nn.idx), function(x) {
61	37x	dt <- data.frame(idx_src = 1:nrow(mat$nn.idx),
62	37x	idx_dst = mat$nn.idx[,x],
63	37x	stringsAsFactors = FALSE)
64	20x	if(any(which(dt$idx_dst == 0)) > 0) dt <- dt[-which(dt$idx_dst == 0),]
65	37x	return(dt)
66		})
67
68	18x	idx <- do.call(rbind, idx)
69	18x	idx <- idx[order(idx$idx_src),]
70
71	18x	if(nrow(idx) > 0)
72		{
73	15x	src <- src[idx$idx_src,]
74	15x	dst <- dst[idx$idx_dst,]
75
76	15x	res <- osrmTableFaceAFace(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
77		# on met les -999999 (en realite -60 et -1000 issus de osrmTableFaceAFace) en 999999
78		# pour eviter qu ils ne se retrouvent en tete lors du classement de list_dtIdSrcMin
79	13x	res$duree[res$duree == -60.0] <- 999999
80	13x	res$distance[res$distance == -1000.0] <- 999999
81	13x	if(nbDstMeasure > 0) # on filtre apres les calculs pour garder les n dst par src les plus proches en temps ou en distance
82		{
83	7x	list_dtIdSrc <- split(res,res$idSrc)
84
85	7x	if(optiMeasure == "duree")
86		{
87	4x	list_dtIdSrcMin <- lapply(1:length(list_dtIdSrc), function (x) list_dtIdSrc[[x]][order(list_dtIdSrc[[x]]$duree)[1:nbDstMeasure],])
88	3x	}else if(optiMeasure == "distance")
89		{
90	1x	list_dtIdSrcMin <- lapply(1:length(list_dtIdSrc), function (x) list_dtIdSrc[[x]][order(list_dtIdSrc[[x]]$distance)[1:nbDstMeasure],])
91		}else
92		{
93	2x	stop(simpleError("optiMeasure doit etre 'duree' ou 'distance'."))
94		}
95
96	5x	res <- do.call(rbind,list_dtIdSrcMin)
97		# on remet les -999999 en -60 et -1000
98	5x	res$duree[res$duree == 999999] <- -60.0
99	5x	res$distance[res$distance == 999999] <- -1000.0
100		}
101
102	!	if(any(is.na(res))) res <- res[!is.na(res$ID),]
103
104	11x	res$ID <- c(1:nrow(res))
105	11x	row.names(res) <- res$ID
106		}else
107		{
108	3x	res <- NULL
109		}
110		}else
111		{
112	!	res <- NULL
113		}
114
115	14x	return(res)
116		}

1		# @name verifParamSrcDst
2		# @title Filtre la conformité des paramètres sources et destinations.
3		# @description Fonction interne qui réalise une grille si l'objet passé en paramètre est un objet sf.
4		# @param src Objet sf ou dataframe 2 ou 3 colonnes contenant deux vecteurs numériques sans valeurs manquantes.
5		# @param dst Objet sf ou dataframe 2 ou 3 colonnes contenant deux vecteurs numériques sans valeurs manquantes.
6		# @return Erreur si les paramètres ne sont pas conformes.
7		# @importFrom methods is
8		# @noRd
9		# @export
10		# @examples
11		# #erreur attendue car présence d'une 4 eme colonne pas autorisee
12		# verifParamSrcDst(
13		# src=data.frame(
14		# code=c('adresse1','adresse2'),
15		# lon=c(5.38589,5.41172),
16		# lat=c(43.30134,43.27183),
17		# aie=c('une_4eme_colonne','pas_autorisee')
18		#
19		# ),
20		# dst=data.frame(
21		# id='Traverse de la chapelle 13011 Marseille',
22		# lon=c(5.51193),
23		# lat=c(43.30201)
24		# )
25		# )
26
27		verifParamSrcDst <- function(src,dst)
28		{
29	46x	msg_error1<-msg_error2<-msg_error3<-msg_error4<-msg_error5<-msg_error6<-msg_error7<-msg_error8<-msg_error9<-msg_error10 <- NULL
30	46x	msg_error11<-msg_error12<-msg_error13<-msg_error14 <- NULL
31
32	46x	if(is.vector(src))
33		{
34	1x	if(length(src)!=3) msg_error1 <- "Le vecteur src doit comporter 3 valeurs (un identifiant puis les coordonnees lon, lat) / "
35	2x	if(any(is.na(src)) \| !is.numeric(src)) msg_error2 <- "Le vecteur src doit \u00eatre numerique et sans valeur manquante / "
36		}
37	46x	if(is.vector(dst))
38		{
39	1x	if(length(dst)!=3) msg_error3 <- "Le vecteur dst doit comporter 3 valeurs (un identifiant puis les coordonnees lon, lat) / "
40	2x	if(any(is.na(dst)) \| !is.numeric(dst)) msg_error4 <- "Le vecteur dst doit \u00eatre numerique et sans valeur manquante / "
41		}
42	46x	if(any(class(src)=="data.frame") & length(class(src))==1)
43		{
44	39x	if(ncol(src)!=3)
45		{
46	3x	msg_error5 <- "Le data.frame src doit comporter 3 colonnes (un identifiant puis les coordonnees lon, lat) / "
47		}else
48		{
49	2x	if(any(is.na(src[,2])) \| !is.numeric(src[,2])) msg_error6 <- "La colonne lon doit \u00eatre numerique et sans valeur manquante / "
50	4x	if(any(is.na(src[,3])) \| !is.numeric(src[,3])) msg_error7 <- "La colonne lat doit \u00eatre numerique et sans valeur manquante / "
51		}
52		}
53	46x	if(any(class(dst)=="data.frame") & length(class(dst))==1)
54		{
55	39x	if(ncol(dst)!=3)
56		{
57	3x	msg_error8 <- "Le data.frame dst doit comporter 3 colonnes (un identifiant puis les coordonnees lon, lat) / "
58		}else
59		{
60	2x	if(any(is.na(dst[,2])) \| !is.numeric(dst[,2])) msg_error9 <- "La colonne lon doit \u00eatre numerique et sans valeur manquante / "
61	4x	if(any(is.na(dst[,3])) \| !is.numeric(dst[,3])) msg_error10 <- "La colonne lat doit \u00eatre numerique et sans valeur manquante / "
62		}
63		}
64	46x	if(testSf(src))
65		{
66	1x	if(!any(class(sf::st_geometry(src)) %in% c("sfc_POINT","sfc_POLYGON","sfc_MULTIPOLYGON"))) msg_error11 <- "L'objet sf src doit etre un sfc_POINT, sfc_POLYGON ou sfc_MULTIPOLYGON / "
67	1x	if(ncol(src)<2) msg_error12 <- "L'objet sf src doit comporter au moins 2 colonnes (un identifiant et la geometry) / "
68		}
69	46x	if(testSf(dst))
70		{
71	1x	if(!any(class(sf::st_geometry(dst)) %in% c("sfc_POINT","sfc_POLYGON","sfc_MULTIPOLYGON"))) msg_error13 <- "L'objet sf dst doit etre un sfc_POINT, sfc_POLYGON ou sfc_MULTIPOLYGON / "
72	1x	if(ncol(dst)<2) msg_error14 <- "L'objet sf dst doit comporter au moins 2 colonnes (un identifiant et la geometry) / "
73		}
74
75	46x	if(any(!is.null(msg_error1),!is.null(msg_error2),!is.null(msg_error3),!is.null(msg_error4),!is.null(msg_error5),!is.null(msg_error6),
76	46x	!is.null(msg_error7),!is.null(msg_error8),!is.null(msg_error9),!is.null(msg_error10),!is.null(msg_error11),!is.null(msg_error12),
77	46x	!is.null(msg_error13),!is.null(msg_error14)))
78		{
79	13x	stop(simpleError(paste0(msg_error1,msg_error2,msg_error3,msg_error4,msg_error5,msg_error6,msg_error7,msg_error8,
80	13x	msg_error9,msg_error10,msg_error11,msg_error12,msg_error13,msg_error14)))
81		}
82		}

1		coordFormat <- function (res, src, dst, faceAFace = TRUE)
2		{
3	137x	sources <- data.frame()
4	137x	destinations <- data.frame()
5	137x	nbSrc <- length(res$sources)
6	137x	nbDst <- length(res$destinations)
7
8	137x	if(nbSrc==1)
9		{
10	68x	aa <- lapply(1:nbSrc, function(x) sources <<- rbind(sources,data.frame(id=rep(src$id[x],nbDst),lon=rep(as.numeric(clean_coord(res$sources[[x]]$location[1])),nbDst),lat=rep(as.numeric(clean_coord(res$sources[[x]]$location[2])),nbDst), stringsAsFactors = FALSE)))
11	68x	aa <- lapply(1:nbDst, function(x) destinations <<- rbind(destinations,data.frame(id=dst$id[x],lon=as.numeric(clean_coord(res$destinations[[x]]$location[1])),lat=as.numeric(clean_coord(res$destinations[[x]]$location[2])), stringsAsFactors = FALSE)))
12	69x	}else if(nbDst==1)
13		{
14	11x	aa <- lapply(1:nbSrc, function(x) sources <<- rbind(sources,data.frame(id=src$id[x],lon=as.numeric(clean_coord(res$sources[[x]]$location[1])),lat=as.numeric(clean_coord(res$sources[[x]]$location[2])), stringsAsFactors = FALSE)))
15	11x	aa <- lapply(1:nbDst, function(x) destinations <<- rbind(destinations,data.frame(id=rep(dst$id[x],nbSrc),lon=rep(as.numeric(clean_coord(res$destinations[[x]]$location[1])),nbSrc),lat=rep(as.numeric(clean_coord(res$destinations[[x]]$location[2]),nbSrc)), stringsAsFactors = FALSE)))
16		}else{
17	58x	aa <- lapply(1:nbSrc, function(x) sources <<- rbind(sources,data.frame(id=src$id[x],lon=as.numeric(clean_coord(res$sources[[x]]$location[1])),lat=as.numeric(clean_coord(res$sources[[x]]$location[2])), stringsAsFactors = FALSE)))
18	58x	aa <- lapply(1:nbDst, function(x) destinations <<- rbind(destinations,data.frame(id=dst$id[x],lon=as.numeric(clean_coord(res$destinations[[x]]$location[1])),lat=as.numeric(clean_coord(res$destinations[[x]]$location[2])), stringsAsFactors = FALSE)))
19		}
20
21	137x	if(!faceAFace)
22		{
23	46x	sources <- sources[rep(1:nbSrc,nbDst),]
24	46x	destinations <- destinations[rep(1:nbDst, each=nbSrc),]
25		}
26
27	137x	return(list(sources = sources, destinations = destinations))
28		}

1		#' @name mapRoutes
2		#'
3		#' @title Visualiser le trace des trajets sur une carte
4		#'
5		#' @description La fonction mapRoutes permet de visualiser les tracés des routes sur une carte.
6		#'
7		#' @param res liste d'objets sf (LINESTRING ou MULTILINESTRING). Les formats sp sont convertis en objet sf.
8		#' @param fonds liste d'objets sf. Les formats sp sont convertis en objet sf.
9		#' @param largeurRoute numérique. Largeur de la route.
10		#' @param opaciteOSM numérique. Entre 0 et 1, opacité du fond OpenStreetMap. Par défaut 0.5.
11		#' @param mapProxy objet leaflet ou leaflet_proxy. Pour l'intégration des fonctions leaflet dans les applications shiny. Par defaut NULL.
12		#' @return objet leaflet
13		#'
14		#' @details Plus le nombre de routes est important, plus le temps de calcul est élévé.
15		#'
16		#' En entrée, l'objet res doit être une liste d'objet sf avec une géométrie MULTILINESTRING.
17		#'
18		#' Cet objet peut être une liste de résultats (objets sf) de la fonction metricOsrmRoute renvoyant des tracés de route.
19		#'
20		#' L'objet res peut également être le résultat de la fonction mapRoutesProp (2ème élément de la liste retournée).
21		#'
22		#' Cet objet comportera alors deux variables weight et classes (logiquement filtrés) pour représenter l'épaisseur des tracés sur la carte selon leur poids (voir fonction mapRoutesProp).
23		#' Dans ce cas, l'argument largeurRoute sera ignoré.
24		#'
25		#' En sortie, la fonction mapRoutes renvoie la carte leaflet qu'il est possible d'afficher directement dans le viewer.
26		#'
27		#' @importFrom sf st_as_sf st_bbox st_transform
28		#' @importFrom leaflet leaflet invokeMethod fitBounds addScaleBar addPolygons addPolylines leafletOptions tileOptions getMapData pathOptions scaleBarOptions clearGroup
29		#' @importFrom methods is
30		#' @export
31		#'
32		#' @examples
33		#' # Specification d'un serveur osrm obligatoire pour executer les exemples
34		#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
35		#'
36		#' # Specification du profil
37		#' options(osrm.profile = "driving")
38		#'
39		#' # Calcul de deux traces de route.
40		#' sf1_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
41		#' lat = 46.15),
42		#' dst = data.frame(lon = 4.72,
43		#' lat = 45.92),
44		#' overview = "full",
45		#' returnclass = "sf")
46		#'
47		#' sf2_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
48		#' lat = 46.15),
49		#' dst = data.frame(lon = 4.82,
50		#' lat = 45.85),
51		#' overview = "full",
52		#' returnclass = "sf")
53		#'
54		#' # Visualisation des deux traces de route.
55		#' mapRoutes(res = list(sf1_route_f, sf2_route_f))
56		#'
57		mapRoutes <- function(res, fonds = NULL, largeurRoute = 1, opaciteOSM = 0.5, mapProxy = NULL)
58		{
59
60	9x	if(!is.list(res))
61		{
62	!	stop(simpleError("res doit \u00eatre une liste (d'objets sf)"))
63		}
64	9x	if (methods::is(fonds[[1]], "Spatial") \| methods::is(res[[1]], "Spatial") ) {
65	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
66		}
67	8x	if(!any(testSf(res[[1]])\| methods::is(res[[1]], "Spatial")))
68		{
69	2x	stop(simpleError("res doit \u00eatre une liste d'objets sf."))
70		}
71	6x	if(!is.null(fonds))
72		{
73	5x	if(!is.list(fonds))
74		{
75	1x	stop(simpleError("fonds doit \u00eatre une liste (d'objets sf)."))
76		}
77	4x	if(!any(testSf(fonds[[1]]) \| methods::is(fonds[[1]], "Spatial")))
78		{
79	1x	stop(simpleError("fonds doit \u00eatre une liste d'objets sf."))
80		}
81		}
82
83	4x	if(!is.null(mapProxy))
84		{
85	!	if(any(class(mapProxy) %in% "leaflet_proxy")) # Contexte shiny/proxy
86		{
87	!	leaflet::clearGroup(mapProxy,
88	!	group = "carte_routes")
89		}
90		}
91
92		# si coord est un objet sp, on le transforme d'abord en objet sf
93	4x	for(i in 1:length(res))
94		{
95		# si fonds est un objet sp, on le transforme d'abord en objet sf
96	5x	if (methods::is(res[[i]], "Spatial"))
97		{
98	!	res[[i]] <- sf::st_as_sf(x = res[[i]])
99		}
100	5x	res[[i]] <- sf::st_transform(res[[i]], crs = 4326)
101		}
102
103	4x	res <- do.call(rbind,res)
104
105	4x	if(length(which(names(res) %in% c("weight", "classes"))) == 2)
106		{
107	1x	weight <- res$classes
108		}else
109		{
110	3x	weight <- largeurRoute
111		}
112
113	4x	if(length(which(names(res) %in% "col")) == 1)
114		{
115	1x	col <- res$col
116		}else
117		{
118	3x	col <- "darkslateblue"
119		}
120
121	4x	if(is.null(mapProxy) \| (!is.null(mapProxy) & is.character(mapProxy)))
122		{
123	4x	if(!is.null(fonds))
124		{
125	3x	for(i in 1:length(fonds))
126		{
127		# si fonds est un objet sp, on le transforme d'abord en objet sf
128	4x	if (methods::is(fonds[[i]], "Spatial"))
129		{
130	!	fonds[[i]] <- sf::st_as_sf(x = fonds[[i]])
131		}
132	4x	fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)
133		}
134		}
135
136	4x	if(is.null(getOption("urlTemplate")) \| is.null(getOption("attribution")))
137		{
138	!	options(urlTemplate = "http://{s}.tile.openstreetmap.fr/osmfr/{z}/{x}/{y}.png")
139	!	options(attribution = paste0("Insee, distancier Metric-OSRM, \u00a9 les contributeurs d'<a href='https://www.openstreetmap.org/copyright'>OpenStreetMap</a> et du <a href='http://project-osrm.org/'>projet OSRM</a>"))
140		}
141
142	4x	m <- leaflet::leaflet(padding = 0,
143	4x	options = leaflet::leafletOptions(
144	4x	preferCanvas = TRUE,
145	4x	transition = 2
146		)
147		) \|>
148
149	4x	leaflet::addTiles(urlTemplate = getOption("urlTemplate"),
150	4x	attribution = getOption("attribution"),
151	4x	options = leaflet::tileOptions(opacity = opaciteOSM)) \|>
152
153	4x	leaflet::fitBounds(lng1 = as.numeric(sf::st_bbox(res)[1]),
154	4x	lat1 = as.numeric(sf::st_bbox(res)[2]),
155	4x	lng2 = as.numeric(sf::st_bbox(res)[3]),
156	4x	lat2 = as.numeric(sf::st_bbox(res)[4])) \|>
157
158	4x	leaflet::addScaleBar(position = 'bottomright',
159	4x	options = leaflet::scaleBarOptions(metric = TRUE, imperial = FALSE))
160
161	4x	if(!is.null(fonds))
162		{
163	3x	for(i in 1:length(fonds))
164		{
165	4x	fonds[[i]] <- sf::st_transform(fonds[[i]], crs = 4326)
166
167	4x	m <- leaflet::addPolygons(map = m, data = fonds[[i]], opacity = 1,
168	4x	stroke = TRUE, color = "#606060", weight = 1,
169	4x	options = leaflet::pathOptions(clickable = F),
170	4x	fill = F,
171	4x	group = "carte_routes_init")
172		}
173		}
174		}else # Contexte shiny/proxy
175		{
176	!	m <- mapProxy
177		}
178
179	4x	m <- leaflet::addPolylines(map = m, data = res, opacity = 100,
180	4x	stroke = TRUE, color = col, weight = weight,
181	4x	options = leaflet::pathOptions(clickable = F),
182	4x	fill = F,
183	4x	group = "carte_routes")
184
185	4x	return(m)
186		}

1		#' @name codeComToCoord
2		#'
3		#' @title Fonction de passage entre code commune INSEE et coordonnees au chef-lieu (chx) ou au centroide ou a un point sur la commune (pos).
4		#'
5		#' @description La fonction codeComToCoord permet de récupérer des coordonnées WGS84 (EPSG 4326) de plusieurs communes à partir des codes communes INSEE.
6		#'
7		#' Les points en sortie correspondent aux chefs-lieux de communes (chx), aux centroïdes ou à des points situés obligatoirement à l'intérieur de la commune,
8		#' calculés selon l'algorithme spécifique "point_on_surface".
9		#'
10		#' Selon la morphologie du contour de la commune, le centroïde peut être situé en-dehors de ses limites.
11		#' Pour que le point soit obligatoirement situé dans la commune, il faut alors spécifier type = "pos" (point_on_surface).
12		#'
13		#' Il est possible de choisir une géographie de 2017 à l'année de mise à jour du package.
14		#' Par exemple, si le package a été mis à jour en géographie 2024,
15		#' il peut transformer en coordonnées lon/lat des codes communes des COG 2017 à 2024.
16		#'
17		#' Pour information, il est possible de récupérer sous forme de table l'ensemble des codes communes Insee
18		#' d'un millésime donné avec leurs coordonnées centroïde, pos et chx.
19		#' Pour ce faire il suffit de taper la commande metric.osrm:::tablePassage20xx
20		#'
21		#' @param codeInsee vecteur texte.
22		#' @param geo texte. Par défaut, l'année courante.
23		#' @param type texte. Type de point souhaité. A choisir parmi "chx" par défaut (chef-lieu de la commune), "centroide" (barycentre) ou "pos" (point sur la surface).
24		#'
25		#' @return Un data.frame de trois colonnes "code", "lon" et "lat".
26		#'
27		#' @importFrom rio import
28		#' @export
29		#'
30		#' @examples
31		#' # Renvoie les coordonnees des chefs-lieux des communes de Montrouge (92049)
32		#' # et de Malakoff (92046) en geographie 2024.
33		#' codeComToCoord(codeInsee = c("92049","92046"),
34		#' geo = "2024",
35		#' type = "chx")
36		#'
37		#' # Renvoie les coordonnees des centroides des communes de Montrouge (92049)
38		#' # et de Malakoff (92046) en geographie 2024.
39		#' codeComToCoord(codeInsee = c("92049","92046"),
40		#' geo = "2024",
41		#' type = "centroide")
42		#'
43		#' # Renvoie les coordonnees "point_on_surface" des communes de Montrouge (92049)
44		#' # et de Malakoff (92046) en geographie 2024.
45		#' codeComToCoord(codeInsee = c("92049","92046"),
46		#' geo = "2024",
47		#' type = "pos")
48		#'
49		#' # Renvoie les coordonnees des chefs-lieux des communes d'Ancteville (50007)
50		#' # et de Saint-Sauveur-Lendelin (50550) en geographie 2018.
51		#' codeComToCoord(codeInsee = c("50007","50550"),
52		#' geo = "2018",
53		#' type = "chx")
54		#'
55		#' # Au 01/01/2019, les communes d'Ancteville (50007),
56		#' # de Saint-Sauveur-Lendelin (50550) et autres communes
57		#' # ont fusionne pour former Saint-Sauveur-Villages (50550).
58		#'
59		#' # Renvoie les coordonnees du chef-lieu de la commune
60		#' # de Saint-Sauveur-Villages (50550) en geographie 2019.
61		#' # et affiche un avertissement si le code commune est introuvable
62		#' # pour la geographie donnee.
63		#' codeComToCoord(codeInsee = c("50007","50550"),
64		#' geo = "2019",
65		#' type = "chx")
66		#'
67		codeComToCoord <- function(codeInsee, geo = "2024", type = "chx")
68		{
69		# import de la table
70	9x	pointCom <- tryCatch({
71
72	9x	base::get(paste0("tablePassage",geo))
73
74	9x	},error = function(err){
75	1x	stop(simpleError(paste0("La g\u00e9ographie des communes n'est pas disponible pour le mill\u00e9sime ",geo)))
76		})
77
78		# filtre
79	8x	selectPoint <- pointCom[pointCom$code %in% unique(codeInsee),]
80
81		# pour conserver l'ordre des codeInsee de la table en entree
82	8x	codeInsee <- data.frame(code=codeInsee, stringsAsFactors = FALSE)
83	8x	codeInsee$id <- c(1:nrow(codeInsee))
84	8x	coordCom <- merge(selectPoint, codeInsee, by = "code")
85	8x	coordCom <- coordCom[order(coordCom$id),]
86
87	8x	if(type == "centroide")
88		{
89	1x	coordCom <- coordCom[c("code","centroid_lon","centroid_lat")]
90	7x	}else if(type == "pos")
91		{
92	1x	coordCom <- coordCom[c("code","pos_lon","pos_lat")]
93		}else
94		{
95	6x	coordCom <- coordCom[c("code","chx_lon","chx_lat")]
96		}
97
98	8x	names(coordCom) <- c("code","lon","lat")
99	8x	coordCom$lon <- round(coordCom$lon,5)
100	8x	coordCom$lat <- round(coordCom$lat,5)
101	7x	if(nrow(coordCom) > 0) row.names(coordCom) <- c(1:nrow(coordCom))
102
103	8x	if(nrow(codeInsee) != nrow(coordCom))
104		{
105	3x	comNonGeoloc <- codeInsee[!codeInsee$code %in% coordCom$code, "code"]
106	3x	if(length(comNonGeoloc) == 1)
107		{
108	2x	message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," commune non g\u00e9olocalis","\u00e9","e."))
109	2x	message(paste0("Veuillez v\u00e9rifier que le mill\u00e9sime de la g\u00e9ographie des codes communes "))
110	2x	message(paste0("correspond bien \u00e0 l'argument geo."))
111		}
112	3x	if(length(comNonGeoloc) > 1)
113		{
114	1x	message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," communes non g\u00e9olocalis","\u00e9","es."))
115	1x	message(paste0("Veuillez v\u00e9rifier que le mill\u00e9sime de la g\u00e9ographie des codes communes"))
116	1x	message(paste0("correspond bien \u00e0 l'argument geo. "))
117		}
118	3x	message(paste0("Liste des codes communes non g\u00e9olocalis","\u00e9","es : "))
119	3x	message(paste(comNonGeoloc, collapse = ", "))
120		}
121
122	8x	return(coordCom)
123		}

1		#' @name metricOsrmRoute
2		#'
3		#' @title Calculer le temps de trajet et la distance entre deux points ainsi que la geometrie du trace
4		#'
5		#' @description La fonction metricOsrmRoute permet de calculer le temps de trajet et la distance
6		#' entre deux points seulement et de récupérer le tracé de la route empruntée.#'
7		#' La fonction permet également d’ajouter des points intermédiaires entre la source (src) et
8		#' la destination (dst) pour former un itinéraire.
9		#'
10		#' @param src vecteur numérique de longueur 2 (lon/lat) ou 3 (id/lon/lat), data.frame d'une ligne (colonnes lon/lat ou id/on/lat),
11		#' objet sf d'une ligne #'
12		#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
13		#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
14
15		#' @param dst vecteur numérique de longueur 2 (lon/lat) ou 3 (id/lon/lat), data.frame d'une ligne (colonnes lon/lat ou id/on/lat),
16		#' objet sf d'une ligne
17		#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
18		#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
19
20		#' @param loc data.frame (colonnes lon/lat ou id/on/lat), objet sf précisant les points intermédiaires du trajet.
21		#' #' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
22		#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
23
24		#' @param overview texte. "simplified" (par défaut), "full" ou NULL. Renvoie une géométrie simplifiée ou détaillée du tracé ou seulement le temps et la distance si NULL.
25		#' @param returnclass texte. "sf" ou NULL (par défaut). Renvoie un objet sf (LINESTRING) ou un data.frame de coordonnées si NULL.
26		#' @param exclude texte. Permet aux trajets d'éviter les autoroutes (“motorway”), les péages (“toll”) ou les ferries (“ferry”). Par défaut NULL.
27		#'
28		#' @return Un data.frame, un objet spatial sf (LINESTRING).
29		#'
30		#' @details Le choix de overview = "full" augmente le temps de calcul puisqu’il permet de renvoyer une géométrie
31		#' détaillée du tracé avec plus de coordonnées. Ce choix est toutefois obligatoire si l’on veut représenter
32		#' ensuite des routes proportionnelles à partir de la fonction routesProportionnelles.
33		#'
34		#' Pour cette usage, il est aussi conseillé de spécifier le paramètre returnclass = NULL pour diminuer le temps
35		#' de calcul. Les coordonnées des tronçons de route seront alors retournées sans la géométrie.
36		#'
37		#' L'argument loc peut être utilisé à la place de src et dst pour forcer le trajet à emprunter des points intermédiaires créant ainsi un itinéraire.
38		#' La première ligne de loc est le point de départ, la dernière ligne le point d’arrivée.
39		#' Ce dernier peut être identique au point de départ pour former une boucle de trajet.
40		#'
41		#' @importFrom sf st_sf st_as_sf st_as_sfc st_crs st_geometry st_centroid st_transform st_coordinates st_collection_extract
42		#' @importFrom RJSONIO fromJSON
43		#' @importFrom methods as
44		#' @importFrom gepaf decodePolyline
45		#' @export
46		#'
47		#' @examples
48		#' # Specification d'un serveur osrm obligatoire pour executer les exemples
49		#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
50		#'
51		#' # Specification du profil
52		#' options(osrm.profile = "driving")
53		#'
54		#' # Calcul d'un trace de route simplifie en data.frame.
55		#' dt_route_s <- metricOsrmRoute(src = data.frame(lon = 4.92,
56		#' lat = 46.15),
57		#' dst = data.frame(lon = 4.72,
58		#' lat = 45.92),
59		#' overview = "simplified")
60		#'
61		#' # Calcul d'un trace de route detaille en data.frame.
62		#' dt_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
63		#' lat = 46.15),
64		#' dst = data.frame(lon = 4.72,
65		#' lat = 45.92),
66		#' overview = "full")
67		#'
68		#' # Calcul d'un trace de route simplifie en objet sf.
69		#' sf_route_s <- metricOsrmRoute(src = data.frame(lon = 4.92,
70		#' lat = 46.15),
71		#' dst = data.frame(lon = 4.72,
72		#' lat = 45.92),
73		#' overview = "simplified",
74		#' returnclass = "sf")
75		#'
76		#' plot(sf::st_geometry(sf_route_s), col = "red")
77		#'
78		#' # Calcul d'un trace de route detaille en objet sf.
79		#' sf_route_f <- metricOsrmRoute(src = data.frame(lon = 4.92,
80		#' lat = 46.15),
81		#' dst = data.frame(lon = 4.72,
82		#' lat = 45.92),
83		#' overview = "full",
84		#' returnclass = "sf")
85		#'
86		#' plot(sf::st_geometry(sf_route_f), col = "blue", add = TRUE)
87		#'
88		#' # Calcul d'une boucle d'itineraire en trace simplifie et objet sf.
89		#' sf_route_s_boucle <- metricOsrmRoute(loc = data.frame(
90		#' lon = c(4.92,4.83,4.72,4.89,4.92),
91		#' lat = c(46.15,45.99,45.92,46.12,46.15)),
92		#' overview = "simplified",
93		#' returnclass = "sf")
94		#'
95		#' # boucle
96		#' plot(sf::st_geometry(sf_route_s_boucle))
97		#' # Points de depart et d'arrivee
98		#' plot(sf::st_point(c(4.92, 46.15)), col = "red", add = TRUE)
99		#' # Point intermediaire 1
100		#' plot(sf::st_point(c(4.83, 45.99)), col = "blue", add = TRUE)
101		#' # Point intermediaire 2
102		#' plot(sf::st_point(c(4.72, 45.92)), col = "green", add = TRUE)
103		#' # Point intermediaire 3
104		#' plot(sf::st_point(c(4.89, 46.12)), col = "orange", add = TRUE)
105		#'
106		metricOsrmRoute <-
107		function (src, dst, loc, overview = "simplified", returnclass = NULL, exclude = NULL)
108
109		{
110	35x	exclude_str <- ""
111	35x	if (missing(loc)) {
112	29x	src <- input_route(x = src, id = "src", single = TRUE)
113	29x	dst <- input_route(x = dst, id = "dst", single = TRUE)
114	29x	id1 <- src$id
115	29x	id2 <- dst$id
116	29x	if (!is.null(exclude)) {
117	1x	exclude <- paste(exclude, sep = "", collapse = ",")
118	1x	exclude_str <- paste("&exclude=", exclude, sep = "")
119		}
120	29x	req <- paste(getOption("osrm.server"), "route/v1/",
121	29x	getOption("osrm.profile"), "/", src$lon, ",", src$lat,
122	29x	";", dst$lon, ",", dst$lat, "?alternatives=false&geometries=polyline&steps=false&overview=",
123	29x	tolower(overview), exclude_str, sep = "")
124		}else{
125	6x	loc <- input_route(x = loc, single = FALSE)
126	6x	id1 <- loc$id1
127	6x	id2 <- loc$id2
128	6x	if (!is.null(exclude)) {
129	1x	exclude_str <- paste("&exclude=", exclude, sep = "")
130		}
131	6x	req <- paste(getOption("osrm.server"), "route/v1/",
132	6x	getOption("osrm.profile"), "/", paste0(apply(data.frame(loc$lon,
133	6x	loc$lat), MARGIN = 1, FUN = paste0, collapse = ","),
134	6x	collapse = ";"), "?alternatives=false&geometries=polyline&steps=false&overview=",
135	6x	tolower(overview), exclude_str, sep = "")
136		}
137
138	35x	resRaw <- utils::URLencode(req)
139
140	35x	res <- RJSONIO::fromJSON(resRaw)
141
142	35x	if (overview == FALSE) {
143	1x	resultat <- c(duree = round(res$routes[[1]]$duration/60,2),
144	1x	distance = round(res$routes[[1]]$distance/1000,3))
145		}else{
146
147	34x	geodf <- gepaf::decodePolyline(res$routes[[1]]$geometry)[,c(2, 1)]
148	34x	resultat <- geodf
149
150	34x	if (!(is.null(returnclass))) {
151	17x	if (!(returnclass == "sf")){
152	3x	returnclass=NULL
153	3x	warning("le parametre returnclass a ete mis a sf. Les valeurs acceptes sont sf ou NULL")
154		}
155	17x	rcoords <- paste0(geodf$lon, " ", geodf$lat, collapse = ", ")
156	17x	rgeom <- (sf::st_as_sfc(paste0("LINESTRING(", rcoords,
157		")")))
158	17x	rosf <- sf::st_sf(src = id1, dst = id2, duree = round(res$routes[[1]]$duration/60,2),
159	17x	distance = round(res$routes[[1]]$distance/1000,3), geometry = rgeom,
160	17x	crs = 4326, row.names = paste(id1, id2, sep = "_"), stringsAsFactors = FALSE)
161	17x	resultat <- rosf
162		}else
163		{
164	17x	resultat <- data.frame(src = id1, dst = id2, duree = round(res$routes[[1]]$duration/60,2),
165	17x	distance = round(res$routes[[1]]$distance/1000,3), lon = resultat$lon, lat = resultat$lat,
166	17x	stringsAsFactors = FALSE)
167		}
168		}
169
170	35x	return(resultat)
171		}

1		# @name osrmTableAllerRetour
2		# @title La fonction interne osrmTableAllerRetour.
3		# @description La fonction interne osrmTableAllerRetour permet de lancer osrmTableCartesien.
4		# @inheritParams metriOsrmTable
5		# @return Un data.frame
6		# @noRd
7		# @export
8		#
9		osrmTableAllerRetour <- function(src, dst, duree, distance, exclude, interactive)
10		{
11		# Traitement des couples aller-retour
12
13	9x	src_comm <- src[src$id %in% dst$id,]
14	9x	dst_comm <- dst[dst$id %in% src$id,]
15
16	9x	if(nrow(src_comm) > 1)
17		{
18		# On calcule les couples AR puis sélection que des allers simples
19	8x	res_comm <- osrmTableCartesien(src = src_comm, dst = dst_comm, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
20
21	8x	res_comm <- res_comm[order(res_comm$idSrc),]
22
23	8x	aa <- matrix(nrow = nrow(src_comm), ncol = nrow(src_comm))
24	8x	i <- 0
25	8x	for(j in 1:(nrow(src_comm)))
26		{
27	16x	aa[,j] <- c(rep(1,i), rep(0,nrow(src_comm)-i))
28	16x	i <- i + 1
29		}
30
31	8x	res_comm$id <- c(aa)
32	8x	res_comm <- res_comm[res_comm$id %in% 0,-ncol(res_comm)]
33		}else
34		{
35	1x	res_comm <- data.frame()
36		}
37
38		# Traitement des couples uniques
39
40	9x	src_diff <- src[!src$id %in% dst$id,]
41	9x	dst_diff <- dst[!dst$id %in% src$id,]
42
43	9x	if(nrow(src_diff) > 0 & nrow(dst_diff) > 0)
44		{
45	8x	res_diff_diff <- osrmTableCartesien(src = src_diff, dst = dst_diff, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
46		}else
47		{
48	1x	res_diff_diff <- data.frame()
49		}
50
51	9x	if(nrow(src_diff) > 0 & nrow(dst_comm) > 0)
52		{
53	7x	res_diff_comm <- osrmTableCartesien(src = src_diff, dst = dst_comm, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
54		}else
55		{
56	2x	res_diff_comm <- data.frame()
57		}
58
59	9x	if(nrow(src_comm) > 0 & nrow(dst_diff) > 0)
60		{
61	7x	res_comm_diff <- osrmTableCartesien(src = src_comm, dst = dst_diff, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
62		}else
63		{
64	2x	res_comm_diff <- data.frame()
65		}
66
67		# Concaténation des tables
68
69	9x	res <- rbind(res_comm,res_comm_diff,res_diff_comm,res_diff_diff)
70
71	9x	res$ID <- 1:nrow(res)
72
73	9x	return(res)
74		}

1		# @name requeteOsrm_n1
2		# @title Calcul de la durée et/ou la distance.
3		# @description La fonction interne requeteOsrm_n1 permet de calculer la durée et la distance
4		# entre un point et un groupe de points.
5		# @param src,dst data.frame n lignes et 3 colonnes id/lon/lat.
6		# @param idx_src valeur numérique.
7		# @param data.frame 1 ligne et 3 colonnes id/lon/lat.
8		# @param idx_dst vecteur numérique de longueur n où n est le nombre de couples pour la requête.
9		# @param measure vecteur caractères. Choix des options entre "duration" et "distance".
10		# @param exclude_str string. Exclu un type de route pour le calcul du trajet.
11		# String formé pour la requête. Si exclude = NULL, exclude_str = "".
12		# @return list.
13		# @importFrom RJSONIO fromJSON
14		# @importFrom utils URLencode
15		# @noRd
16		# @export
17
18		requeteOsrm_1n <-
19		function(src, idx_src, dst, idx_dst, measure, exclude_str)
20		{
21	52x	if(!is.null(getOption("osrm.server")))
22		{
23	51x	if(substr(getOption("osrm.server"),nchar(getOption("osrm.server")),nchar(getOption("osrm.server"))) == "/")
24		{
25	50x	server <- getOption("osrm.server")
26		}else
27		{
28	1x	server <- paste0(getOption("osrm.server"), "/")
29		}
30		}else
31		{
32	1x	server <- getOption("osrm.server")
33		}
34
35	52x	req <- paste(paste0(server, "table/v1/",
36	52x	getOption("osrm.profile"), "/"),
37	52x	paste0(clean_coord(as.numeric(src[,2])),",",clean_coord(as.numeric(src[,3])),";"),
38	52x	paste(clean_coord(as.numeric(dst[idx_dst,2])),clean_coord(as.numeric(dst[idx_dst,3])), sep = ",",collapse = ";"),
39	52x	"?sources=", paste(idx_src, collapse = ";"),
40	52x	"&destinations=", paste(idx_dst, collapse = ";"),
41	52x	"&annotations=", paste(measure, collapse = ","),
42	52x	exclude_str, sep = "")
43
44	50x	req <- utils::URLencode(req)
45
46	50x	res <- tryCatch({
47
48	50x	RJSONIO::fromJSON(req)
49
50	50x	},error = function(err){
51	1x	message("Un encombrement du r\u00e9seau a eu lieu mais le calcul continue.")
52
53		# On attend 5 secondes que le réseau redevienne fluide avant de relancer la requête
54	1x	Sys.sleep(5)
55
56	1x	res <- tryCatch({
57
58	1x	RJSONIO::fromJSON(req)
59
60	1x	},error = function(err){
61	1x	message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x1.")
62
63		# On attend maintenant 10 secondes que le réseau redevienne fluide avant de relancer la requête
64	1x	Sys.sleep(10)
65
66	1x	res <- tryCatch({
67
68	1x	RJSONIO::fromJSON(req)
69
70	1x	},error = function(err){
71	1x	message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x2.")
72
73		# On attend 20 secondes que le réseau redevienne fluide avant de relancer la requête
74	1x	Sys.sleep(30)
75
76	1x	res <- tryCatch({
77
78	1x	RJSONIO::fromJSON(req)
79
80	1x	},error = function(err){
81	1x	message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x3.")
82
83		# On attend 60 secondes que le réseau redevienne fluide avant de relancer la requête
84	1x	Sys.sleep(60)
85
86	1x	res <- tryCatch({
87
88	1x	RJSONIO::fromJSON(req)
89
90	1x	},error = function(err){
91	1x	message("Le r\u00e9seau ne s'est toujours pas lib\u00e9r\u00e9. Arr\u00eat du traitement.")
92	1x	message(err)
93		})
94		})
95		})
96		})
97		})
98
99		# Attente pour laisser le temps à la requête de faire l'aller-retour vers le serveur. Sinon risque de plantage de connexion.
100	49x	Sys.sleep(0.01)
101
102	49x	return(res)
103		}

1		calculs_faceaface <- function(couplesUniques, duree, distance, exclude, interactive)
2		{
3		### 1er groupe : groupes >= 1000 couples (1n ou n1) : calcul de 1 à n (n = 500 max)
4	39x	res_1g <- osrmTableGrpe1(couples = couplesUniques, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
5
6	39x	if(!is.null(res_1g))
7		{
8	!	couplesUniques <- couplesUniques[-which(couplesUniques$ID %in% res_1g$ID),]
9		}else
10		{
11	39x	res_1g <- NULL
12		}
13
14		### 2eme groupe : groupes entre 5 et 999 couples (1n ou n1) : calcul de 1 à n (n = 500 max)
15	39x	if(nrow(couplesUniques)>0)
16		{
17	39x	res_2g <- osrmTableGrpe2(couples = couplesUniques, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
18	38x	if(!is.null(res_2g))
19		{
20	1x	couplesUniques <- couplesUniques[-which(couplesUniques$ID %in% res_2g$ID),]
21		}
22		}else
23		{
24	!	res_2g <- NULL
25		}
26
27		### 3eme groupe : groupes de 1 à 4 couple(s) en face a face (11) : calcul par croisement de n x n (n=100 max) puis conservation de la diagonale
28	38x	if(nrow(couplesUniques)>0)
29		{
30	37x	nb_boucles <- (nrow(couplesUniques)%/%100)+1
31	37x	list_res_3g <- list()
32
33	37x	if(interactive)
34		{
35	4x	shiny::withProgress(message = "Calculs en cours - 3/3 : ",{
36	!	for(i in 1:nb_boucles)
37		{
38	!	if(nrow(couplesUniques)>=100)
39		{
40	!	nb_row <- 100
41		}else
42		{
43	!	nb_row <- nrow(couplesUniques)%%100
44		}
45	!	if(nb_row > 0)
46		{
47	!	list_res_3g[[i]] <- osrmTableGrpe3(couples = couplesUniques[1:nb_row,], duree = duree, distance = distance, exclude = exclude)
48	!	couplesUniques <- couplesUniques[-(1:nb_row),]
49		}
50	!	shiny::incProgress(1/nb_boucles)
51		}
52		})
53	33x	}else if(!interactive)
54		{
55	33x	pb3 <- progress::progress_bar$new(
56	33x	format = "Calcul en cours - 3/3 : [:bar] :percent :elapsed",
57	33x	total = nb_boucles, clear = FALSE, width= 60
58		)
59
60	33x	pb3$tick(0)
61
62	33x	for(i in 1:nb_boucles)
63		{
64	33x	if(nrow(couplesUniques)>=100)
65		{
66	!	nb_row <- 100
67		}else
68		{
69	33x	nb_row <- nrow(couplesUniques)%%100
70		}
71	33x	if(nb_row > 0)
72		{
73	33x	list_res_3g[[i]] <- osrmTableGrpe3(couples = couplesUniques[1:nb_row,], duree = duree, distance = distance, exclude = exclude)
74	33x	couplesUniques <- couplesUniques[-(1:nb_row),]
75		}
76	33x	pb3$tick()
77		}
78		}
79
80	33x	res_3g <- do.call(rbind,list_res_3g)
81		}else
82		{
83	1x	pb3 <- progress::progress_bar$new(
84	1x	format = "Calcul en cours - 3/3 : [:bar] :percent :elapsed",
85	1x	total = 2, clear = FALSE, width= 60
86		)
87
88	1x	for (i in 1:2) {
89	2x	pb3$tick()
90	2x	Sys.sleep(0.2)
91		}
92
93	1x	res_3g <- NULL
94		}
95
96		# Fusion des 3 tables
97	34x	res <- rbind(res_1g,res_2g)
98	34x	res <- rbind(res,res_3g)
99	34x	res <- res[order(res$ID),]
100	34x	row.names(res) <- c(1:nrow(res))
101
102	34x	return(res)
103		}

1		# @name osrmTable_11_nm
2		# @title La fonction interne osrmTable_11_nm Calcule la durée et/ou la distance en face à face ou par croisement.
3		# @description La fonction osrmTable_11_nm permet de calculer la durée et la distance
4		# entre couples de points en face à face ou par croisement.
5		# @inheritParams metriOsrmTable
6		# @return Un data.frame
7		# @noRd
8		# @export
9		#
10		# @param faceAFace boolean. Si TRUE (par défaut),
11		# Si FALSE,
12		# 10000 couples max sont acceptés (nombre de points de src x nombre de points de dst < 10000),
13		# au-delà le traitement se fera en face à face.
14		#
15		# @return data.frame
16		osrmTable_11_nm <- function(src, dst, duree, distance, exclude, faceAFace = TRUE)
17		{
18	94x	list_res_duree <- list()
19	94x	list_res_distance <- list()
20	94x	res_destinations <- data.frame()
21	94x	res_sources <- data.frame()
22	94x	measure <- NULL
23	77x	if(duree) measure <- "duration"
24	93x	if(distance) measure <- c(measure,"distance")
25	1x	if(is.null(measure)) measure <- "duration"
26	94x	if(is.null(exclude))
27		{
28	93x	exclude_str <- ""
29		}else{
30	1x	exclude <- paste(exclude, sep = "", collapse = ",")
31	1x	exclude_str <- paste("&exclude=", exclude, sep = "")
32		}
33
34	94x	if(!faceAFace) # produit cartesien
35		{
36	47x	idx_src <- 1:nrow(src)
37	47x	idx_dst <- 1:nrow(dst)
38		}else # couple a couple
39		{
40	47x	if(nrow(src)<=nrow(dst)) # on cale sur src
41		{
42	45x	idx_src <- 1:nrow(src)
43	45x	idx_dst <- 1:nrow(src)
44	1x	}else if(nrow(src)>nrow(dst))
45		{
46	1x	idx_src <- 1:nrow(dst) # on cale sur dst
47	1x	idx_dst <- 1:nrow(dst)
48		}
49		}
50
51	93x	res <- requeteOsrm_11_nm(src = src, idx_src = idx_src, dst = dst, idx_dst = idx_dst, measure = measure, exclude_str = exclude_str)
52
53	92x	if(duree)
54		{
55	75x	nc <- FALSE
56	75x	for(i in 1:length(res$durations))
57		{
58	199x	for(j in 1:length(res$durations[[i]]))
59		{
60	668x	if(!is.null(res$durations[[i]][[j]]))
61		{
62	663x	if(res$durations[[i]][[j]] < 0)
63		{
64	!	res$durations[[i]][[j]] <- abs(res$durations[[i]][[j]])
65		}
66		}else
67		{
68	5x	res$durations[[i]][[j]] <- -60
69	5x	nc <- TRUE
70		}
71		}
72		}
73
74	3x	if(nc) res$durations <- lapply(res$durations, function(x)
75		{
76	4x	if(is.list(x))
77		{
78	4x	do.call(c,x)
79		}else
80		{
81	!	x
82		}
83		})
84
85	75x	res_duree <- data.frame(res$durations)
86	75x	dimnames(res_duree) <- list(1:length(idx_dst),1:length(idx_src))
87		}
88
89	92x	if(distance)
90		{
91	91x	nc <- FALSE
92	91x	for(i in 1:length(res$distances))
93		{
94	223x	for(j in 1:length(res$distances[[i]]))
95		{
96	704x	if(!is.null(res$distances[[i]][[j]]))
97		{
98	699x	if(res$distances[[i]][[j]] < 0)
99		{
100	!	res$distances[[i]][[j]] <- abs(res$distances[[i]][[j]])
101		}
102		}else
103		{
104	5x	res$distances[[i]][[j]] <- -1000
105	5x	nc <- TRUE
106		}
107		}
108		}
109
110	3x	if(nc) res$distances <- lapply(res$distances, function(x)
111		{
112	4x	if(is.list(x))
113		{
114	4x	do.call(c,x)
115		}else
116		{
117	!	x
118		}
119		})
120
121	91x	res_distance <- data.frame(res$distances)
122	91x	dimnames(res_distance) <- list(1:length(idx_dst),1:length(idx_src))
123		}
124
125	92x	coords <- coordFormat(res = res, src = src[1:length(idx_src),], dst = dst[1:length(idx_dst),], faceAFace = faceAFace)
126	92x	res_sources <- rbind(res_sources,coords$sources)
127	92x	res_destinations <- rbind(res_destinations,coords$destinations)
128
129	92x	names(res_sources) <- c("idSrc","lonSrc","latSrc")
130	92x	names(res_destinations) <- c("idDst","lonDst","latDst")
131
132	92x	if(duree)
133		{
134	75x	if(faceAFace) # couple a couple
135		{
136	45x	res_duree_save <- res_duree
137	45x	res_duree <- NULL
138	45x	for(i in 1:nrow(res_duree_save))
139		{
140	142x	res_duree <- rbind(res_duree,data.frame(duree=res_duree_save[i,i]))
141		}
142		}
143	30x	else if(!faceAFace) # produit cartesien
144		{
145	30x	res_duree <- data.frame(duree=do.call(c,list(t(res_duree))))
146		}else
147		{}
148		}
149
150	92x	if(distance)
151		{
152	91x	if(faceAFace) # couple a couple
153		{
154	45x	res_distance_save <- res_distance
155	45x	res_distance <- NULL
156	45x	for(i in 1:nrow(res_distance_save))
157		{
158	142x	res_distance <- rbind(res_distance,data.frame(distance=res_distance_save[i,i]))
159		}
160	46x	}else if(!faceAFace) # produit cartesien
161		{
162	46x	res_distance <- data.frame(distance=do.call(c,list(t(res_distance))))
163		}else{}
164		}
165
166	92x	res_11_nm <- cbind(res_sources,res_destinations)
167	75x	if(duree) res_11_nm <- cbind(res_11_nm,res_duree)
168	91x	if(distance) res_11_nm <- cbind(res_11_nm,res_distance)
169
170	92x	res_11_nm$idSrc <- as.character(res_11_nm$idSrc)
171	92x	res_11_nm$idDst <- as.character(res_11_nm$idDst)
172
173	92x	row.names(res_11_nm) <- c(1:nrow(res_11_nm))
174
175	92x	return(res_11_nm)
176		}

1		#' @name codeLauToCoord
2		#'
3		#' @title Fonction de passage entre code LAU de communes etrangeres et coordonnees au centroide ou a un point situe sur la commune.
4		#'
5		#' @description La fonction codeLauToCoord permet de récupérer des coordonnées WGS84 (EPSG 4326) de plusieurs communes étrangères à partir des codes LAU.
6		#'
7		#' Les points en sortie correspondent aux centroïdes ou à des points situés obligatoirement à l'intérieur de la commune,
8		#' calculés selon l'algorithme spécifique "point_on_surface". Selon la morphologie du contour de la commune, le centroïde peut être situé en-dehors de ses limites.
9		#' Pour que le point soit obligatoirement dans la commune, il faut alors spécifier type = "pos" (point_on_surface).
10		#'
11		#' Les codes pays, sur 2 caractères, sont consultables sur insee.fr (https://www.insee.fr/fr/information/2028273).
12		#'
13		#' Les codes LAU sont consultables sur le site d'eurostat (https://ec.europa.eu/eurostat/fr/web/nuts/local-administrative-units).
14		#' Les fonds de cartes des LAU sont disponibles ici (https://gisco-services.ec.europa.eu/distribution/v2/lau/download/).
15		#' Afin de garantir l'unicité du code, il est préférable d'utiliser le code GISCO, qui est la concaténation du code pays et du code LAU.
16		#' En effet, un code LAU d'un pays peut être identique à celui d'un autre.
17		#' La liste exhaustive des codes gisco 2021 est disponibles en exécutant la commande :
18		#' code_gisco <- rio::import(system.file("extdata","listeCodesGISCO.csv", package = "metric.osrm"))
19		#' La table avec les coordonnees associées est disponibles en exécutant la commande :
20		#' coord_LAU2021 <- metric.osrm:::tablePassageLAU2021
21		#'
22		#' Le champ couvert par codeLauToCoord contient les LAU des régions frontalières à la France, hors Andorre.
23		#' Les codes communes français sont ignorés. Utilisez, pour eux, la fonction codeComToCoord.
24		#'
25		#' @param codePays vecteur texte. Code pays sur 2 caractères selon la codification des pays et des territoires étrangers.
26		#' @param codeLau vecteur texte. Code LAU de communes étrangères.
27		#' @param geo texte. A choisir parmi "2020" ou "2021". Par défaut, l'année du dernier millésime disponible.
28		#' @param type texte. Type de point souhaité. A choisir parmi "centroide" (barycentre de la commune) ou "pos" par défaut (point sur la commune).
29		#'
30		#' @return Un data.frame de trois colonnes "code", "lon" et "lat".
31		#'
32		#' @importFrom rio import
33		#' @export
34		#'
35		#' @examples
36		#' # Renvoie les coordonnees des points sur la surface des communes de Bruxelles (21004)
37		#' # de Liege (62063), de Luxembourg (0304) et de Stuttgard (08111000).
38		#' codeLauToCoord(codePays = c("BE","BE","LU","DE"),
39		#' codeLau = c("21004","62063","0304","08111000"),
40		#' geo = "2021",
41		#' type = "pos")
42		#'
43		#' # Renvoie les coordonnees des centroides des communes des communes de Bruxelles (21004)
44		#' # de Liege (62063), de Luxembourg (0304) et de Stuttgard (08111000).
45		#' codeLauToCoord(codePays = c("BE","BE","LU","DE"),
46		#' codeLau = c("21004","62063","0304","08111000"),
47		#' geo = "2021",
48		#' type = "centroide")
49		#'
50		#' # Ajout de Metz (57463) et de Strasbourg (67482).
51		#' codeLauToCoord(codePays = c("FR","FR","BE","BE","LU","DE"),
52		#' codeLau = c("57463","67482","21004","62063","0304","08111000"),
53		#' geo = "2021",
54		#' type = "pos")
55		#'
56		#' # Ajout d'une commune etrangere hors champ de metric.osrm, Berlin (11000000).
57		#' codeLauToCoord(codePays = c("BE","BE","LU","DE","DE"),
58		#' codeLau = c("21004","62063","0304","08111000","11000000"),
59		#' geo = "2021",
60		#' type = "pos")
61		#'
62		codeLauToCoord <- function(codePays, codeLau, geo = "2021", type = "pos")
63		{
64		# import de la table
65	8x	pointCom <- tryCatch({
66
67	8x	base::get(paste0("tablePassageLAU",geo))
68
69	8x	},error = function(err){
70	!	stop(simpleError(paste0("La g\u00e9ographie des LAU n'est pas disponible pour le mill\u00e9sime ",geo)))
71		})
72
73		# concatenation du code pays et du LAU : code gisco
74	8x	codeGisco <- paste0(codePays,"_",codeLau)
75
76		# filtre
77	8x	selectPoint <- pointCom[pointCom$code %in% unique(codeGisco),]
78
79		# pour conserver l'ordre des codeLau de la table en entree
80	8x	codeGisco <- data.frame(code=codeGisco, stringsAsFactors = FALSE)
81	8x	codeGisco$id <- c(1:nrow(codeGisco))
82	8x	coordCom <- merge(selectPoint, codeGisco, by = "code")
83	8x	coordCom <- coordCom[order(coordCom$id),]
84
85	8x	if(type == "pos")
86		{
87	7x	coordCom <- coordCom[c("code","pos_lon","pos_lat")]
88		}else
89		{
90	1x	coordCom <- coordCom[c("code","centroid_lon","centroid_lat")]
91		}
92
93	8x	names(coordCom) <- c("code","lon","lat")
94	8x	coordCom$lon <- round(coordCom$lon,5)
95	8x	coordCom$lat <- round(coordCom$lat,5)
96	8x	if(nrow(coordCom) > 0) row.names(coordCom) <- c(1:nrow(coordCom))
97
98	8x	if(nrow(codeGisco) != nrow(coordCom))
99		{
100	4x	if(any(codePays %in% "FR"))
101		{
102	2x	if(length(codePays[codePays %in% "FR"]) == 1)
103		{
104	1x	message(paste0("[WARNING] Il y a ",length(codePays[codePays %in% "FR"])," commune fran","\u00e7","aise."))
105	1x	message(paste0("Pour elle seulement, veuillez utiliser la fonction codeComToCoord."))
106		}
107	2x	if(length(codePays[codePays %in% "FR"]) > 1)
108		{
109	1x	message(paste0("[WARNING] Il y a ",length(codePays[codePays %in% "FR"])," communes fran","\u00e7","aises."))
110	1x	message(paste0("Pour elles seulement, veuillez utiliser la fonction codeComToCoord."))
111		}
112		}
113
114	4x	comNonGeoloc <- codeGisco[!codeGisco$code %in% coordCom$code, "code"]
115	4x	comNonGeoloc <- comNonGeoloc[substr(comNonGeoloc,1,2) != "FR"]
116
117	4x	if(length(comNonGeoloc) > 0)
118		{
119	2x	if(length(comNonGeoloc) == 1)
120		{
121	1x	message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," commune non g\u00e9olocalis","\u00e9","e ou hors du champ de metric.osrm."))
122		}
123	2x	if(length(comNonGeoloc) > 1)
124		{
125	1x	message(paste0("[WARNING] Il y a ",length(comNonGeoloc)," communes non g\u00e9olocalis","\u00e9","es ou hors du champ de metric.osrm."))
126		}
127	2x	message(paste0("Liste des codes communes non g\u00e9olocalis","\u00e9","es ou hors-champ : "))
128	2x	message(paste(comNonGeoloc, collapse = ", "))
129		}
130		}
131
132	8x	return(coordCom)
133		}

1		#' @name statTable
2		#'
3		#' @title Calculer des statistiques sur les resultats de la fonction metricOsrmTable.
4		#'
5		#' @description La fonction statTable permet de calculer des statistiques simples sur les résultats de la fonction metricOsrmTable (comptages, valeurs min, valeurs max, moyennes, médianes).
6		#'
7		#' @param res data.frame. Résultat de la fonction metricOsrmTable avec les colonnes duree et/ou distance.
8		#'
9		#' @return Une liste de valeurs statistiques
10		#'
11		#' @details La table res doit correspondre à la table de résultats de la fonction metricOsrmTable avec les colonnes suivantes :
12		#' "ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst", "duree" et/ou "distance".
13		#'
14		#' Les statistiques calculées sont :
15		#'
16		#' - le nombre de couples calculés ;
17		#'
18		#' - le nombre de sources (src) ;
19		#'
20		#' - le nombre de destinations (dst).
21		#'
22		#' Pour la duree et la distance :
23		#'
24		#' - la valeur min ;
25		#'
26		#' - la valeur max ;
27		#'
28		#' - la moyenne ;
29		#'
30		#' - la médiane.
31		#'
32		#' @export
33		#'
34		#' @examples
35		#' # Reproduction d'une table de resultats avec la fonction metricOsrmTable
36		#' res <- data.frame(ID = c(1:4),
37		#' idSrc = c("1","2","3","4"),
38		#' lonSrc = c(5.39200,5.39242,5.37107,5.46476),
39		#' latSrc = c(43.28292,43.28368,43.47900,43.31246),
40		#' idDst = c("B","B","A","C"),
41		#' lonDst = c(5.38385,5.38385,5.47678,5.38219),
42		#' latDst = c(43.28571,43.28571,43.29028,43.44144),
43		#' duree = c(87.3,62.8,726.8,239.7),
44		#' distance = c(1103.3,942.7,8318.6,3252.6),
45		#' pop = c(1204,806,1164,976),
46		#' stringsAsFactors = FALSE)
47		#'
48		#' res_ind <- statTable(res = res)
49		#'
50		statTable <- function(res)
51		{
52	23x	measure <- c()
53	16x	if(any(names(res) %in% "duree")) measure <- c(measure,"duree")
54	18x	if(any(names(res) %in% "distance")) measure <- c(measure,"distance")
55
56	23x	if(!identical(names(res)[1:7], c("ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst"))) # si les 7 premieres colonnes ne correspondent pas, erreur
57		{
58	3x	stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
59		}
60	20x	if(is.null(measure)) # si il n'y a pas de colonnes duree et/ou distance, erreur
61		{
62	1x	stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
63		}
64	19x	if(!names(res)[8] %in% measure) # si la 8ème colonne n'est ni duree, ni distance, erreur
65		{
66	1x	stop(simpleError("Les 7 premieres variables de res doivent correspondre aux 7 premieres variables du tableau de resultats de la fonction metricOsrmTable : 'ID','idSrc','lonSrc','latSrc','idDst','lonDst','latDst' suivies d'au moins d'une des deux variables 'duree' et 'distance'."))
67		}
68
69	18x	if(any(measure %in% "duree") & any(measure %in% "distance"))
70		{
71	9x	if(any(res$duree %in% -999999.00))
72		{
73	3x	nbNonCalc <- length(res$duree[res$duree %in% -999999.00])
74	1x	if(nbNonCalc == 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (duree = -999999.00). Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs stats."))
75	2x	if(nbNonCalc > 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (duree = -999999.00). Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs stats."))
76
77	3x	res <- res[!res$duree %in% -999999.00,]
78		}
79
80	9x	if(any(res$duree %in% 0) & any(res$distance %in% 0))
81		{
82	2x	nbStables <- length(res$duree[res$duree %in% 0])
83	2x	if(nbStables == 1)
84		{
85	1x	message(paste0("[INFO] Il y a ",nbStables," couple de stable dans la table de r\u00e9sultats (duree = 0)."))
86	1x	message(paste0("Il a \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
87		}
88	2x	if(nbStables > 1)
89		{
90	1x	message(paste0("[INFO] Il y a ",nbStables," couples de stables dans la table de r\u00e9sultats (duree = 0)."))
91	1x	message(paste0("Ils ont \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
92		}
93		}else
94		{
95	7x	nbStables <- 0
96		}
97		}
98
99	18x	if(any(measure %in% "duree") & !any(measure %in% "distance"))
100		{
101	4x	if(any(res$duree %in% -999999.00))
102		{
103	2x	nbNonCalc <- length(res$duree[res$duree %in% -999999.00])
104	1x	if(nbNonCalc == 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (duree = -999999.00). Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs stats."))
105	1x	if(nbNonCalc > 1) message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (duree = -999999.00). Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs stats."))
106
107	2x	res <- res[!res$duree %in% -999999.00,]
108		}
109
110	4x	if(any(res$duree %in% 0))
111		{
112	2x	nbStables <- length(res$duree[res$duree %in% 0])
113	2x	if(nbStables == 1)
114		{
115	1x	message(paste0("[INFO] Il y a ",nbStables," couple de stable dans la table de r\u00e9sultats (duree = 0)."))
116	1x	message(paste0("Il a \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
117		}
118	2x	if(nbStables > 1)
119		{
120	1x	message(paste0("[INFO] Il y a ",nbStables," couples de stables dans la table de r\u00e9sultats (duree = 0)."))
121	1x	message(paste0("Ils ont \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
122		}
123		}else
124		{
125	2x	nbStables <- 0
126		}
127		}
128
129	18x	if(any(measure %in% "distance") & !any(measure %in% "duree"))
130		{
131	5x	if(any(res$distance %in% -999999.00))
132		{
133	2x	nbNonCalc <- length(res$distance[res$distance %in% -999999.00])
134	2x	if(nbNonCalc == 1)
135		{
136	1x	message(paste0("[WARNING] Il y a ",nbNonCalc," couple non calcul\u00e9 dans la table de r\u00e9sultats (distance = -999999.00)."))
137	1x	message(paste0("Il a \u00e9t\u00e9 supprim\u00e9 pour le calcul des indicateurs stats."))
138		}
139	2x	if(nbNonCalc > 1)
140		{
141	1x	message(paste0("[WARNING] Il y a ",nbNonCalc," couples non calcul\u00e9s dans la table de r\u00e9sultats (distance = -999999.00)."))
142	1x	message(paste0("Ils ont \u00e9t\u00e9 supprim\u00e9s pour le calcul des indicateurs stats."))
143		}
144
145	2x	res <- res[!res$distance %in% -999999.00,]
146		}
147
148	5x	if(any(res$distance %in% 0))
149		{
150	2x	nbStables <- length(res$distance[res$distance %in% 0])
151	2x	if(nbStables == 1)
152		{
153	1x	message(paste0("[INFO] Il y a ",nbStables," couple de stable dans la table de r\u00e9sultats (distance = 0)."))
154	1x	message(paste0("Il a \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
155		}
156	2x	if(nbStables > 1)
157		{
158	1x	message(paste0("[INFO] Il y a ",nbStables," couples de stables dans la table de r\u00e9sultats (distance = 0)."))
159	1x	message(paste0("Ils ont \u00e9t\u00e9 pris en compte pour le calcul des indicateurs stats."))
160		}
161		}else
162		{
163	3x	nbStables <- 0
164		}
165		}
166
167	18x	stats <- list()
168
169	18x	stats$nbCouples <- nrow(res)
170	6x	if(nbStables > 0) stats$nbStables <- nbStables
171	18x	stats$nbIdDep <- length(unique(as.data.frame(res)[,"idSrc"]))
172	18x	stats$nbIdArr <- length(unique(as.data.frame(res)[,"idDst"]))
173
174	18x	if(any(measure %in% "duree"))
175		{
176	13x	if(nrow(res) > 0)
177		{
178	12x	stats$tempsMax <- max(as.data.frame(res)[,"duree"], na.rm = TRUE)
179	12x	stats$tempsMin <- min(as.data.frame(res)[,"duree"], na.rm = TRUE)
180	12x	stats$tempsMoyenne <- round(mean(as.data.frame(res)[,"duree"], na.rm = TRUE),2)
181	12x	stats$tempsMediane <- round(stats::median(as.data.frame(res)[,"duree"], na.rm = TRUE),2)
182		}else
183		{
184	1x	stats$tempsMax <- "--"
185	1x	stats$tempsMin <- "--"
186	1x	stats$tempsMoyenne <- "--"
187	1x	stats$tempsMediane <- "--"
188		}
189		}
190
191	18x	if(any(measure %in% "distance"))
192		{
193	14x	if(nrow(res) > 0)
194		{
195	13x	stats$distanceMax <- max(as.data.frame(res)[,"distance"], na.rm = TRUE)
196	13x	stats$distanceMin <- min(as.data.frame(res)[,"distance"], na.rm = TRUE)
197	13x	stats$distanceMoyenne <- round(mean(as.data.frame(res)[,"distance"], na.rm = TRUE),3)
198	13x	stats$distanceMediane <- round(stats::median(as.data.frame(res)[,"distance"], na.rm = TRUE),3)
199		}else
200		{
201	1x	stats$distanceMax <- "--"
202	1x	stats$distanceMin <- "--"
203	1x	stats$distanceMoyenne <- "--"
204	1x	stats$distanceMediane <- "--"
205		}
206		}
207
208	18x	return(stats)
209		}

1		# @name st_make_grid_metric
2		# @title Réalise une grille à partir d'un objet sf de géométrie POLYGON.
3		# @description Fonction interne qui réalise une grille si le paramètre est un objet sf.
4		# @param x Objet sf de géométrie POLYGON.
5		# @return Objet sf sous forme de grille.
6		# @importFrom sf st_bbox st_crs st_polygon st_sf st_sfc
7		# @noRd
8		# @export
9		#
10		st_make_grid_metric <- function (x,
11		n = c(10, 10),
12		offset = sf::st_bbox(x)[c("xmin", "ymin")],
13		crs = sf::st_crs(x))
14		{
15	20x	bb <- sf::st_bbox(x)
16
17	20x	n <- rep(n, length.out = 2)
18	20x	nx <-n[1]
19	20x	ny <- n[2]
20
21	20x	xc <- seq(offset[1], bb[3], length.out = nx + 1)
22	20x	yc <- seq(offset[2], bb[4], length.out = ny + 1)
23
24	20x	ret <- vector("list", nx * ny)
25	20x	square <- function(x1, y1, x2, y2) sf::st_polygon(list(matrix(c(x1, x2, x2, x1, x1, y1, y1, y2, y2, y1), 5)))
26	20x	for (i in 1:nx) for (j in 1:ny) ret[[(j - 1) * nx + i]] <- square(xc[i], yc[j], xc[i + 1], yc[j + 1])
27
28	20x	ret <- sf::st_sf(sf::st_sfc(ret, crs = crs))
29
30	20x	return(ret)
31		}

1		#' @name metricOsrmTable
2		#'
3		#' @title Calculer les temps de trajet et les distances entre deux groupes de points
4		#'
5		#' @description La fonction metricOsrmTable permet de calculer des temps de trajet et des distances entre deux points
6		#' ou deux groupes de points en face à face ou par croisement.
7		#' Si le serveur ne répond pas trois fois alors que vous avez spécifié l'adresse d'un serveur et un profil,
8		#' consultez l'article \href{https://metric-osrm.pages.lab.sspcloud.fr/metric-osrm-package/articles/G-installation.html}{installation}
9		#'
10		#' @param src,dst vecteur numérique de longueur 3 (id/lon/lat), data.frame (colonnes id/lon/lat) ou objet sf.
11		#' Les formats sp ne sont plus acceptés, ils sont convertis en objet sf avec sf::st_as_sf.
12		#' Les formats data.table ne sont pas acceptés, ils sont convertis en data.frame avec as.data.frame.
13		#' @param duree booléen. Si TRUE (par défaut), la fonction retourne la durée.
14		#' @param distance booléen. Si TRUE (par défaut), la fonction retourne la distance.
15		#' @param faceAFace booléen. Si TRUE (par défaut), les couples de points sont pris en face à face
16		#' entre src et dst. Si src et dst n’ont pas la même dimension, les points en trop de la table la plus grande sont ignorés.
17		#' Si FALSE, les couples sont formés selon le croisement en produit cartésien entre src et dst.
18		#' @param allerRetour booléen. Si faceAFace = FALSE et allerRetour = TRUE (par défaut), tous les couples sont formés entre src et dst (hors stables). Ignoré si faceAFace = TRUE.
19		#' @param stable booléen. Si stable = FALSE (par défaut), les stables sont supprimés dans la table en sortie. Sinon (stable = TRUE), la durée et la distance renvoient 0.
20		#' @param rayonMax numérique. Si faceAFace = FALSE, distance maximale en kilomètres pour les couples formés entre src et dst.
21		#' @param nbDstVolOiseau numérique. Si faceAFace = FALSE, nombre maximal de dst par src les plus proches à vol d'oiseau.
22		#' @param nbDstMeasure numérique. Si faceAFace = FALSE, nombre maximal de dst par src les plus proches en temps ou en distance.
23		#' @param optiMeasure texte. Si faceAFace = FALSE et nbDstMeasure > 0, choix du critère des dst les plus proches par src : "duree" ou "distance".
24		#' @param emprise texte. Zone géographique contenant les coordonnées. A préciser si rayonMax > 0, sinon l'argument est ignoré.
25		#' A choisir parmi "FRM" (par défaut) pour la France métropolitaine et ses régions transfrontalières,
26		#' "971" pour la Guadeloupe, "972" pour la Martinique, "973" pour la Guyane, "974" pour la Réunion, "976" pour Mayotte ou "999" pour une autre zone.
27		#' @param exclude texte. Ce paramètre permet d'effectuer les calculs de trajet en évitant un type de route :
28		#' les ferries ("ferry") option RECOMMANDEE car les données ne sont pas exhaustives, les autoroutes (“motorway”), les péages (“toll”) ou aucun type de route (exclude=NULL, paramètre par défaut).
29		#' @param interactive booléen. Choix du contexte d'exécution. Si TRUE, contexte shiny. Par défaut FALSE.
30		#'
31		#' @return data.frame avec les colonnes "ID","idSrc","lonSrc","latSrc","idDst","lonDst","latDst", "duree" et/ou "distance".
32		#'
33		#' @details Les sources (src) correspondent aux points de départ et les destinations (dst) aux points d’arrivée.
34		#'
35		#' Les id doivent toujours être en 1ère position du vecteur ou en 1ère colonne du data.frame.
36		#'
37		#' Si src et dst sont des vecteurs ou des data.frame, les coordonnées doivent être dans le système
38		#' géographique non projeté WGS84 (longitude et latitude, EPSG : 4326).
39		#'
40		#' La fonction convertTo permet de convertir des coordonnees en WGS84 (EPSG : 4326).
41		#'
42		#' Les objets spatiaux sf peuvent être dans n’importe quel système, projeté ou non.
43		#' Mais en sortie, les coordonnées seront dans le système WGS84 (EPSG : 4326).
44		#'
45		#' Si faceAFace = FALSE et allerRetour = TRUE, tous les couples sont formés. Par exemple si scr = c(src_Pau,src_Agen) et dst = c(dst_Pau,dst_Agen),
46		#' alors les couples 'src_Pau' vers 'dst_Agen' et 'src_Agen' vers 'dst_Pau' seront calculés (hors stables 'src_Pau-dst_Pau' et 'src_Agen-dst_Agen').
47		#' Si faceAFace = FALSE et allerRetour = FALSE, un seul couple est calculé, de 'src_Pau' vers 'dst_Agen'.
48		#'
49		#' Les stables peuvent être supprimés de la table de résultats en spécifiant stable = FALSE. Si TRUE, les stables seront repérables avec les valeurs de durée et de distance à 0.
50		#'
51		#' Lorsque faceAFace = FALSE, les arguments rayonMax, nbDstVolOiseau, nbDstMeasure et optiMeasure permettent de filtrer les résultats selon la structure des src et dst.
52		#'
53		#' rayonMax et nbDstVolOiseau permettent de filtrer en amont les couples src->dst pour éviter des calculs vers le serveur inutiles et chronophages.
54		#'
55		#' nbDstMeasure et optiMeasure permettent de filtrer les résultats après le requêtage au serveur. Ne réduit donc pas les temps de calcul.
56		#'
57		#' Si faceAFace = TRUE, les arguments allerRetour, rayonMax, nbDstVolOiseau, nbDstMeasure et optiMeasure sont ignorés.
58		#'
59		#' Si le filtre rayonMax est utilisé (si rayonMax > 0), alors il est indispensable de préciser l'emprise de la zone couverte par les coordonnées.
60		#' Par défaut, l'emprise correspond à la France métropolitaine et ses régions transfrontalières (emprise = "FRM"). Le système de coordonnées projetées, utilisé alors pour effectuer
61		#' les calculs de distances à vol d'oiseau, est le Lambert93 (EPSG 2154). Pour les DOM, il faut préciser le code départemantal du DOM ("971","972","973","974" ou "976").
62		#' Pour information, les codes EPSG en vigueur dans les DOM sont 5490 pour la Guadeloupe et la Martinique, 2972 pour la Guyane, 2975 pour la Réunion et 4471 pour Mayotte.
63		#' Pour toutes autres zones, il faut alors préciser emprise = "999". Dans ce cas, la projection Mercator sera utilisée (EPSG 3395).
64		#'
65		#' Pour des besoins spécifiques, il est possible d’exclure un type de routes parmi les autoroutes, les
66		#' péages ou les ferries( ferries +bacs). Ces routes seront alors exclues des calculs de trajets.
67		#' Il est recommandé de toujours exclure les lignes de ferries présentes dans les données OpenStreetMap (option exclude="ferry") pour limiter
68		#' le champ aux trajets strictement par la route en voiture ; éviter les calculs entre îles et continent typiquement.
69		#' Les données OSM assimilent les bacs maritimes (bacs de Seine par exemple) et fluviaux à des lignes « classiques » de ferries.
70		#' Mais la complétude et la qualité des données OSM en termes de liaisons maritimes
71		#' et autres bacs de liaison ne sont pas garanties. Par ailleurs l’absence de données d’horaires de traversée
72		#' fait que le temps de trajet est calculé sans attente (et sans temps de chargement/déchargement).
73
74		#' @importFrom sf st_as_sf st_crs st_collection_extract st_centroid st_transform st_coordinates st_geometry
75		#' @importFrom RJSONIO fromJSON
76		#' @importFrom RANN nn2
77		#' @export
78		#'
79		#' @examples
80		#' # Specification d'un serveur osrm obligatoire pour executer les exemples
81		#' options(osrm.server = "https://metric-osrm-backend.lab.sspcloud.fr/")
82		#'
83		#' # Specification du profil
84		#' options(osrm.profile = "driving")
85		#'
86		#' # Construction des sources et des destinations.
87		#' sources <- data.frame(id = c("A","B","C"),
88		#' lon = c(4.92,4.86,4.72),
89		#' lat = c(46.15,46.08,45.92),
90		#' stringsAsFactors = FALSE)
91		#'
92		#' destinations <-data.frame(id = c("B","C","D"),
93		#' lon = c(4.86,4.72,4.67),
94		#' lat = c(46.08,45.92,45.83),
95		#' stringsAsFactors = FALSE)
96		#'
97		#' # 3 couples de points calcules en face a face.
98		#' metricOsrmTable(src = sources,
99		#' dst = destinations,
100		#' exclude = "ferry", # option recommandée
101		#' faceAFace = TRUE) # par defaut
102		#'
103		#' # 3 couples de points calcules selon le produit cartesien.
104		#' metricOsrmTable(src = sources,
105		#' dst = destinations,
106		#' exclude = "ferry", # option recommandée
107		#' faceAFace = FALSE)
108		#'
109		#' # 3 couples de points calcules selon le produit cartesien
110		#' # et avec les stables conserves.
111		#' metricOsrmTable(src = sources,
112		#' dst = destinations,
113		#' exclude = "ferry", # option recommandée
114		#' faceAFace = FALSE,
115		#' stable = TRUE)
116		#'
117		#' # 3 couples de points calcules selon le produit cartesien,
118		#' # sans les stables et sans aller-retour.
119		#' metricOsrmTable(src = sources,
120		#' dst = destinations,
121		#' faceAFace = FALSE,
122		#' exclude = "ferry", # option recommandée
123		#' stable = FALSE,
124		#' allerRetour = FALSE)
125		#'
126		#' ### Utilisation des filtres
127		#'
128		#' # Construction des sources et des destinations.
129		#' sources <- data.frame(id = c("C1","C2","C3"),
130		#' lon = c(4.92,4.86,4.72),
131		#' lat = c(46.15,46.08,45.92),
132		#' stringsAsFactors = FALSE)
133		#'
134		#' destinations <-data.frame(id = c("E1","E2","E3"),
135		#' lon = c(4.63,4.75,4.67),
136		#' lat = c(45.95,45.88,45.83),
137		#' stringsAsFactors = FALSE)
138		#'
139		#' ## Les sources et les destinations ne sont pas de meme nature.
140		#' ## Par exemple, les sources peuvent etre des carreaux
141		#' ## et les destinations des equipements.
142		#'
143		#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src.
144		#' metricOsrmTable(src = sources,
145		#' dst = destinations,
146		#' exclude = "ferry",
147		#' faceAFace = FALSE,
148		#' stable = TRUE,
149		#' rayonMax = 40,
150		#' emprise = "FRM")
151		#' # Les distances calculees par la route peuvent etre superieures a 40km :
152		#' # le trajet par la route est forcement plus long en distance qu'a vol d'oiseau.
153		#'
154		#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src
155		#' # puis la plus proche parmi celles-ci.
156		#' metricOsrmTable(src = sources,
157		#' dst = destinations,
158		#' faceAFace = FALSE,
159		#' exclude = "ferry",
160		#' stable = TRUE,
161		#' rayonMax = 40,
162		#' nbDstVolOiseau = 1,
163		#' emprise = "FRM")
164		#' # Les stables, s'il y en a, doivent etre conserves
165		#' # car src et dst ne sont pas de meme nature.
166		#'
167		#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src
168		#' # puis les 2 dst les plus proches parmi celles-ci.
169		#' metricOsrmTable(src = sources,
170		#' dst = destinations,
171		#' faceAFace = FALSE,
172		#' exclude = "ferry",
173		#' stable = TRUE,
174		#' rayonMax = 40,
175		#' nbDstVolOiseau = 2,
176		#' emprise = "FRM")
177		#'
178		#' # On selectionne n dst situees a moins de 40km a vol d'oiseau de chaque src
179		#' # puis les 2 dst les plus proches parmi celles-ci.
180		#' # Enfin, on conserve uniquement 1 dst la plus proche en temps de parcours par la route.
181		#' metricOsrmTable(src = sources,
182		#' dst = destinations,
183		#' faceAFace = FALSE,
184		#' exclude = "ferry",
185		#' stable = TRUE,
186		#' rayonMax = 40,
187		#' nbDstVolOiseau = 2,
188		#' nbDstMeasure = 1,
189		#' optiMeasure = "duree",
190		#' emprise = "FRM")
191		#'
192		metricOsrmTable <- function(src, dst, duree = TRUE, distance = TRUE, faceAFace = TRUE, allerRetour = TRUE, stable = FALSE, rayonMax = 0, nbDstVolOiseau = 0, nbDstMeasure = 0, optiMeasure = c("duree", "distance"), emprise = "FRM", exclude = NULL, interactive = FALSE)
193		{
194	34x	if(any(class(src)=="data.table") )
195		{
196	3x	src<-as.data.frame(src)
197	3x	warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
198		}
199	34x	if(any(class(dst)=="data.table") )
200		{
201	3x	dst<-as.data.frame(dst)
202	3x	warning("Les formats data.table ne sont pas accept\u00e9s, ils sont convertis en data.frame avec as.data.frame")
203		}
204		### verification des parametres
205	34x	verifParamSrcDst(src = src, dst = dst)
206
207		### Conversion de src et dst en data.frame
208	30x	src <- convertToDf(objet = src)
209	30x	dst <- convertToDf(objet = dst)
210
211	30x	if(!faceAFace)
212		{
213		### Suppression des points en doublon
214	23x	src <- unique(src)
215	23x	dst <- unique(dst)
216		}
217
218	30x	if(faceAFace)
219		{
220	7x	res <- osrmTableFaceAFace(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
221
222	23x	}else if(!faceAFace & allerRetour & rayonMax == 0 & nbDstVolOiseau == 0)
223		{
224	8x	res <- osrmTableCartesien(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
225
226	15x	}else if(!faceAFace & !allerRetour & rayonMax == 0 & nbDstVolOiseau == 0)
227		{
228	9x	res <- osrmTableAllerRetour(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, interactive = interactive)
229
230	6x	}else if(!faceAFace & (rayonMax > 0 \| nbDstVolOiseau > 0))
231		{
232		### Recuperation du code epsg a partir de l'emprise declaree
233	6x	code_epsg <- switch(emprise,
234	6x	"FRM"="2154",# Lambert 93
235	6x	"971"="5490",# UTM 20 N
236	6x	"972"="5490",# UTM 20 N
237	6x	"973"="2972",# UTM 22 N
238	6x	"974"="2975",# UTM 40 S
239	6x	"976"="4471",# UTM 38 S
240	6x	"999"="3395") # Mercator
241
242	6x	res <- osrmTableFiltre(src = src, dst = dst, duree = duree, distance = distance, exclude = exclude, rayonMax = rayonMax, nbDstVolOiseau = nbDstVolOiseau, nbDstMeasure = nbDstMeasure, optiMeasure = optiMeasure, code_epsg = code_epsg, interactive = interactive)
243		}
244
245	27x	if(is.null(res))
246		{
247	2x	message(paste0("[WARNING] Aucun couple n'a \u00e9t\u00e9 calcul\u00e9."))
248	2x	message(paste0("V\u00e9rifiez que les filtres ne soient pas trop restrictifs"))
249	2x	message(paste0("ou que les sources et les destinations ne soient pas trop \u00e9loign","\u00e9","es."))
250	2x	return(NULL)
251		}
252
253		# Suppression des stables
254
255	25x	if(!stable)
256		{
257	7x	if(any(res$duree %in% 0) & any(res$distance %in% 0)) res <- res[!res$duree == 0 & !res$distance == 0,]
258		}
259
260	25x	if(nrow(res) > 0)
261		{
262	24x	res <- res[order(res$idSrc),]
263	24x	res$ID <- 1:nrow(res)
264	24x	row.names(res) <- res$ID
265
266		# Avertissement pour les couples non calculés
267
268	24x	message <- FALSE
269	24x	nbNonCalcules <- 0
270
271	24x	if(duree)
272		{
273	20x	res$duree <- round(res$duree/60,2)
274
275	20x	if(!is.na(any(res$duree < 0)))
276		{
277	20x	if(any(res$duree < 0))
278		{
279	2x	nbNonCalcules <- nrow(res[res$duree < 0,])
280	2x	res[res$duree < 0, "duree"] <- -999999
281	2x	message <- TRUE
282		}
283		}
284		}
285
286	24x	if(distance)
287		{
288	24x	res$distance <- round(res$distance/1000,3)
289
290	24x	if(!is.na(any(res$distance < 0)))
291		{
292	24x	if(any(res$distance < 0))
293		{
294	2x	res[res$distance < 0, "distance"] <- -999999
295	2x	message <- TRUE
296		}
297		}
298		}
299
300	24x	if(message)
301		{
302	2x	if(nbNonCalcules == 1)
303		{
304	1x	message(paste0("[WARNING] ",nbNonCalcules," couple n'a pas \u00e9t\u00e9 calcul\u00e9."))
305	1x	message(paste0("Il est rep\u00e9rable dans la table des r\u00e9sultats avec une dur","\u00e9","e et une distance \u00e0 -999999."))
306	1x	message(paste0("Pensez \u00e0 le retirer avant toute analyse de la table."))
307		}
308	2x	if(nbNonCalcules > 1)
309		{
310	1x	message(paste0("[WARNING] ",nbNonCalcules," couples n'ont pas \u00e9t\u00e9 calcul\u00e9s."))
311	1x	message(paste0("Ils sont rep\u00e9rables dans la table des r\u00e9sultats avec une dur","\u00e9","e et une distance \u00e0 -999999."))
312	1x	message(paste0("Pensez \u00e0 les retirer avant toute analyse de la table."))
313		}
314		}
315		}else
316		{
317	1x	message(paste0("[WARNING] Le table de r\u00e9sultats est vide."))
318	1x	message(paste0("Il n'y a que des couples de stables dans la table en entr","\u00e9","e et l'argument stable = FALSE."))
319		}
320
321	25x	return(res)
322		}

1		# @name osrmTableGrpe2
2		# @title Calcul la durée et/ou la distance entre deux points.
3		# @description La fonction interne osrmTableGrpe2 permet de calculer la durée et la distance d'un point
4		# vers un groupe de points ou d'un groupe de points vers un point.
5		# Chaque groupe est composé d'au moins 2 points et moins de 1000 points.
6		# @param couples Un data.frame 7 colonnes "idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID".
7		# @param duree Un booleen. La fonction retourne la durée. Par défaut à TRUE.
8		# @param distance Un booleen. La fonction retourne la distance. Par défaut à TRUE.
9		# @param exclude Une chaine de carctère string. Exclu un type de route pour le calcul du trajet. Par défaut à NULL.
10		# @return Un data.frame
11		# @importFrom shiny withProgress incProgress
12		# @importFrom progress progress_bar
13		# @noRd
14		# @export
15		osrmTableGrpe2 <-function(couples, duree, distance, exclude, interactive)
16		{
17	45x	names(couples) <- c("idSrc","lonSrc","latSrc","idDst","lonDst","latDst","ID")
18
19		# on détermine laquelle des 2 colonnes on fera les calculs pour id unique
20		# en plus de l'ID, il faut aussi les coordonnées pour s'assurer du bon nombre distinct de points
21	43x	lengthSrcId <- nrow(unique(couples[,c(1,2,3)]))
22	43x	lengthDstId <- nrow(unique(couples[,c(4,5,6)]))
23
24		# on garde la liste la plus petite pour avoir un minimum de requêtes à envoyer
25	43x	if(lengthSrcId>=lengthDstId)
26		{
27	21x	id <- 4
28	22x	}else if(lengthSrcId<lengthDstId)
29		{
30	22x	id <- 1
31		}else{}
32
33		# Création de l'index
34	43x	count <- as.numeric(table(couples[,id]))
35	43x	table_idx <- data.frame(id=unique(sort(couples[,id])),COUNT=count, stringsAsFactors=F)
36	43x	table_idx_5_999 <- table_idx[table_idx$COUNT>=5,]
37
38	43x	list_res_1n_n1 <- list()
39
40	43x	if(nrow(table_idx_5_999)>0)
41		{
42	6x	table_idx_5_999$ID2 <- c(1:nrow(table_idx_5_999))
43
44		# Fusion de base avec table_idx pour récupérer l'idx
45	6x	couples_5_999 <- merge(couples,table_idx_5_999,by.x = names(couples)[id], by.y = "id")
46	6x	couples_5_999 <- couples_5_999[order(couples_5_999$COUNT),]
47
48	6x	list_id <- split(couples_5_999[,c("ID","idSrc","lonSrc","latSrc","idDst","lonDst",'latDst')],couples_5_999[,names(couples)[id]])
49
50	6x	table_idx_5_999 <- table_idx_5_999[rev(order(table_idx_5_999$COUNT)),]
51
52	6x	list_id <- list_id[table_idx_5_999$ID]
53
54	6x	if(interactive)
55		{
56	1x	shiny::withProgress(message = "Calculs en cours - 2/3 : ",{
57	!	for(i in 1:length(list_id))
58		{
59	!	list_res_1n_n1[[i]] <- calculs_faceaface_groupe2(id, dt_id = list_id[[i]], duree, distance, exclude)
60
61	!	shiny::incProgress(1/length(list_id))
62		}
63		})
64	5x	}else if(!interactive)
65		{
66	5x	pb2 <- progress::progress_bar$new(
67	5x	format = "Calcul en cours - 2/3 : [:bar] :percent :elapsed",
68	5x	total = length(list_id), clear = FALSE, width= 60
69		)
70
71	5x	pb2$tick(0)
72
73	5x	for(i in 1:length(list_id))
74		{
75	5x	list_res_1n_n1[[i]] <- calculs_faceaface_groupe2(id, dt_id = list_id[[i]], duree, distance, exclude)
76
77	5x	pb2$tick()
78		}
79		}else
80		{}
81		}
82
83	42x	res_2g <- do.call(rbind,list_res_1n_n1)
84
85	42x	if(is.null(res_2g))
86		{
87	37x	pb2 <- progress::progress_bar$new(
88	37x	format = "Calcul en cours - 2/3 : [:bar] :percent :elapsed",
89	37x	total = 2, clear = FALSE, width= 60
90		)
91
92	37x	for (i in 1:2) {
93	74x	pb2$tick()
94	74x	Sys.sleep(0.2)
95		}
96		}
97
98	42x	return(res_2g)
99		}

1		# @name osrmTableCartesien
2		# @title La fonction interne osrmTableCartesien.
3		# @description La fonction interne osrmTableCartesien permet de lancer osrmTable_11_nm.
4		# les couples sont formés à partir du croisement en produit cartésien entre src et dst. 10000 couples max sont acceptés (nombre de points de src x nombre de points de dst < 10000),
5		# au-delà le traitement se fera en face à face
6		# @inheritParams metriOsrmTable
7		# @importFrom shiny withProgress
8		# @importFrom progress progress_bar
9		# @return Un data.frame
10		# @noRd
11		# @export
12		#
13		osrmTableCartesien <- function(src, dst, duree, distance, exclude, interactive)
14		{
15	47x	nb_boucles_src <- nrow(src)%/%100
16	47x	nb_boucles_dst <- nrow(dst)%/%100
17	47x	reste_src <- nrow(src)%%100
18	47x	reste_dst <- nrow(dst)%%100
19
20	47x	if(nrow(src) < 100)
21		{
22	47x	nb_src <- nrow(src)
23		}else
24		{
25	!	nb_src <- 100
26		}
27
28	47x	if(nrow(dst) < 100)
29		{
30	47x	nb_dst <- nrow(dst)
31		}else
32		{
33	!	nb_dst <- 100
34		}
35
36	47x	if(interactive)
37		{
38	2x	shiny::withProgress(message = "Patientez le temps des calculs",{
39
40	!	list_res <- list()
41	!	k <- 1
42	!	i <- 0
43	!	if(nb_boucles_src > 0)
44		{
45	!	for(i in 1:nb_boucles_src)
46		{
47	!	j <- 0
48	!	if(nb_boucles_dst > 0)
49		{
50	!	for(j in 1:nb_boucles_dst)
51		{
52	!	shiny::incProgress(1/(nb_boucles_src*nb_boucles_dst))
53
54	!	list_res[[k]] <- osrmTable_11_nm(src[((i-1)nb_src+1):(inb_src),],
55	!	dst[((j-1)nb_dst+1):(jnb_dst),],
56	!	duree,
57	!	distance,
58	!	exclude,
59	!	faceAFace = FALSE)
60
61	!	k <- k + 1
62		}
63		}
64	!	if(reste_dst > 0)
65		{
66	!	list_res[[k]] <- osrmTable_11_nm(src[((i-1)nb_src+1):(inb_src),],
67	!	dst[(jnb_dst+1):(jnb_dst+reste_dst),],
68	!	duree,
69	!	distance,
70	!	exclude,
71	!	faceAFace = FALSE)
72
73	!	k <- k + 1
74		}
75		}
76		}
77	!	if(reste_src > 0)
78		{
79	!	j <- 0
80	!	if(nb_boucles_dst > 0)
81		{
82	!	for(j in 1:nb_boucles_dst)
83		{
84	!	list_res[[k]] <- osrmTable_11_nm(src[(inb_src+1):(inb_src+reste_src),],
85	!	dst[((j-1)nb_dst+1):(jnb_dst),],
86	!	duree,
87	!	distance,
88	!	exclude,
89	!	faceAFace = FALSE)
90
91	!	k <- k + 1
92		}
93		}
94	!	if(reste_dst > 0)
95		{
96	!	list_res[[k]] <- osrmTable_11_nm(src[(inb_src+1):(inb_src+reste_src),],
97	!	dst[(jnb_dst+1):(jnb_dst+reste_dst),],
98	!	duree,
99	!	distance,
100	!	exclude,
101	!	faceAFace = FALSE)
102
103	!	k <- k + 1
104		}
105		}
106		})
107	45x	}else if(!interactive)
108		{
109	45x	pb <- progress::progress_bar$new(
110	45x	format = "Calcul en cours [:bar] :percent :elapsed",
111	45x	total = nb_boucles_src*nb_boucles_dst, clear = FALSE, width= 60
112		)
113
114	45x	pb$tick(0)
115
116	45x	list_res <- list()
117	45x	k <- 1
118	45x	i <- 0
119	45x	if(nb_boucles_src > 0)
120		{
121	!	for(i in 1:nb_boucles_src)
122		{
123	!	j <- 0
124	!	if(nb_boucles_dst > 0)
125		{
126	!	for(j in 1:nb_boucles_dst)
127		{
128	!	pb$tick()
129	!	list_res[[k]] <- osrmTable_11_nm(src[((i-1)nb_src+1):(inb_src),],
130	!	dst[((j-1)nb_dst+1):(jnb_dst),],
131	!	duree,
132	!	distance,
133	!	exclude,
134	!	faceAFace = FALSE)
135
136	!	k <- k + 1
137		}
138		}
139	!	if(reste_dst > 0)
140		{
141	!	list_res[[k]] <- osrmTable_11_nm(src[((i-1)nb_src+1):(inb_src),],
142	!	dst[(jnb_dst+1):(jnb_dst+reste_dst),],
143	!	duree,
144	!	distance,
145	!	exclude,
146	!	faceAFace = FALSE)
147
148	!	k <- k + 1
149		}
150		}
151		}
152	45x	if(reste_src > 0)
153		{
154	45x	j <- 0
155	45x	if(nb_boucles_dst > 0)
156		{
157	!	for(j in 1:nb_boucles_dst)
158		{
159	!	list_res[[k]] <- osrmTable_11_nm(src[(inb_src+1):(inb_src+reste_src),],
160	!	dst[((j-1)nb_dst+1):(jnb_dst),],
161	!	duree,
162	!	distance,
163	!	exclude,
164	!	faceAFace = FALSE)
165
166	!	k <- k + 1
167		}
168		}
169	45x	if(reste_dst > 0)
170		{
171	45x	list_res[[k]] <- osrmTable_11_nm(src[(inb_src+1):(inb_src+reste_src),],
172	45x	dst[(jnb_dst+1):(jnb_dst+reste_dst),],
173	45x	duree,
174	45x	distance,
175	45x	exclude,
176	45x	faceAFace = FALSE)
177
178	44x	k <- k + 1
179		}
180		}
181
182		}else{}
183
184	44x	res <- do.call(rbind,list_res)
185	44x	res$idSrc <- as.character(res$idSrc)
186	44x	res$idDst <- as.character(res$idDst)
187
188		# On cree un identifiant par couple
189	44x	res$ID <- c(1:nrow(res)) # ID : identifiant de couples
190	44x	res <- res[,c("ID",names(res)[-ncol(res)])]
191
192	44x	return(res)
193		}

1		isopoly <-
2		function (x, breaks, xcoords = "COORDX", ycoords = "COORDY", var = "OUTPUT")
3		{
4	19x	vmin <- min(x[[var]], na.rm = TRUE)
5	19x	vmax <- max(x[[var]], na.rm = TRUE)
6	19x	breaks <- sort(unique(c(vmin, breaks[breaks > vmin & breaks <
7	19x	vmax], vmax)))
8	19x	m <- matrix(data = x[[var]], nrow = length(unique(x[[xcoords]])),
9	19x	dimnames = list(unique(x[[xcoords]]), unique(x[[ycoords]])))
10	19x	lev_low = breaks[1:(length(breaks) - 1)]
11	19x	lev_high = breaks[2:length(breaks)]
12	19x	raw <- isoband::isobands(x = as.numeric(rownames(m)), y = as.numeric(colnames(m)),
13	19x	z = t(m), levels_low = lev_low, levels_high = c(lev_high[-length(lev_high)],
14	19x	vmax + 1e-10))
15	19x	bands <- isoband::iso_to_sfg(raw)
16	19x	iso <- sf::st_sf(id = 1:length(bands), min = lev_low, max = lev_high,
17	19x	geometry = sf::st_sfc(bands), crs = sf::st_crs(x))
18	19x	iso[1, "min"] <- 0
19	19x	iso$center = iso$min + (iso$max - iso$min)/2
20	19x	sf::st_geometry(iso) <- sf::st_make_valid(sf::st_geometry(iso))
21	19x	if (methods::is(sf::st_geometry(iso), c("sfc_GEOMETRYCOLLECTION"))) {
22	!	sf::st_geometry(iso) <- sf::st_collection_extract(sf::st_geometry(iso),
23	!	"POLYGON")
24	19x	}else if (methods::is(sf::st_geometry(iso), c("sfc_GEOMETRY"))) {
25	!	sf::st_geometry(iso) <- sf::st_collection_extract(sf::st_geometry(iso),
26	!	"POLYGON")
27		}
28	19x	iso <- iso[-nrow(iso), ]
29	19x	return(iso)
30		}

1		# @name requeteOsrm_11_nm
2		# @title Calcul la durée et/ou la distance en face à face ou par croisement.
3		# @description La fonction interne requeteOsrm_11_nm permet de calculer
4		# la durée et la distance entre couples de points en face à face ou par croisement.
5		# @param src,dst Undata.frame 3 colonnes id/lon/lat.
6		# @param idx_src,idx_dst Un vecteur numérique de 1 à n où n est le nombre de couples pour la requête.
7		# @param measure Un vecteur caractères. Choix des options entre "duration" et "distance".
8		# @param exclude_str Chaine de caractères string. Exclu un type de route pour le calcul du trajet.
9		# String formé pour la requête. Si exclude = NULL, exclude_str = "".
10		# @return list.
11		# @importFrom RJSONIO fromJSON
12		# @noRd
13		# @export
14		#
15		requeteOsrm_11_nm <-
16		function(src, idx_src, dst, idx_dst, measure, exclude_str)
17		{
18	100x	if(!is.null(getOption("osrm.server")))
19		{
20	99x	if(substr(getOption("osrm.server"),nchar(getOption("osrm.server")),nchar(getOption("osrm.server"))) == "/")
21		{
22	98x	server <- getOption("osrm.server")
23		}else
24		{
25	1x	server <- paste0(getOption("osrm.server"), "/")
26		}
27		}else
28		{
29	1x	server <- getOption("osrm.server")
30		}
31
32	100x	req <- paste(paste0(server, "table/v1/",
33	100x	getOption("osrm.profile"), "/"),
34	100x	paste(clean_coord(src[idx_src,2]),clean_coord(src[idx_src,3]), sep = ",",collapse = ";"),";",
35	100x	paste(clean_coord(dst[idx_dst,2]),clean_coord(dst[idx_dst,3]), sep = ",",collapse = ";"),
36	100x	"?sources=", paste(idx_src-1, collapse = ";"),
37	100x	"&destinations=", paste(length(idx_src):(length(idx_src)+length(idx_dst)-1), collapse = ";"),
38	100x	"&annotations=", paste0(measure, collapse = ","),
39	100x	exclude_str, sep = "")
40
41	100x	req <- utils::URLencode(req)
42
43	100x	res <- tryCatch({
44
45	100x	RJSONIO::fromJSON(req)
46
47	100x	},error = function(err){
48	2x	message("Un encombrement du r\u00e9seau a eu lieu mais le calcul continue.")
49
50		# On attend 5 secondes que le réseau redevienne fluide avant de relancer la requête
51	2x	Sys.sleep(5)
52
53	2x	res <- tryCatch({
54
55	2x	RJSONIO::fromJSON(req)
56
57	2x	},error = function(err){
58	2x	message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x1.")
59
60		# On attend maintenant 10 secondes que le réseau redevienne fluide avant de relancer la requête
61	2x	Sys.sleep(10)
62
63	2x	res <- tryCatch({
64
65	2x	RJSONIO::fromJSON(req)
66
67	2x	},error = function(err){
68	2x	message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x2.")
69
70		# On attend 20 secondes que le réseau redevienne fluide avant de relancer la requête
71	2x	Sys.sleep(30)
72
73	2x	res <- tryCatch({
74
75	2x	RJSONIO::fromJSON(req)
76
77	2x	},error = function(err){
78	2x	message("Le r\u00e9seau ne s'est pas lib\u00e9r\u00e9. Nouvelle relance de la requ\u00eate x3.")
79
80		# On attend 60 secondes que le réseau redevienne fluide avant de relancer la requête
81	2x	Sys.sleep(60)
82
83	2x	res <- tryCatch({
84
85	2x	RJSONIO::fromJSON(req)
86
87	2x	},error = function(err){
88	2x	message("Le r\u00e9seau ne s'est toujours pas lib\u00e9r\u00e9. Arr\u00eat du traitement.")
89	2x	message(err)
90		})
91		})
92		})
93		})
94		})
95
96		# Attente pour laisser le temps à la requête de faire l'aller-retour vers le serveur. Sinon risque de plantage de connexion.
97	98x	Sys.sleep(0.01)
98
99	98x	return(res)
100		}

1		# @name osrmTableFaceAFace
2		# @title La fonction interne osrmTableFaceAFace.
3		# @description La fonction interne osrmTableFaceAFace permet de lancer calculs_faceaface.
4		# Les couples de points sont pris en face à face entre src et dst.
5		# Les points en trop, si src et dst n’ont pas la même dimension, sont ignorés.
6		# @inheritParams metriOsrmTable
7		# @return Un data.frame
8		# @noRd
9		# @export
10		#
11		osrmTableFaceAFace <- function(src, dst, duree, distance, exclude, interactive)
12		{
13	32x	if(nrow(src)>nrow(dst) & nrow(dst)>1)
14		{
15	1x	src <- src[1:nrow(dst),]
16	31x	}else if(nrow(dst)>nrow(src) & nrow(src)>1)
17		{
18	1x	dst <- dst[1:nrow(src),]
19		}else # nrow(src)==nrow(dst)
20		{}
21
22		# on cree une table avec les couples uniques en face a face
23	32x	couplesUniques <- unique(cbind(src,dst))
24	32x	names(couplesUniques) <- c("idSrc","lonSrc","latSrc","idDst","lonDst","latDst")
25
26		# On cree un identifiant par couple
27	30x	couplesUniques$ID <- c(1:nrow(couplesUniques)) # ID : identifiant de couples
28
29	30x	res <- calculs_faceaface(couplesUniques, duree, distance, exclude, interactive)
30
31	27x	return(res)
32		}

1		convertToDf <- function(objet)
2		{
3		# Si objet est un vecteur
4	68x	if(is.vector(objet))
5		{
6	3x	objet <- vectorToDf(vector = objet)
7		}
8
9		# si objet est un objet sp, on le transforme d'abord en objet sf
10	68x	if (methods::is(objet, "Spatial")) {
11	!	objet <- sf::st_as_sf(x = objet)
12	!	warning("Les formats sp ne sont plus accept\u00e9s, ils sont convertis en objet sf avec sf::st_as_sf")
13		}
14		# si objet est un objet sf, on le transforme en data.frame
15	68x	if (testSf(x = objet)) {
16	4x	objet <- sfToDf(x = objet)
17		}
18
19	67x	names(objet) <- c("id", "lon", "lat")
20
21	67x	return(objet)
22		}

1		# @name vectorToDf
2		# @title Transforme une liste de 3 vecteurs de même longueur en dataframe.
3		# @description Fonction interne qui transforme une liste de 3 vecteurs de même longueur en dataframe.
4		# @param src,dst objet sf ou dataframe 2 ou 3 colonnes contenant deux vecteurs numériques sans valeurs manquantes.
5		# @return Erreur si les paramètres ne sont pas conformes.
6		# @noRd
7		# @export
8		#
9		vectorToDf <-
10		function(vector)
11		{
12	5x	dt <- data.frame(id=vector[1],lon=vector[2],lat=vector[3])
13	5x	return(dt)
14		}

1		# @name sfToDf
2		# @title Transforme un objet sf en data.frame.
3		# @description La fonction interne sfToDf permet de transformer un objet sf en data.frame.
4		# @param x objet sf POINT, MULTIPOINT, POLYGON, MULTIPOLYGON, GEOMETRY ou GEOMETRYCOLLECTION.
5		# @return data.frame avec les longitude et latitude en systeme de projection 4326.
6		# @importFrom sf st_crs st_collection_extract st_geometry st_transform st_coordinates st_centroid
7		# @importFrom methods is
8		# @noRd
9		# @export
10		#
11		sfToDf <- function (x)
12		{
13	62x	if (is.na(sf::st_crs(x))) {
14	2x	stop(paste0("L'entr","\u00e9","e ne dispose pas d'un syst\u00e8me de r","\u00e9","f\u00e9rence de coordonn","\u00e9","es valide."))
15		}
16
17	60x	if (methods::is(sf::st_geometry(x), c("sfc_GEOMETRY"))) {
18	!	x <- sf::st_collection_extract(x, "POLYGON", warn = FALSE)
19	60x	}else if (methods::is(sf::st_geometry(x), c("sfc_GEOMETRYCOLLECTION"))) {
20	1x	x <- sf::st_collection_extract(x, "POLYGON", warn = FALSE)
21	59x	}else if (methods::is(sf::st_geometry(x), c("sfc_POLYGON"))) {
22	2x	sf::st_geometry(x) <- suppressWarnings(sf::st_centroid(x = sf::st_geometry(x),
23	2x	of_largest_polygon = T))
24	57x	}else if (methods::is(sf::st_geometry(x), c("sfc_MULTIPOLYGON"))) {
25	!	sf::st_geometry(x) <- suppressWarnings(sf::st_centroid(x = sf::st_geometry(x),
26	!	of_largest_polygon = T))
27		}else{}
28	60x	x <- sf::st_transform(x = x, crs = 4326)
29	60x	coords <- sf::st_coordinates(x)
30	60x	x <- data.frame(id = as.data.frame(x)[,1], lon = as.numeric(clean_coord(coords[,1])), lat = as.numeric(clean_coord(coords[, 2])), stringsAsFactors = FALSE)
31	60x	if (any(names(x)!=c("id","lon","lat"))) {
32	1x	stop(paste0("L'entr","\u00e9","e ne dispose pas d'identifiant."))
33		}
34	59x	return(x)
35		}