Skip to content

Commit

Permalink
Stage leaflet changes
Browse files Browse the repository at this point in the history
  • Loading branch information
@Damonamajor
Damonamajor committed Aug 8, 2024
1 parent 1b30286 commit f352ab3
Showing 1 changed file with 58 additions and 61 deletions.
119 changes: 58 additions & 61 deletions analyses/new-feature-template.qmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1374,9 +1374,7 @@ assessment_pin %>%
```

:::


```{r leaflet_function}
```{r}
create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme = "high", longitude = "loc_longitude", latitude = "loc_latitude") {
# Filter neighborhoods that have at least one observation
nbhd_borders <- nbhd %>%
Expand All @@ -1400,15 +1398,23 @@ create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme
lat = ~ get(latitude),
radius = 5,
color = ~ pal(dataset[[legend_value]]),
popup = ~ paste(
"<br>", "Pin: ", dataset$meta_pin,
"<br>", "SHAP:", dollar(dataset[[params$added_feature_shap]]),
"<br>", "Relative SHAP", dataset$shap_relative,
"<br>", "Feature:", sprintf("%.2f", dataset[[params$added_feature]]),
"<br>", "New FMV:", dataset$pred_pin_final_fmv_new,
"<br>", "Comparison FMV: ", dataset$pred_pin_final_fmv_comparison,
"<br>", "FMV Difference: ", dollar(dataset$diff_pred_pin_final_fmv)
)
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,
Expand All @@ -1426,110 +1432,109 @@ create_leaflet_map <- function(dataset, legend_value, legend_title, order_scheme
```

## Highest and Lowest 100 Values
Three different types of high and low values are produced; the values of the feature we are analyzing, the impact that can be determined through the SHAPs, and the largest effects in change in FMV.

::: panel-tabset
Three different types of high and low values are produced; the values of the feature we are analyzing, the impact that can be determined through the SHAPs, and the largest effects in change in FMV.

::: panel-tabset
### Largest 100 Values

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.
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}
highest_100 <- working_data_pin %>%
arrange(desc(!!sym(params$added_feature))) %>%
slice(1:100)
highest_100 <- leaflet_data %>%
arrange(desc(!!sym(target_feature_value))) %>%
dplyr::slice(1:100)
create_leaflet_map(highest_100, params$added_feature, "Largest 100 Values", order_scheme = "high")
create_leaflet_map(highest_100, {{ target_feature_value }}, "Largest 100 Values")
```

### Lowest 100 Values

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.
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}
lowest_100 <- working_data_pin %>%
lowest_100 <- leaflet_data %>%
distinct(meta_pin, .keep_all = TRUE) %>%
arrange(!!sym(params$added_feature)) %>%
arrange(!!sym({{ target_feature_value }})) %>%
slice(1:100)
create_leaflet_map(lowest_100, params$added_feature, "Lowest 100 Values", order_scheme = "low")
create_leaflet_map(lowest_100, {{ target_feature_value }}, "Lowest 100 Values", order_scheme = "low")
```

### Highest 100 SHAP Values

```{r}
highest_100 <- working_data_card %>%
arrange(desc(!!sym(params$added_feature_shap))) %>%
highest_100 <- leaflet_data %>%
arrange(desc(shap_total)) %>%
slice(1:100)
create_leaflet_map(highest_100, params$added_feature_shap, "Highest 100 SHAPs")
create_leaflet_map(highest_100, "shap_total", "Highest 100 SHAPs")
```

### Lowest 100 SHAP Values

```{r}
# Example usage with the dataset sliced outside the function
lowest_100 <- working_data_card %>%
arrange(!!sym((params$added_feature_shap))) %>%
lowest_100 <- leaflet_data %>%
arrange(shap_total) %>%
slice(1:100)
create_leaflet_map(lowest_100, params$added_feature_shap, "Lowest 100 SHAPs", order_scheme = "low")
create_leaflet_map(lowest_100, "shap_total", "Lowest 100 SHAPs", order_scheme = "low")
```

:::

## Largest FMV Changes

Multicard parcels have heuristic which limits their change. The added feature may trigger (or not trigger it), leading to changes much larger than the added feature's impact.
Multicard parcels have heuristic which limits their change. The added feature may trigger (or not trigger it), leading to changes much larger than the added feature's impact.

::: panel-tabset

### 100 Largest FMV Increases

```{r}
largest_fmv_increases <- working_data_pin %>%
largest_fmv_increases <- leaflet_data %>%
arrange(desc(diff_pred_pin_final_fmv)) %>%
slice(1:100)
# Call the function with the pre-sliced dataset
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_final_fmv", "Largest FMV Increases")
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_final_fmv", "Largest FMV Increases (%)")
```

### 100 Largest FMV Decreases

Multicard parcels have heuristic which limits their change. The added feature may trigger (or not trigger it), leading to changes much larger than the added feature's impact.
Multicard parcels have heuristic which limits their change. The added feature may trigger (or not trigger it), leading to changes much larger than the added feature's impact.

```{r}
largest_fmv_decreases <- working_data_pin %>%
largest_fmv_decreases <- leaflet_data %>%
arrange(diff_pred_pin_final_fmv) %>%
slice(1:100)
create_leaflet_map(largest_fmv_decreases, "diff_pred_pin_final_fmv", "Largest FMV Decreases", order_scheme = "low")
create_leaflet_map(largest_fmv_decreases, "diff_pred_pin_final_fmv", "Largest FMV Decreases (%)", order_scheme = "low")
```

### 100 Largest FMV Initial Increases

```{r}
largest_fmv_increases <- working_data_card %>%
largest_fmv_increases <- leaflet_data %>%
arrange(desc(diff_pred_pin_initial_fmv)) %>%
slice(1:100)
# Call the function with the pre-sliced dataset
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_initial_fmv", "Largest FMV Increases")
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_initial_fmv", "Largest FMV Increases (%)")
```


### 100 Largest Initial FMV Decreases

```{r}
largest_fmv_decreases <- working_data_pin %>%
largest_fmv_decreases <- leaflet_data %>%
arrange(diff_pred_pin_initial_fmv) %>%
slice(1:100)
create_leaflet_map(largest_fmv_decreases, "diff_pred_pin_initial_fmv", "Largest FMV Decreases", order_scheme = "low")
create_leaflet_map(largest_fmv_decreases, "diff_pred_pin_initial_fmv", "Largest FMV Decreases (%)", order_scheme = "low")
```

## Largest FMV Increases no Multicards

```{r}
largest_fmv_increases <- working_data_card %>%
largest_fmv_increases <- leaflet_data %>%
group_by(meta_pin) %>%
filter(n() == 1) %>%
ungroup() %>%
Expand All @@ -1538,21 +1543,19 @@ largest_fmv_increases <- working_data_card %>%
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_final_fmv", "Largest FMV Increases")
```

## Largest FMV Decreases no Multicards

```{r}
largest_fmv_decreases <- working_data_card %>%
largest_fmv_decreases <- leaflet_data %>%
group_by(meta_pin) %>%
filter(n() == 1) %>%
ungroup() %>%
arrange(diff_pred_pin_initial_fmv) %>%
slice(1:100)
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_final_fmv", "Largest FMV Increases", order_scheme = "low")
create_leaflet_map(largest_fmv_increases, "diff_pred_pin_final_fmv", "Largest FMV Increases (%)", order_scheme = "low")
```



:::

## Neighborhoods with the Highest and Lowest SHAP Values
Expand All @@ -1561,9 +1564,9 @@ These maps identify neighborhoods where the added feature is having the largest

::: panel-tabset
```{r processing_SHAP_values}
selected_data <- working_data_card %>%
selected_data <- leaflet_data %>%
group_by(meta_nbhd_code) %>%
mutate(mean_value = mean(abs(!!sym(paste0(params$added_feature_shap))), na.rm = TRUE)) %>%
mutate(mean_value = mean(abs(shap_total)), na.rm = TRUE) %>%
ungroup() %>%
distinct(meta_nbhd_code, .keep_all = TRUE) %>%
arrange(mean_value)
Expand All @@ -1574,8 +1577,7 @@ selected_nbhd_codes <- selected_data %>%
pull(meta_nbhd_code)
# Filter working_data_card for these neighborhoods
filtered_data <- filter(working_data_card, meta_nbhd_code %in% selected_nbhd_codes)
filtered_data <- filter(leaflet_data, meta_nbhd_code %in% selected_nbhd_codes)
# Separate high and low mean value neighborhoods
Expand All @@ -1586,20 +1588,15 @@ low_mean_data <- filtered_data %>%
filter(meta_nbhd_code %in% selected_nbhd_codes[1:2])
```


### 2 Highest SHAP Neighborhoods

```{r}
create_leaflet_map(high_mean_data, params$added_feature_shap, "SHAP Values")
create_leaflet_map(high_mean_data, "shap_total", "SHAP Values")
```
### 2 Lowest SHAP Neighborhoods

### 2 Lowest SHAP Neighborhoods

```{r}
create_leaflet_map(low_mean_data, params$added_feature_shap, "SHAP Values")
create_leaflet_map(low_mean_data, "shap_total", "SHAP Values")
```

:::



0 comments on commit f352ab3

Please sign in to comment.