R/dsidd_split_osrmTable.R

In arnaudmilet/medtRucks: Package de préparation et de valorisation des données brutes de mesure d'accès aux soins en France

#' Découpe les tables sources et destinations lorsqu'elles sont trop grande et restitue une liste normale
#'
#' @param source sf correpondant aux données sources
#' @param destination sf correpondant aux données destination
#' @param nb Nombre de lignes maximum des sources et destinations
#'
#' @return une liste de identique à la liste que la fonction osrmTable aurait rendue sans le découpage
#'
#' @examples
#'\dontrun{
#'apotheke.sf <- st_read(system.file("gpkg/apotheke.gpkg", package = "osrm"), quiet = TRUE)
#'distA3 <- osrmTable(loc = apotheke.sf[1:10,])
#'distA3_split <- dsidd_split_osrmTable(source = apotheke.sf[1:10,])
#'dsidd_split_osrmTable(source = apotheke.sf,destination = apotheke.sf,nb=50)
#'}
#' @importFrom dplyr mutate group_by distinct
#' @importFrom osrm osrmTable
#' @importFrom purrr map walk
#' @importFrom tidyr nest
dsidd_split_osrmTable <- function(source,destination,nb){
  source_tbl <- source %>%
    dplyr::mutate(
      group=rep(1:ceiling(nrow(source)/nb),length.out=nrow(source))
    ) %>%
    dplyr::group_by(group) %>%
    tidyr::nest()

  destination_tbl <- destination %>%
    dplyr::mutate(
      group=rep(1:ceiling(nrow(destination)/nb),length.out=nrow(destination))
    ) %>%
    dplyr::group_by(group) %>%
    tidyr::nest()

  x <- source_tbl$data[[1]]
  y <- destination_tbl$data[[1]]

  nb_matrix <- 0

  list_dist_mat <- purrr::map(source_tbl$data,function(x){
    purrr::map(destination_tbl$data,function(y){
      nb_matrix <<- nb_matrix +1
      print(paste0("Traitement de la matrice ", nb_matrix))
      osrm::osrmTable(src = x, dst = y)
    })
  })
  dist_mat <- list()
  x_dist_mat <- list()
  dist_mat$durations <- NULL
  dist_mat$sources <- NULL
  dist_mat$destinations <- NULL

  purrr::walk(list_dist_mat,function(x){
    x_dist_mat <<- list()
    x_dist_mat$durations <<- NULL
    x_dist_mat$destinations <<- NULL
    purrr::walk(x,function(y){
      dist_mat$sources <<- dplyr::distinct(rbind(dist_mat$sources,y$sources))
      x_dist_mat$durations <<- cbind(x_dist_mat$durations,y$durations)
      x_dist_mat$destinations <<- dplyr::distinct(rbind(x_dist_mat$destinations,y$destinations))
    })
    dist_mat$durations <<- rbind(dist_mat$durations,x_dist_mat$durations)
    dist_mat$destinations <<- x_dist_mat$destinations
  })

  rownames(dist_mat$durations) <- rownames(source)
  colnames(dist_mat$durations) <- rownames(destination)
  dist_mat
  return(dist_mat)
}