This is an R Markdown Notebook. When you execute code within the notebook, the results appear beneath the code.

Try executing this chunk by clicking the Run button within the chunk or by placing your cursor inside it and pressing Cmd+Shift+Enter.

Warning message:
In do_once((if (is_R_CMD_check()) stop else warning)("The function xfun::isFALSE() will be deprecated in the future. Please ",  :
  The function xfun::isFALSE() will be deprecated in the future. Please consider using base::isFALSE(x) or identical(x, FALSE) instead.
###### Loading and making first layers ####
library(readxl)
library(caret)
library(randomForest)
library(raster)
library(openxlsx)
library(Metrics)
library(rgdal)
library(dplyr)

## Using the data to calculate the NDVI index
####

gedi_file <- "GEDI_2021.shp"
tiff_file <- "S2_1764_2021_allbands.tiff"

#performRegression <- function(gedi_file, tiff_file, bands) {
# Read GEDI data
GEDI_data <- readOGR(gedi_file)
OGR data source with driver: ESRI Shapefile 
Source: "/Users/yayayapoop/Library/CloudStorage/OneDrive-TheUniversityofNottingham/Mres - Onedrive/15 04 23 - Sujit Earth engine shape file- WD/Working Folder/23 06 23 - Working Folder/GEDI_2021.shp", layer: "GEDI_2021"
with 174 features
It has 3 fields
# Read TIFF image data
img_data <- stack(tiff_file)
bands <- rh98~.

GEDI_data <- spTransform(GEDI_data, CRS(projection(img_data)))

# Extract image values at plot locations
img_val <- extract(img_data, GEDI_data, fun = mean, na.rm = TRUE)
#img_val <- extract(img_data, GEDI_data)#, fun = mean, na.rm = TRUE)
ht_data <- as.data.frame(cbind(GEDI_data, img_val))

# Remove the last two columns of coordinates
htData <- ht_data[, -c((ncol(ht_data) - 1):ncol(ht_data))]

# Select only one height data (e.g., rh98) and image data columns
htData <- select(htData, rh98, colnames(img_val))

# Assuming htData contains the necessary columns (Red and NIR bands)
# htData$NDVI <- (htData$NIR - htData$Red) / (htData$NIR + htData$Red)

# Assuming htData contains the necessary columns (Red and NIR bands)
htData$NDVI <- (htData$B8 - htData$B4) / (htData$B8 + htData$B4)

## NDVI can be tddhought of as the difference between the NIR 
## and Red because it would correspond to more water so makes more sense. 
### HtData in the stuff. 

mean_y <- mean(htData[, 1])
sd_y <- sd(htData[, 1])

# Set a threshold for outlier detection (e.g., 3 times the standard deviation)
threshold <- 0.5 * sd_y

# Identify the indices of the anomalous points
anomalous_indices <- which(abs(htData[, 1] - mean_y) > threshold)

# Remove the anomalous points from the data frame
clean_frac <- htData[-anomalous_indices, ]

frac <- createDataPartition(clean_frac$rh98, p = .65, list = FALSE, group = 10)

## New variable weight

# Histogram of densities RH98
ggplot(clean_frac, aes(x = rh98)) +
  geom_density()


d <- density(clean_frac$rh98)
plot(d, main="Kernel Density 98th Relative Height Metric")
polygon(d, col="red", border="blue")


hist(htData$rh98)


#### The distribution of the various bands 
library(ggplot2)

ggplot(clean_frac) +
  #geom_density(aes(x = rh98), color = "blue", fill = "lightblue", alpha = 0.5, show.legend = TRUE) +
  geom_density(aes(x = B7), color = "red", fill = "red", alpha = 0.5, show.legend = TRUE) +
  geom_density(aes(x = NDVI), color = "green", fill = "green", alpha = 0.5, show.legend = TRUE) +
  geom_density(aes(x = B9), color = "blue", fill = "blue", alpha = 0.5, show.legend = TRUE) +
  geom_density(aes(x = B8), color = "blue", fill = "blue", alpha = 0.5, show.legend = TRUE) +
  xlab("Variable") +
  ylab("Density") +
  ggtitle("Kernel Density Plots") +
  theme_minimal()


# Testing and training split. 
training <- htData[frac, ]
testing <- htData[-frac, ]

# Regression modeling
fitControl <- trainControl(method = "cv", number = 5, savePredictions = TRUE)
rfGrid <- expand.grid(mtry = c(1:6))

set.seed(1)
rfFit1 <- train(
  bands,
  data = training,
  method = "rf",
  trControl = fitControl,
  verbose = FALSE,
  importance = TRUE,
  tuneGrid = rfGrid
)

# Plot variable importance
rfImp <- varImp(rfFit1, scale = FALSE)
plot(rfImp, main = "Variable Importance")


# Evaluate model performance
predictedHt <- predict(rfFit1, testing[-1])
correlation <- cor(predictedHt, testing[, 1])^2
rmse <- sqrt(mean((predictedHt - testing[, 1])^2))

# Plot predicted vs actual heights
plot(testing[, 1], predictedHt, pch = 16, cex.axis = 1.5, cex.lab = 1.5, col = "blue",
     main = "GEDI vs Model Predicted Height\n RF Regression\n",
     xlim = c(0, 15), ylim = c(0, 15), xlab = "GEDI height (m)", ylab = "Model height (m)")
abline(1.123e-15, 1)


# Print RMSE
print(paste("rmse: ",rmse))
[1] "rmse:  2.39140650554688"
print(paste("R2: ",correlation))
[1] "R2:  0.229308776314909"
# Access the p-value
cor_test <- cor.test(testing[, 1], predictedHt)
p_value <- cor_test$p.value

# print(paste("Correlation test: ",cor_test))
# Check the statistical significance at a significance level (e.g., alpha = 0.05)

if (p_value < 0.05) {
  print(paste("The correlation is statistically significant since p-value ", p_value, "is less than 0.05."))
} else {
  print(paste("The correlation is not statistically significant p-value =", p_value))
}
[1] "The correlation is statistically significant since p-value  1.38682601109052e-05 is less than 0.05."
### Finding which of the Bands has the highest importance score
rfImp <- varImp(rfFit1, scale = FALSE)
plot(rfImp, main = "Variable Importance")

NA
NA

Add a new chunk by clicking the Insert Chunk button on the toolbar or by pressing Cmd+Option+I.

When you save the notebook, an HTML file containing the code and output will be saved alongside it (click the Preview button or press Cmd+Shift+K to preview the HTML file).

The preview shows you a rendered HTML copy of the contents of the editor. Consequently, unlike Knit, Preview does not run any R code chunks. Instead, the output of the chunk when it was last run in the editor is displayed.

LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKVGhpcyBpcyBhbiBbUiBNYXJrZG93bl0oaHR0cDovL3JtYXJrZG93bi5yc3R1ZGlvLmNvbSkgTm90ZWJvb2suIFdoZW4geW91IGV4ZWN1dGUgY29kZSB3aXRoaW4gdGhlIG5vdGVib29rLCB0aGUgcmVzdWx0cyBhcHBlYXIgYmVuZWF0aCB0aGUgY29kZS4KClRyeSBleGVjdXRpbmcgdGhpcyBjaHVuayBieSBjbGlja2luZyB0aGUgKlJ1biogYnV0dG9uIHdpdGhpbiB0aGUgY2h1bmsgb3IgYnkgcGxhY2luZyB5b3VyIGN1cnNvciBpbnNpZGUgaXQgYW5kIHByZXNzaW5nICpDbWQrU2hpZnQrRW50ZXIqLgoKYGBge3IgTG9hZGluZywgd2FybmluZz1GQUxTRX0KCiMjIyMjIyBMb2FkaW5nIGFuZCBtYWtpbmcgZmlyc3QgbGF5ZXJzICMjIyMKbGlicmFyeShyZWFkeGwpCmxpYnJhcnkoY2FyZXQpCmxpYnJhcnkocmFuZG9tRm9yZXN0KQpsaWJyYXJ5KHJhc3RlcikKbGlicmFyeShvcGVueGxzeCkKbGlicmFyeShNZXRyaWNzKQpsaWJyYXJ5KHJnZGFsKQpsaWJyYXJ5KGRwbHlyKQoKIyMgVXNpbmcgdGhlIGRhdGEgdG8gY2FsY3VsYXRlIHRoZSBORFZJIGluZGV4CiMjIyMKCmdlZGlfZmlsZSA8LSAiR0VESV8yMDIxLnNocCIKdGlmZl9maWxlIDwtICJTMl8xNzY0XzIwMjFfYWxsYmFuZHMudGlmZiIKCiNwZXJmb3JtUmVncmVzc2lvbiA8LSBmdW5jdGlvbihnZWRpX2ZpbGUsIHRpZmZfZmlsZSwgYmFuZHMpIHsKIyBSZWFkIEdFREkgZGF0YQpHRURJX2RhdGEgPC0gcmVhZE9HUihnZWRpX2ZpbGUpCgoKIyBSZWFkIFRJRkYgaW1hZ2UgZGF0YQppbWdfZGF0YSA8LSBzdGFjayh0aWZmX2ZpbGUpCmJhbmRzIDwtIHJoOTh+LgoKR0VESV9kYXRhIDwtIHNwVHJhbnNmb3JtKEdFRElfZGF0YSwgQ1JTKHByb2plY3Rpb24oaW1nX2RhdGEpKSkKCiMgRXh0cmFjdCBpbWFnZSB2YWx1ZXMgYXQgcGxvdCBsb2NhdGlvbnMKaW1nX3ZhbCA8LSBleHRyYWN0KGltZ19kYXRhLCBHRURJX2RhdGEsIGZ1biA9IG1lYW4sIG5hLnJtID0gVFJVRSkKI2ltZ192YWwgPC0gZXh0cmFjdChpbWdfZGF0YSwgR0VESV9kYXRhKSMsIGZ1biA9IG1lYW4sIG5hLnJtID0gVFJVRSkKaHRfZGF0YSA8LSBhcy5kYXRhLmZyYW1lKGNiaW5kKEdFRElfZGF0YSwgaW1nX3ZhbCkpCgojIFJlbW92ZSB0aGUgbGFzdCB0d28gY29sdW1ucyBvZiBjb29yZGluYXRlcwpodERhdGEgPC0gaHRfZGF0YVssIC1jKChuY29sKGh0X2RhdGEpIC0gMSk6bmNvbChodF9kYXRhKSldCgojIFNlbGVjdCBvbmx5IG9uZSBoZWlnaHQgZGF0YSAoZS5nLiwgcmg5OCkgYW5kIGltYWdlIGRhdGEgY29sdW1ucwpodERhdGEgPC0gc2VsZWN0KGh0RGF0YSwgcmg5OCwgY29sbmFtZXMoaW1nX3ZhbCkpCgojIEFzc3VtaW5nIGh0RGF0YSBjb250YWlucyB0aGUgbmVjZXNzYXJ5IGNvbHVtbnMgKFJlZCBhbmQgTklSIGJhbmRzKQojIGh0RGF0YSRORFZJIDwtIChodERhdGEkTklSIC0gaHREYXRhJFJlZCkgLyAoaHREYXRhJE5JUiArIGh0RGF0YSRSZWQpCgojIEFzc3VtaW5nIGh0RGF0YSBjb250YWlucyB0aGUgbmVjZXNzYXJ5IGNvbHVtbnMgKFJlZCBhbmQgTklSIGJhbmRzKQpodERhdGEkTkRWSSA8LSAoaHREYXRhJEI4IC0gaHREYXRhJEI0KSAvIChodERhdGEkQjggKyBodERhdGEkQjQpCgojIyBORFZJIGNhbiBiZSB0ZGRob3VnaHQgb2YgYXMgdGhlIGRpZmZlcmVuY2UgYmV0d2VlbiB0aGUgTklSIAojIyBhbmQgUmVkIGJlY2F1c2UgaXQgd291bGQgY29ycmVzcG9uZCB0byBtb3JlIHdhdGVyIHNvIG1ha2VzIG1vcmUgc2Vuc2UuIAojIyMgSHREYXRhIGluIHRoZSBzdHVmZi4gCgptZWFuX3kgPC0gbWVhbihodERhdGFbLCAxXSkKc2RfeSA8LSBzZChodERhdGFbLCAxXSkKCiMgU2V0IGEgdGhyZXNob2xkIGZvciBvdXRsaWVyIGRldGVjdGlvbiAoZS5nLiwgMyB0aW1lcyB0aGUgc3RhbmRhcmQgZGV2aWF0aW9uKQp0aHJlc2hvbGQgPC0gMC41ICogc2RfeQoKIyBJZGVudGlmeSB0aGUgaW5kaWNlcyBvZiB0aGUgYW5vbWFsb3VzIHBvaW50cwphbm9tYWxvdXNfaW5kaWNlcyA8LSB3aGljaChhYnMoaHREYXRhWywgMV0gLSBtZWFuX3kpID4gdGhyZXNob2xkKQoKIyBSZW1vdmUgdGhlIGFub21hbG91cyBwb2ludHMgZnJvbSB0aGUgZGF0YSBmcmFtZQpjbGVhbl9mcmFjIDwtIGh0RGF0YVstYW5vbWFsb3VzX2luZGljZXMsIF0KCmZyYWMgPC0gY3JlYXRlRGF0YVBhcnRpdGlvbihjbGVhbl9mcmFjJHJoOTgsIHAgPSAuNjUsIGxpc3QgPSBGQUxTRSwgZ3JvdXAgPSAxMCkKCiMjIE5ldyB2YXJpYWJsZSB3ZWlnaHQKCiMgSGlzdG9ncmFtIG9mIGRlbnNpdGllcyBSSDk4CmdncGxvdChjbGVhbl9mcmFjLCBhZXMoeCA9IHJoOTgpKSArCiAgZ2VvbV9kZW5zaXR5KCkKCmQgPC0gZGVuc2l0eShjbGVhbl9mcmFjJHJoOTgpCnBsb3QoZCwgbWFpbj0iS2VybmVsIERlbnNpdHkgOTh0aCBSZWxhdGl2ZSBIZWlnaHQgTWV0cmljIikKcG9seWdvbihkLCBjb2w9InJlZCIsIGJvcmRlcj0iYmx1ZSIpCgpoaXN0KGh0RGF0YSRyaDk4KQoKIyMjIyBUaGUgZGlzdHJpYnV0aW9uIG9mIHRoZSB2YXJpb3VzIGJhbmRzIApsaWJyYXJ5KGdncGxvdDIpCgpnZ3Bsb3QoY2xlYW5fZnJhYykgKwogICNnZW9tX2RlbnNpdHkoYWVzKHggPSByaDk4KSwgY29sb3IgPSAiYmx1ZSIsIGZpbGwgPSAibGlnaHRibHVlIiwgYWxwaGEgPSAwLjUsIHNob3cubGVnZW5kID0gVFJVRSkgKwogIGdlb21fZGVuc2l0eShhZXMoeCA9IEI3KSwgY29sb3IgPSAicmVkIiwgZmlsbCA9ICJyZWQiLCBhbHBoYSA9IDAuNSwgc2hvdy5sZWdlbmQgPSBUUlVFKSArCiAgZ2VvbV9kZW5zaXR5KGFlcyh4ID0gTkRWSSksIGNvbG9yID0gImdyZWVuIiwgZmlsbCA9ICJncmVlbiIsIGFscGhhID0gMC41LCBzaG93LmxlZ2VuZCA9IFRSVUUpICsKICBnZW9tX2RlbnNpdHkoYWVzKHggPSBCOSksIGNvbG9yID0gImJsdWUiLCBmaWxsID0gImJsdWUiLCBhbHBoYSA9IDAuNSwgc2hvdy5sZWdlbmQgPSBUUlVFKSArCiAgZ2VvbV9kZW5zaXR5KGFlcyh4ID0gQjgpLCBjb2xvciA9ICJibHVlIiwgZmlsbCA9ICJibHVlIiwgYWxwaGEgPSAwLjUsIHNob3cubGVnZW5kID0gVFJVRSkgKwogIHhsYWIoIlZhcmlhYmxlIikgKwogIHlsYWIoIkRlbnNpdHkiKSArCiAgZ2d0aXRsZSgiS2VybmVsIERlbnNpdHkgUGxvdHMiKSArCiAgdGhlbWVfbWluaW1hbCgpCgojIFRlc3RpbmcgYW5kIHRyYWluaW5nIHNwbGl0LiAKdHJhaW5pbmcgPC0gaHREYXRhW2ZyYWMsIF0KdGVzdGluZyA8LSBodERhdGFbLWZyYWMsIF0KCiMgUmVncmVzc2lvbiBtb2RlbGluZwpmaXRDb250cm9sIDwtIHRyYWluQ29udHJvbChtZXRob2QgPSAiY3YiLCBudW1iZXIgPSA1LCBzYXZlUHJlZGljdGlvbnMgPSBUUlVFKQpyZkdyaWQgPC0gZXhwYW5kLmdyaWQobXRyeSA9IGMoMTo2KSkKCnNldC5zZWVkKDEpCnJmRml0MSA8LSB0cmFpbigKICBiYW5kcywKICBkYXRhID0gdHJhaW5pbmcsCiAgbWV0aG9kID0gInJmIiwKICB0ckNvbnRyb2wgPSBmaXRDb250cm9sLAogIHZlcmJvc2UgPSBGQUxTRSwKICBpbXBvcnRhbmNlID0gVFJVRSwKICB0dW5lR3JpZCA9IHJmR3JpZAopCgojIFBsb3QgdmFyaWFibGUgaW1wb3J0YW5jZQpyZkltcCA8LSB2YXJJbXAocmZGaXQxLCBzY2FsZSA9IEZBTFNFKQpwbG90KHJmSW1wLCBtYWluID0gIlZhcmlhYmxlIEltcG9ydGFuY2UiKQoKIyBFdmFsdWF0ZSBtb2RlbCBwZXJmb3JtYW5jZQpwcmVkaWN0ZWRIdCA8LSBwcmVkaWN0KHJmRml0MSwgdGVzdGluZ1stMV0pCmNvcnJlbGF0aW9uIDwtIGNvcihwcmVkaWN0ZWRIdCwgdGVzdGluZ1ssIDFdKV4yCnJtc2UgPC0gc3FydChtZWFuKChwcmVkaWN0ZWRIdCAtIHRlc3RpbmdbLCAxXSleMikpCgojIFBsb3QgcHJlZGljdGVkIHZzIGFjdHVhbCBoZWlnaHRzCnBsb3QodGVzdGluZ1ssIDFdLCBwcmVkaWN0ZWRIdCwgcGNoID0gMTYsIGNleC5heGlzID0gMS41LCBjZXgubGFiID0gMS41LCBjb2wgPSAiYmx1ZSIsCiAgICAgbWFpbiA9ICJHRURJIHZzIE1vZGVsIFByZWRpY3RlZCBIZWlnaHRcbiBSRiBSZWdyZXNzaW9uXG4iLAogICAgIHhsaW0gPSBjKDAsIDE1KSwgeWxpbSA9IGMoMCwgMTUpLCB4bGFiID0gIkdFREkgaGVpZ2h0IChtKSIsIHlsYWIgPSAiTW9kZWwgaGVpZ2h0IChtKSIpCmFibGluZSgxLjEyM2UtMTUsIDEpCgojIFByaW50IFJNU0UKcHJpbnQocGFzdGUoInJtc2U6ICIscm1zZSkpCnByaW50KHBhc3RlKCJSMjogIixjb3JyZWxhdGlvbikpCiMgQWNjZXNzIHRoZSBwLXZhbHVlCmNvcl90ZXN0IDwtIGNvci50ZXN0KHRlc3RpbmdbLCAxXSwgcHJlZGljdGVkSHQpCnBfdmFsdWUgPC0gY29yX3Rlc3QkcC52YWx1ZQoKIyBwcmludChwYXN0ZSgiQ29ycmVsYXRpb24gdGVzdDogIixjb3JfdGVzdCkpCiMgQ2hlY2sgdGhlIHN0YXRpc3RpY2FsIHNpZ25pZmljYW5jZSBhdCBhIHNpZ25pZmljYW5jZSBsZXZlbCAoZS5nLiwgYWxwaGEgPSAwLjA1KQoKaWYgKHBfdmFsdWUgPCAwLjA1KSB7CiAgcHJpbnQocGFzdGUoIlRoZSBjb3JyZWxhdGlvbiBpcyBzdGF0aXN0aWNhbGx5IHNpZ25pZmljYW50IHNpbmNlIHAtdmFsdWUgIiwgcF92YWx1ZSwgImlzIGxlc3MgdGhhbiAwLjA1LiIpKQp9IGVsc2UgewogIHByaW50KHBhc3RlKCJUaGUgY29ycmVsYXRpb24gaXMgbm90IHN0YXRpc3RpY2FsbHkgc2lnbmlmaWNhbnQgcC12YWx1ZSA9IiwgcF92YWx1ZSkpCn0KCiMjIyBGaW5kaW5nIHdoaWNoIG9mIHRoZSBCYW5kcyBoYXMgdGhlIGhpZ2hlc3QgaW1wb3J0YW5jZSBzY29yZQpyZkltcCA8LSB2YXJJbXAocmZGaXQxLCBzY2FsZSA9IEZBTFNFKQpwbG90KHJmSW1wLCBtYWluID0gIlZhcmlhYmxlIEltcG9ydGFuY2UiKQoKCmBgYAoKQWRkIGEgbmV3IGNodW5rIGJ5IGNsaWNraW5nIHRoZSAqSW5zZXJ0IENodW5rKiBidXR0b24gb24gdGhlIHRvb2xiYXIgb3IgYnkgcHJlc3NpbmcgKkNtZCtPcHRpb24rSSouCgpXaGVuIHlvdSBzYXZlIHRoZSBub3RlYm9vaywgYW4gSFRNTCBmaWxlIGNvbnRhaW5pbmcgdGhlIGNvZGUgYW5kIG91dHB1dCB3aWxsIGJlIHNhdmVkIGFsb25nc2lkZSBpdCAoY2xpY2sgdGhlICpQcmV2aWV3KiBidXR0b24gb3IgcHJlc3MgKkNtZCtTaGlmdCtLKiB0byBwcmV2aWV3IHRoZSBIVE1MIGZpbGUpLgoKVGhlIHByZXZpZXcgc2hvd3MgeW91IGEgcmVuZGVyZWQgSFRNTCBjb3B5IG9mIHRoZSBjb250ZW50cyBvZiB0aGUgZWRpdG9yLiBDb25zZXF1ZW50bHksIHVubGlrZSAqS25pdCosICpQcmV2aWV3KiBkb2VzIG5vdCBydW4gYW55IFIgY29kZSBjaHVua3MuIEluc3RlYWQsIHRoZSBvdXRwdXQgb2YgdGhlIGNodW5rIHdoZW4gaXQgd2FzIGxhc3QgcnVuIGluIHRoZSBlZGl0b3IgaXMgZGlzcGxheWVkLgo=