diff --git a/R/final_format_utils.R b/R/final_format_utils.R index 673ab94..9835a01 100644 --- a/R/final_format_utils.R +++ b/R/final_format_utils.R @@ -980,7 +980,9 @@ format_fix_column_classes <- function(df, warn_on_change = TRUE, warn_on_missing state = "character", business_status = "character", lat = "numeric", - lon = "numeric" + lon = "numeric", + district = "character", + district_std = "character" ) cols_present <- intersect(names(expected_classes), names(df)) @@ -1237,7 +1239,7 @@ run_final_formatting <- function(state, "enrollment", "current", "med_exempt", "rel_exempt"), optional_cols = c("school_type", "school_level", "excluded_note", "addr_clean", "city", "zip", "state", "business_status", - "lat", "lon") + "lat", "lon", "district", "district_std") ) kinder_dat <- format_fix_column_classes(kinder_dat) diff --git a/R/geocoding_utils.R b/R/geocoding_utils.R index 60ea85d..27ed6ce 100644 --- a/R/geocoding_utils.R +++ b/R/geocoding_utils.R @@ -129,6 +129,10 @@ get_zip <- function(lat, lon, data_year = 2020) { #' #' @param lat Numeric vector of latitudes in decimal degrees (WGS84). #' @param lon Numeric vector of longitudes in decimal degrees (WGS84). +#' @param state_abbr Character vector of state abbreviations (e.g., \code{"MD"}) +#' used to filter TIGER/Census geometries and speed up spatial joins. +#' @param data_year Integer. The year of Census TIGER/Line shapefiles to use. +#' Defaults to \code{2020}. #' #' @return A tibble with: #' \describe{ @@ -140,7 +144,9 @@ get_zip <- function(lat, lon, data_year = 2020) { #' } #' #' @examples -#' get_geo_info(39.2904, -76.6122) +#' \dontrun{ +#' get_geo_info(lat = 39.2904, lon = -76.6122, state_abbr = "MD") +#' } #' #' @importFrom sf st_as_sf st_transform st_join st_within #' @importFrom tibble tibble diff --git a/R/matching_schools_utils.R b/R/matching_schools_utils.R index b6ad082..d3f357f 100644 --- a/R/matching_schools_utils.R +++ b/R/matching_schools_utils.R @@ -177,7 +177,7 @@ match_locations <- function( } res <- data.frame(name = name, score_sum = score_sum) - return(res[, c(return_name, return_score)]) + return(res[, c(return_name, return_score), drop = FALSE]) } @@ -209,7 +209,13 @@ match_locations <- function( #' @export #' #' @examples -#' cleaned <- fix_school_level_na(kinder_dat_unique, n_years_data = 10, id_col = "ids_tmp") +#' dat <- data.frame( +#' school_name_std = c("oak elementary", "oak elementary"), +#' county_std = c("riverside", "riverside"), +#' school_type = c("public", "public"), +#' school_level = c("elementary", NA_character_) +#' ) +#' cleaned <- fix_school_level_na(dat, n_years_data = 10, id_col = "ids_tmp") fix_school_level_na <- function(data, n_years_data, id_col = "ids_tmp") { grp_cols <- c("school_name_std", "county_std", "school_type") @@ -267,7 +273,13 @@ fix_school_level_na <- function(data, n_years_data, id_col = "ids_tmp") { #' @export #' #' @examples -#' cleaned <- fix_school_type_na(kinder_dat_unique, n_years_data = 10, id_col = "ids_tmp") +#' dat <- data.frame( +#' school_name_std = c("oak elementary", "oak elementary"), +#' county_std = c("riverside", "riverside"), +#' school_level = c("elementary", "elementary"), +#' school_type = c("public", NA_character_) +#' ) +#' cleaned <- fix_school_type_na(dat, n_years_data = 10, id_col = "ids_tmp") fix_school_type_na <- function(data, n_years_data, id_col = "ids_tmp") { grp_cols <- c("school_name_std", "county_std", "school_level") @@ -502,47 +514,45 @@ match_schools_names <- function(data1, data2, stringsAsFactors = FALSE ) - # When there is only one candidate, select it directly. - if (nrow(dists_gtbl) == 1L) { - best_idx <- match(dists_gtbl$name, data2_sub$school_name_std) - + # Use pre-computed lowercased filter values for this row + filter_vals_i <- filter_vals_all[i, , drop = FALSE] + filter_vals_rep <- filter_vals_i[rep(1L, nrow(dists_gtbl)), , drop = FALSE] + # Guard empty candidate names so prob_osa remains finite when dividing by + # the standardized candidate-name length. + candidate_name_length <- pmax(nchar(data2_sub$school_name_std), 1L) + + dists_gtbl <- dists_gtbl %>% + dplyr::mutate(prob_osa = osa / candidate_name_length) + + mo <- dists_gtbl %>% + dplyr::as_tibble() %>% + dplyr::mutate( + name = data1_row$school_name_std, + name_options = data2_sub$school_name_std + ) %>% + dplyr::bind_cols(filter_vals_rep) %>% + dplyr::select(name, name_options, dplyr::any_of(match_cols1), + dplyr::everything()) %>% + dplyr::filter(jw < .5, jaccard < .5) %>% + dplyr::mutate(match_level = dplyr::case_when( + (jaccard <= 0.05 & cosine <= 0.05) ~ 1L, + (jw <= 0.15) ~ 1L, + (soundex == 0 & jw <= 0.3) ~ 1L, + (soundex == 0 & cosine <= 0.25) ~ 2L, + (jaccard <= 0.15 & cosine <= 0.15 & prob_osa <= 0.4) ~ 2L, + (jw <= 0.21) ~ 2L, + TRUE ~ 1000L + )) + + if (any(mo$match_level <= 3L)) { + best_local <- which.min(mo$match_level) + best_match_scores <- mo[best_local, ] + best_idx <- match(mo$name_options[best_local], + data2_sub$school_name_std) } else { - dists_gtbl <- dists_gtbl %>% - dplyr::mutate(prob_osa = osa / nchar(data2_sub$school_name_std)) - - # Use pre-computed lowercased filter values for this row - filter_vals_i <- filter_vals_all[i, , drop = FALSE] - - mo <- dists_gtbl %>% - dplyr::as_tibble() %>% - dplyr::mutate( - name = data1_row$school_name_std, - name_options = data2_sub$school_name_std - ) %>% - dplyr::bind_cols(filter_vals_i[rep(1L, nrow(.)), ]) %>% - dplyr::select(name, name_options, dplyr::any_of(match_cols1), - dplyr::everything()) %>% - dplyr::filter(jw < .5, jaccard < .5) %>% - dplyr::mutate(match_level = dplyr::case_when( - (jaccard <= 0.05 & cosine <= 0.05) ~ 1L, - (jw <= 0.15) ~ 1L, - (soundex == 0 & jw <= 0.3) ~ 1L, - (soundex == 0 & cosine <= 0.25) ~ 2L, - (jaccard <= 0.15 & cosine <= 0.15 & prob_osa <= 0.4) ~ 2L, - (jw <= 0.21) ~ 2L, - TRUE ~ 1000L - )) - - if (any(mo$match_level <= 3L)) { - best_local <- which.min(mo$match_level) - best_match_scores <- mo[best_local, ] - best_idx <- match(mo$name_options[best_local], - data2_sub$school_name_std) - } else { - return(list(matched = NULL, - unmatched = data1_row, - match_opts = setNames(list(mo), data1_row$school_name_std))) - } + return(list(matched = NULL, + unmatched = data1_row, + match_opts = setNames(list(mo), data1_row$school_name_std))) } } @@ -631,13 +641,18 @@ match_schools_names <- function(data1, data2, matched_df <- dplyr::bind_rows(matched_rows) unmatched_dat1 <- dplyr::bind_rows(unmatched_rows) + matched_names <- rlang::`%||%`(matched_df[["school_name_std_data2"]], character(0)) unmatched_dat2 <- data2 %>% - dplyr::filter(!(school_name_std %in% matched_df$school_name_std_data2)) + dplyr::filter(!(school_name_std %in% matched_names)) - match_options <- dplyr::bind_rows(match_options) + match_options <- if (length(match_options) > 0L) { + dplyr::bind_rows(match_options) + } else { + tibble::tibble() + } match_summary <- table(c( - matched_df$match_category, + if ("match_category" %in% names(matched_df)) matched_df$match_category else character(0), rep("Unmatched_data1", nrow(unmatched_dat1)), rep("Unmatched_data2", nrow(unmatched_dat2)) )) @@ -663,6 +678,3 @@ match_schools_names <- function(data1, data2, - - - diff --git a/tests/test_modular_functions.R b/inst/scripts/test_modular_functions.R similarity index 100% rename from tests/test_modular_functions.R rename to inst/scripts/test_modular_functions.R diff --git a/man/fix_school_level_na.Rd b/man/fix_school_level_na.Rd index 769e904..813aa97 100644 --- a/man/fix_school_level_na.Rd +++ b/man/fix_school_level_na.Rd @@ -24,5 +24,11 @@ where school_level has NAs but all non-NA values are identical. In these cases, the function fills in missing school_level values for all rows in the group. } \examples{ -cleaned <- fix_school_level_na(kinder_dat_unique, n_years_data = 10, id_col = "ids_tmp") +dat <- data.frame( + school_name_std = c("oak elementary", "oak elementary"), + county_std = c("riverside", "riverside"), + school_type = c("public", "public"), + school_level = c("elementary", NA_character_) +) +cleaned <- fix_school_level_na(dat, n_years_data = 10, id_col = "ids_tmp") } diff --git a/man/fix_school_type_na.Rd b/man/fix_school_type_na.Rd index 7e9647f..0a67f95 100644 --- a/man/fix_school_type_na.Rd +++ b/man/fix_school_type_na.Rd @@ -24,5 +24,11 @@ where school_type has NAs but all non-NA values are identical. In these cases, the function fills in missing school_type values for all rows in the group. } \examples{ -cleaned <- fix_school_type_na(kinder_dat_unique, n_years_data = 10, id_col = "ids_tmp") +dat <- data.frame( + school_name_std = c("oak elementary", "oak elementary"), + county_std = c("riverside", "riverside"), + school_level = c("elementary", "elementary"), + school_type = c("public", NA_character_) +) +cleaned <- fix_school_type_na(dat, n_years_data = 10, id_col = "ids_tmp") } diff --git a/man/get_geo_info.Rd b/man/get_geo_info.Rd index 7475d1c..f654139 100644 --- a/man/get_geo_info.Rd +++ b/man/get_geo_info.Rd @@ -10,6 +10,12 @@ get_geo_info(state_abbr = state, lat, lon, data_year = 2020) \item{lat}{Numeric vector of latitudes in decimal degrees (WGS84).} \item{lon}{Numeric vector of longitudes in decimal degrees (WGS84).} + +\item{state_abbr}{Character vector of state abbreviations (e.g., \code{"MD"}) +used to filter TIGER/Census geometries and speed up spatial joins.} + +\item{data_year}{Integer. The year of Census TIGER/Line shapefiles to use. +Defaults to \code{2020}.} } \value{ A tibble with: @@ -27,6 +33,8 @@ for each coordinate pair by performing spatial joins against both county and ZCTA boundaries. } \examples{ -get_geo_info(39.2904, -76.6122) +\dontrun{ +get_geo_info(lat = 39.2904, lon = -76.6122, state_abbr = "MD") +} } diff --git a/tests/testthat/test-final_format_utils.R b/tests/testthat/test-final_format_utils.R new file mode 100644 index 0000000..2d06a70 --- /dev/null +++ b/tests/testthat/test-final_format_utils.R @@ -0,0 +1,57 @@ +# ---- format_select_columns() ------------------------------------------------- + +test_that("format_select_columns() retains district and district_std when present", { + df <- data.frame( + school_id = "001", + year = 2023L, + school_name = "Test School", + county_name = "Test County", + enrollment = 100L, + current = 90L, + med_exempt = 2L, + rel_exempt = 1L, + district = "Test USD", + district_std = "test", + stringsAsFactors = FALSE + ) + result <- suppressMessages( + format_select_columns( + df, + required_cols = c("school_id", "year", "school_name", "county_name", + "enrollment", "current", "med_exempt", "rel_exempt"), + optional_cols = c("school_type", "school_level", "excluded_note", + "addr_clean", "city", "zip", "state", "business_status", + "lat", "lon", "district", "district_std") + ) + ) + expect_true("district" %in% names(result)) + expect_true("district_std" %in% names(result)) + expect_equal(result$district, "Test USD") + expect_equal(result$district_std, "test") +}) + +test_that("format_select_columns() works when district columns are absent", { + df <- data.frame( + school_id = "001", + year = 2023L, + school_name = "Test School", + county_name = "Test County", + enrollment = 100L, + current = 90L, + med_exempt = 2L, + rel_exempt = 1L, + stringsAsFactors = FALSE + ) + result <- suppressMessages( + format_select_columns( + df, + required_cols = c("school_id", "year", "school_name", "county_name", + "enrollment", "current", "med_exempt", "rel_exempt"), + optional_cols = c("school_type", "school_level", "excluded_note", + "addr_clean", "city", "zip", "state", "business_status", + "lat", "lon", "district", "district_std") + ) + ) + expect_false("district" %in% names(result)) + expect_false("district_std" %in% names(result)) +}) diff --git a/tests/testthat/test-match_schools_names.R b/tests/testthat/test-match_schools_names.R index cf0d895..bf66060 100644 --- a/tests/testthat/test-match_schools_names.R +++ b/tests/testthat/test-match_schools_names.R @@ -71,7 +71,7 @@ test_that("non-exact candidates return status 3 with up to 10 rows", { groups2 <- rep("beta county", 15) res <- tidyschoolvax:::match_schools_batch_cpp( - names1 = "washington highschool", + names1 = "washngton highschool", groups1 = "beta county", names2 = names2, groups2 = groups2, @@ -89,7 +89,7 @@ test_that("status-3 candidates include all six pre-computed metrics", { groups2 <- rep("beta county", 5) res <- tidyschoolvax:::match_schools_batch_cpp( - names1 = "washington highschool", + names1 = "washngton highschool", groups1 = "beta county", names2 = names2, groups2 = groups2, @@ -181,7 +181,7 @@ test_that("NA group in data1 is treated as unmatched", { test_that("multiple data1 rows with different groups are handled independently", { res <- tidyschoolvax:::match_schools_batch_cpp( - names1 = c("lincoln elementary", "no match school"), + names1 = c("lincoln elementary", "zzz"), groups1 = c("alpha county", "alpha county"), names2 = c("lincoln elementary", "jefferson middle"), groups2 = c("alpha county", "alpha county"),