Removed yieldprediction from CI_report_dashboard_planet.Rmd edited online with Bitbucket
This commit is contained in:
Martin Folkerts
parent
fb2e94c52a
commit
eb9803fbf1
|
|
@ -274,104 +274,4 @@ print(" PRINT")
|
||||||
# cat("\n")
|
# cat("\n")
|
||||||
})
|
})
|
||||||
}
|
}
|
||||||
```
|
```
|
||||||
|
|
||||||
# Yield prediction
|
|
||||||
The below table shows estimates of the biomass if you would harvest them now.
|
|
||||||
|
|
||||||
```{r message=FALSE, warning=FALSE, include=FALSE}
|
|
||||||
|
|
||||||
#CI_quadrant <- readRDS(here(cumulative_CI_vals_dir,"All_pivots_Cumulative_CI_quadrant_year_v2.rds"))
|
|
||||||
CI_quadrant <- readRDS(here(cumulative_CI_vals_dir,"All_pivots_Cumulative_CI_quadrant_year_v2.rds")) %>%
|
|
||||||
group_by(model) %>% # Group by model or other relevant columns
|
|
||||||
fill(field, sub_field, .direction = "downup") %>% # Fill down then up within each group
|
|
||||||
ungroup()
|
|
||||||
if (all(is.na(CI_quadrant$tonnage_ha))) {
|
|
||||||
log_message("Lacking historic harvest data, please provide for yield prediction calculation")
|
|
||||||
knitr::knit_exit() # Exit the chunk if tonnage_ha is empty
|
|
||||||
}
|
|
||||||
|
|
||||||
harvesting_data <- harvesting_data %>% rename(season = year)
|
|
||||||
|
|
||||||
CI_and_yield <- left_join(CI_quadrant , harvesting_data, by = c("field", "sub_field", "season")) %>% #filter(!is.na(tonnage_ha)) %>%
|
|
||||||
group_by(sub_field, season) %>% slice(which.max(DOY)) %>%
|
|
||||||
dplyr::select(field, sub_field, tonnage_ha, cumulative_CI, DOY, season, sub_area) %>%
|
|
||||||
mutate(CI_per_day = cumulative_CI/ DOY)
|
|
||||||
|
|
||||||
predictors <- c( "cumulative_CI" , "DOY" ,"CI_per_day" )
|
|
||||||
response <- "tonnage_ha"
|
|
||||||
# CI_and_yield_test <- as.data.frame(CI_and_yield_test)
|
|
||||||
CI_and_yield_test <- CI_and_yield %>% as.data.frame() %>% filter(!is.na(tonnage_ha))
|
|
||||||
CI_and_yield_validation <- CI_and_yield_test
|
|
||||||
prediction_yields <- CI_and_yield %>% as.data.frame() %>% filter(is.na(tonnage_ha))
|
|
||||||
|
|
||||||
ctrl <- trainControl(method="cv",
|
|
||||||
savePredictions = TRUE,
|
|
||||||
allowParallel= TRUE,
|
|
||||||
number = 5,
|
|
||||||
verboseIter = TRUE)
|
|
||||||
|
|
||||||
set.seed(202)
|
|
||||||
model_ffs_rf <- ffs( CI_and_yield_test[,predictors],
|
|
||||||
CI_and_yield_test[,response],
|
|
||||||
method="rf" ,
|
|
||||||
trControl=ctrl,
|
|
||||||
importance=TRUE,
|
|
||||||
withinSE = TRUE,
|
|
||||||
tuneLength = 5,
|
|
||||||
na.rm = TRUE
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
# Function to prepare predictions
|
|
||||||
prepare_predictions <- function(predictions, newdata) {
|
|
||||||
return(predictions %>%
|
|
||||||
as.data.frame() %>%
|
|
||||||
rename(predicted_Tcha = ".") %>%
|
|
||||||
mutate(sub_field = newdata$sub_field,
|
|
||||||
field = newdata$field,
|
|
||||||
Age_days = newdata$DOY,
|
|
||||||
total_CI = round(newdata$cumulative_CI, 0),
|
|
||||||
predicted_Tcha = round(predicted_Tcha, 0),
|
|
||||||
season = newdata$season) %>%
|
|
||||||
dplyr::select(field, sub_field, Age_days, total_CI, predicted_Tcha, season) %>%
|
|
||||||
left_join(., newdata, by = c("field", "sub_field", "season")))
|
|
||||||
}
|
|
||||||
# Predict yields for the validation dataset
|
|
||||||
pred_ffs_rf <- prepare_predictions(predict(model_ffs_rf, newdata = CI_and_yield_validation), CI_and_yield_validation)
|
|
||||||
|
|
||||||
# Predict yields for the current season
|
|
||||||
pred_rf_current_season <- prepare_predictions(predict(model_ffs_rf, newdata = prediction_yields), prediction_yields) %>%
|
|
||||||
filter(Age_days > 300) %>%
|
|
||||||
mutate(CI_per_day = round(total_CI / Age_days, 1))
|
|
||||||
```
|
|
||||||
|
|
||||||
```{r yield_plaatjes, echo=FALSE }
|
|
||||||
if (all(is.na(CI_quadrant$tonnage_ha))) {
|
|
||||||
log_message("Lacking historic harvest data, please provide for yield prediction calculation")
|
|
||||||
knitr::knit_exit() # Exit the chunk if tonnage_ha is empty
|
|
||||||
}
|
|
||||||
ggplot(pred_ffs_rf, aes(y = predicted_Tcha, x = tonnage_ha)) +
|
|
||||||
geom_point(size = 2, alpha = 0.6) + # Adjust point size and transparency
|
|
||||||
geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "red") + # Reference line
|
|
||||||
scale_x_continuous(limits = c(0, 200)) +
|
|
||||||
scale_y_continuous(limits = c(0, 200)) +
|
|
||||||
labs(title = "Model Performance: \nPredicted vs Actual Tonnage/ha",
|
|
||||||
x = "Actual tonnage/ha (Tcha)",
|
|
||||||
y = "Predicted tonnage/ha (Tcha)") +
|
|
||||||
theme_minimal()
|
|
||||||
|
|
||||||
ggplot(pred_rf_current_season, aes(x = Age_days, y = predicted_Tcha)) +
|
|
||||||
geom_point(size = 2, alpha = 0.6) + # Adjust point size and transparency
|
|
||||||
labs(title = "Predicted Yields for Fields Over 300 Days \nOld Yet to Be Harvested",
|
|
||||||
x = "Age (days)",
|
|
||||||
y = "Predicted tonnage/ha (Tcha)") +
|
|
||||||
# facet_wrap(~sub_area) +
|
|
||||||
scale_y_continuous(limits = c(0, 200)) + # Optional: Set limits for y-axis
|
|
||||||
theme_minimal()
|
|
||||||
|
|
||||||
knitr::kable(pred_rf_current_season,
|
|
||||||
digits = 0,
|
|
||||||
caption = "Predicted Tonnage/ha for Fields Over 300 Days Old")
|
|
||||||
```
|
|
||||||
|
|
||||||
Loading…
Reference in a new issue