include ability to add dist matrices for njtierney#77

R/max_coverage.R

@@ -18,6 +18,12 @@
 #'   you are interested in. If a number is less than distance_cutoff, it will be
 #'   1, if it is greater than it, it will be 0.
 #' @param n_added the maximum number of facilities to add.
+#' @param d_existing_user Optional distance matrix between existing facilities
+#' and users. Default distances are direct (geospherical ellipsoidal) distances;
+#' this allows alternative measures such as street-network distances to be
+#' submitted (see Examples).
+#' @param d_proposed_user Option distance matrix between proposed facilities and
+#' users (see Examples).
 #' @param solver character "glpk" (default) or "lpSolve". "gurobi" is currently
 #'   in development, see <https://github.com/njtierney/maxcovr/issues/25>
 #'
@@ -52,24 +58,50 @@
 #' # get the summaries
 #' mc_result$summary
 #'
+#' # Example of street-network distance calculations
+#' \dontrun{
+#' library(dodgr)
+#' net <- dodgr_streetnet_sf ("york england") %>%
+#'     weight_streetnet (wt_profile = "foot")
+#'
+#' from <- match_points_to_graph (v, york_selected [, c ("long", "lat")])
+#' to <- match_points_to_graph (v, york_crime [, c ("long", "lat")])
+#' d_existing_user <- dodgr_dists (net, from = from, to = to)
+#'
+#' from <- match_points_to_graph (v, york_unselected [, c ("long", "lat")])
+#' d_proposed_user <- dodgr_dists (net, from = from, to = to)
+#'
+#' mc_result <- max_coverage(existing_facility = york_selected,
+#'                           proposed_facility = york_unselected,
+#'                           user = york_crime,
+#'                           distance_cutoff = 100,
+#'                           n_added = 20,
+#'                           d_existing_user = d_existing_user,
+#'                           d_proposed_user = d_proposed_user)
+#'
+#' }
 #' @export
 max_coverage <- function(existing_facility,
                          proposed_facility,
                          user,
                          distance_cutoff,
                          n_added,
+                         d_existing_user = NULL,
+                         d_proposed_user = NULL,
                          solver = "glpk"){
 
     # give user an ID
     user <- tibble::rowid_to_column(user, var = "user_id")
 
     user_not_covered <- find_users_not_covered(existing_facility,
                                                user,
-                                               distance_cutoff)
+                                               distance_cutoff,
+                                               d_existing_user = d_existing_user)
 
     A <- binary_distance_matrix(facility = proposed_facility,
                                 user = user_not_covered,
-                                distance_cutoff = distance_cutoff)
+                                distance_cutoff = distance_cutoff,
+                                d_proposed_user = d_proposed_user)
 
     colnames(A) <- 1:nrow(proposed_facility)
     user_id_list <- 1:nrow(user_not_covered)

R/utils.R

@@ -202,19 +202,28 @@ nearest_facility_distances <- function(existing_facility,
 #'   0 otherwise.
 binary_distance_matrix <- function(facility,
                                    user,
-                                   distance_cutoff){
-
-    facility_cpp <- facility %>%
-        dplyr::select(lat, long) %>%
-        as.matrix()
-
-    user_cpp <- user %>%
-        dplyr::select(lat, long) %>%
-        as.matrix()
-
-    A <- maxcovr::binary_matrix_cpp(facility = facility_cpp,
-                                    user = user_cpp,
-                                    distance_cutoff = distance_cutoff)
+                                   distance_cutoff,
+                                   d_proposed_user = NULL){
+
+    if (is.null (d_proposed_user)){
+        facility_cpp <- facility %>%
+            dplyr::select(lat, long) %>%
+            as.matrix()
+
+        user_cpp <- user %>%
+            dplyr::select(lat, long) %>%
+            as.matrix()
+
+        A <- maxcovr::binary_matrix_cpp(facility = facility_cpp,
+                                        user = user_cpp,
+                                        distance_cutoff = distance_cutoff)
+    } else {
+        # reduce d_proposed_user down to submitted `user_not_covered`:
+        d_proposed_user <- d_proposed_user [, user_not_covered$user_id]
+        d_proposed_user [is.na (d_proposed_user)] <-
+            max (d_proposed_user, na.rm = TRUE)
+        A <- t (d_proposed_user < distance_cutoff)
+    }
 
     return(A)
 
@@ -225,20 +234,39 @@ binary_distance_matrix <- function(facility,
 #' @param existing_facility data.frame of existing facilities
 #' @param user  data.frame of existing users
 #' @param distance_cutoff integer of distance cutoff
+#' @param d_existing_user Optional distance matrix between existing facilities
+#' and users.
 #'
 #' @return data.frame of those users not covered by current facilities
 find_users_not_covered <- function(existing_facility,
                                    user,
-                                   distance_cutoff){
-
-
-    # make nearest dist into dataframe
-    dat_nearest_no_cov <- nearest_facility_distances(
-        existing_facility = existing_facility,
-        user = user) %>%
-        # leave only those not covered
-        dplyr::filter(distance > distance_cutoff)
-
+                                   distance_cutoff,
+                                   d_existing_user = NULL){
+
+
+    if (is.null (d_existing_user)){
+        # make nearest dist into dataframe
+        dat_nearest_no_cov <- nearest_facility_distances(
+            existing_facility = existing_facility,
+            user = user) %>%
+            # leave only those not covered
+            dplyr::filter(distance > distance_cutoff)
+
+    } else {
+        if (nrow (d_existing) != nrow (existing_facility) |
+            ncol (d_existing) != nrow (user))
+            stop ("'d_existing_user' must have same number of rows as 'user',",
+                  " and same number of columns as 'existing_facility'")
+
+        d_existing_user [is.na(d_existing_user)] <-
+            max(d_existing_user, na.rm = TRUE)
+        index <- which(apply(d_existing_user, 2, min) > distance_cutoff)
+        nearest_facility <- t(apply(d_existing_user [, index], 2,
+                                      function(i) c(which.min(i), min(i))))
+        dat_nearest_no_cov <- tibble::tibble (user_id = index,
+                                    facility_id = nearest_facility[, 1],
+                                    distance = nearest_facility[, 2])
+    }
     user_not_covered <- dplyr::left_join(dat_nearest_no_cov,
                                          user,
                                          by = "user_id")