Skip to content

Commit

Permalink
Move leaflet function and lintr
Browse files Browse the repository at this point in the history
  • Loading branch information
@Damonamajor
Damonamajor committed Jan 8, 2025
1 parent 4169716 commit fdc19bc
Show file tree
Hide file tree
Showing 7 changed files with 247 additions and 300 deletions.
2 changes: 1 addition & 1 deletion analyses/new_feature/categorical/_descriptive_stats_categorical.qmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -87,7 +87,7 @@ create_histogram_with_statistics <- function(data, target_feature, x_label, y_la
# Create the plot
# Calculate dynamic binwidth based on data range
range_value <- range(data[[target_feature]], na.rm = TRUE)
dynamic_binwidth <- (range_value[2] - range_value[1]) / 30 # Adjust '30' as needed for more or fewer bins
dynamic_binwidth <- (range_value[2] - range_value[1]) / 30
htmltools::tagList(
plot <- data %>%
Expand Down
164 changes: 19 additions & 145 deletions analyses/new_feature/categorical/_spatial_analysis_categorical.qmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,71 +57,6 @@ assessment_pin_new %>%

# Leaflet Maps

```{r, _spatial_analysis_categorical_leaflet_function}
create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme = "high",
longitude = "loc_longitude", latitude = "loc_latitude",
display_as_percent = FALSE) {
# Filter neighborhoods that have at least one observation
nbhd_borders <- nbhd %>%
right_join(dataset, by = c("town_nbhd" = "meta_nbhd_code"))
# Adjust the dataset values if display_as_percent is TRUE
if (display_as_percent) {
dataset[[legend_value]] <- dataset[[legend_value]] * 100
}
# Create the color palette based on order_scheme
if (order_scheme == "low") {
pal <- colorNumeric(palette = "Reds", domain = dataset[[legend_value]], reverse = TRUE)
} else {
pal <- colorNumeric(palette = "Reds", domain = dataset[[legend_value]])
}
# Calculate the bounding box of the filtered neighborhoods
bbox <- st_bbox(nbhd_borders)
# Create the leaflet map
leaflet(dataset) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addCircleMarkers(
lng = ~ get(longitude),
lat = ~ get(latitude),
radius = 5,
color = ~ pal(dataset[[legend_value]]),
popup = ~ {
shap_values <- dataset %>%
select(starts_with("target_feature_shap_")) %>%
summarise_all(~ ifelse(!is.na(.), sprintf("SHAP: %s", scales::dollar(.)), NA)) %>%
apply(1, function(row) {
paste(na.omit(row), collapse = "<br>")
})
paste(
"Pin: ", meta_pin,
ifelse(shap_values == "", "", paste0("<br>", shap_values)),
"<br>", "Relative SHAP: ", scales::percent(relative_shap, accuracy = 0.01),
"<br>", "Feature: ", get(params$added_feature),
"<br>", "New FMV: ", pred_pin_final_fmv_new,
"<br>", "Comparison FMV: ", pred_pin_final_fmv_comp,
"<br>", "FMV Difference: ", scales::percent(diff_pred_pin_final_fmv, accuracy = 0.01)
)
}
) %>%
addPolygons(
data = nbhd_borders,
color = "black",
weight = 2,
fill = FALSE
) %>%
addLegend(
"bottomright",
pal = pal,
values = dataset[[legend_value]],
title = legend_title,
labFormat = if (display_as_percent) labelFormat(suffix = "%") else labelFormat()
)
}
```


## Neighborhood Values

Expand All @@ -130,82 +65,24 @@ create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme
### Percentage of Largest Feature

```{r _spatial_analysis_categorical_mean_feature_neighborhood}
```{r}
create_neighborhood_map <- function(data,
fill_column,
palette,
legend_title,
fill_type = c("continuous", "categorical"),
top_n = NULL) {
fill_type <- match.arg(fill_type)
# Filter to top N most common values if fill type is categorical
if (fill_type == "categorical" && !is.null(top_n)) {
top_values <- data %>%
count(!!sym(fill_column)) %>%
arrange(desc(n)) %>%
slice_head(n = top_n) %>%
pull(!!sym(fill_column))
# Filter data to keep only rows with top values
data <- data %>% filter(!!sym(fill_column) %in% top_values)
}
# Define palette based on fill type
if (fill_type == "continuous") {
fill_palette <- colorNumeric(palette, domain = data[[fill_column]])
} else if (fill_type == "categorical") {
fill_palette <- colorFactor(brewer.pal(n = 8, name = palette), domain = unique(data[[fill_column]]))
}
# Generate popup content dynamically
popup_content <- ~ paste0(
"<strong>Neighborhood Code:</strong> ", meta_nbhd_code, "<br>",
"<strong>Primary Mode Percentage:</strong> ", round(primary_mode_percentage, 2), "%<br>",
"<strong>Secondary Mode Percentage:</strong> ", round(secondary_mode_percentage, 2), "%<br>",
"<strong>Primary Mode:</strong> ", primary_mode, "<br>",
"<strong>Secondary Mode:</strong> ", secondary_mode
)
# Build the map
map <- leaflet(data) %>%
addProviderTiles("CartoDB.Positron") %>%
addPolygons(
fillColor = ~ fill_palette(data[[fill_column]]),
fillOpacity = 0.7,
color = "black",
weight = 1,
popup = popup_content
) %>%
addLegend(
position = "bottomright",
pal = fill_palette,
values = ~ data[[fill_column]],
title = legend_title,
opacity = 0.7
)
return(map)
}
# Map functions are in the helpers.R file
create_neighborhood_map(
data = pin_nbhd,
fill_column = "primary_mode_percentage",
palette = "YlOrRd",
legend_title = "Primary Mode Percentage",
data = pin_nbhd,
fill_column = "primary_mode_percentage",
palette = "YlOrRd",
legend_title = "Primary Mode Percentage",
fill_type = "continuous"
)
```

### Percentage of Second Largest Feature

```{r _spatial_analysis_categorical_median_feature_neighborhood}
create_neighborhood_map(
data = pin_nbhd,
fill_column = "secondary_mode_percentage",
palette = "Blues",
legend_title = "Secondary Mode Percentage",
data = pin_nbhd,
fill_column = "secondary_mode_percentage",
palette = "Blues",
legend_title = "Secondary Mode Percentage",
fill_type = "continuous"
)
```
Expand All @@ -215,28 +92,25 @@ create_neighborhood_map(

```{r _spatial_analysis_categorical_mode_feature_neighborhood}
primary_mode_map <- create_neighborhood_map(
data = pin_nbhd,
fill_column = "primary_mode",
palette = "Set3",
legend_title = "Primary Mode (Top 5)",
fill_type = "categorical",
data = pin_nbhd,
fill_column = "primary_mode",
palette = "Set3",
legend_title = "Primary Mode (Top 5)",
fill_type = "categorical",
top_n = 5
)
```
### Second Modal Value

```{r _spatial_analysis_categorical_second modal value}
secondary_mode_map <- create_neighborhood_map(
data = pin_nbhd,
fill_column = "secondary_mode",
palette = "Set3",
legend_title = "Secondary Mode (Top 5)",
fill_type = "categorical",
data = pin_nbhd,
fill_column = "secondary_mode",
palette = "Set3",
legend_title = "Secondary Mode (Top 5)",
fill_type = "categorical",
top_n = 5
)
```
:::
## Highest and Lowest 100 Values
Expand Down
7 changes: 3 additions & 4 deletions analyses/new_feature/continuous/_descriptive_stats_continuous.qmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,10 +7,10 @@
```{r _descriptive_stats_continuous_descriptive_setup}
create_summary_table <- function(data, target_feature, group_by_column = NULL) {
target_feature <- sym(target_feature)
if (!is.null(group_by_column)) {
formatted_group_by_column <- str_to_title(str_replace_all(group_by_column, "_", " "))
summary_data <- data %>%
group_by(!!sym(group_by_column)) %>%
summarize(
Expand All @@ -34,7 +34,7 @@ create_summary_table <- function(data, target_feature, group_by_column = NULL) {
`NA Count` = sum(is.na(!!target_feature))
)
}
# Display the summary in a datatable
datatable(
summary_data,
Expand All @@ -47,7 +47,6 @@ create_summary_table <- function(data, target_feature, group_by_column = NULL) {
rownames = FALSE
)
}
```

## Overall
Expand Down
2 changes: 0 additions & 2 deletions analyses/new_feature/continuous/_shaps_continuous.qmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -182,8 +182,6 @@ card_individual %>%
plot.title = element_text(hjust = 0.5)
) +
ggtitle("Violin Plot of SHAP Values for Feature Ranges")
```
:::

72 changes: 1 addition & 71 deletions analyses/new_feature/continuous/_spatial_analysis_continuous.qmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -88,76 +88,6 @@ assessment_pin_new %>%
:::
# Leaflet Maps

```{r, _spatial_analysis_continuous_leaflet_function}
create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme = "high",
longitude = "loc_longitude", latitude = "loc_latitude",
display_as_percent = FALSE) {
# Filter neighborhoods that have at least one observation
nbhd_borders <- nbhd %>%
right_join(dataset, by = c("town_nbhd" = "meta_nbhd_code"))
# Create the color palette based on order_scheme
if (order_scheme == "low") {
pal <- colorNumeric(palette = "Reds", domain = dataset[[legend_value]], reverse = TRUE)
} else {
pal <- colorNumeric(palette = "Reds", domain = dataset[[legend_value]])
}
# Calculate the bounding box of the filtered neighborhoods
bbox <- st_bbox(nbhd_borders)
# Create the leaflet map
leaflet(dataset) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addCircleMarkers(
lng = ~get(longitude),
lat = ~get(latitude),
radius = 5,
color = ~pal(dataset[[legend_value]]), # Fill color
stroke = TRUE, # Enable the outline (stroke)
weight = 1, # Set the stroke thickness
opacity = 1, # Stroke opacity
fillOpacity = 0.8, # Marker fill opacity
fill = TRUE, # Fill the marker
popup = ~ {
shap_values <- dataset %>%
select(starts_with("target_feature_shap_")) %>%
summarise_all(~ ifelse(!is.na(.), sprintf("SHAP: %s", scales::dollar(.)), NA)) %>%
apply(1, function(row) {
paste(na.omit(row), collapse = "<br>")
})
paste(
"Pin: ", meta_pin,
ifelse(shap_values == "", "", paste0("<br>", shap_values)),
"<br>", "Relative SHAP: ", scales::percent(relative_shap, accuracy = 0.01),
"<br>", "Feature: ", sprintf("%.2f", get(params$added_feature)),
"<br>", "New FMV: ", pred_pin_final_fmv_new,
"<br>", "Comparison FMV: ", pred_pin_final_fmv_comp,
"<br>", "FMV Difference: ", scales::percent(diff_pred_pin_final_fmv)
)
}
) %>%
addPolygons(
data = nbhd_borders,
color = "black",
weight = 2,
fill = FALSE
) %>%
addLegend(
"bottomright",
pal = pal,
values = dataset[[legend_value]],
title = legend_title,
labFormat = if (display_as_percent) {
function(type, cuts, p) scales::percent(cuts)
} else {
labelFormat()
}
)
}
```

## Highest and Lowest 100 Values

::: panel-tabset
Expand All @@ -167,6 +97,7 @@ create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme
Be careful interpreting values which are the max and min of the raw value, since ties are not accounted for. For example, if there are 10,000 parcels which are 0 feet from a newly constructed building, the map will not be a full representation.

```{r _spatial_analysis_continuous_largest_values}
# Map functions are in the helpers.R file
highest_100 <- leaflet_data %>%
arrange(desc(!!sym(target_feature_value))) %>%
dplyr::slice(1:100)
Expand All @@ -185,7 +116,6 @@ lowest_100 <- leaflet_data %>%
dplyr::slice(1:100)
create_leaflet_map(lowest_100, {{ target_feature_value }}, "Lowest 100 Values", order_scheme = "low")
```

### Highest 100 SHAP Values
Expand Down
Loading

0 comments on commit fdc19bc

Please sign in to comment.