From d5d43466b4b667311c0b172fb5e167602f8191f5 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 14 May 2025 16:45:03 -0700 Subject: [PATCH 01/13] update for public dataset --- trees/height-diameter/AUC.R | 1 + trees/height-diameter/THPL.R | 275 +++++----- trees/height-diameter/setup.R | 934 +++++++++++++++++++--------------- 3 files changed, 666 insertions(+), 544 deletions(-) diff --git a/trees/height-diameter/AUC.R b/trees/height-diameter/AUC.R index f2270ff..931960c 100644 --- a/trees/height-diameter/AUC.R +++ b/trees/height-diameter/AUC.R @@ -1,3 +1,4 @@ +#install packages library(dplyr) library(ggplot2) library(furrr) diff --git a/trees/height-diameter/THPL.R b/trees/height-diameter/THPL.R index 7cbcaa3..7dc63e2 100644 --- a/trees/height-diameter/THPL.R +++ b/trees/height-diameter/THPL.R @@ -1,11 +1,19 @@ # load libraries, functions, and trees2016 from Elliott Stand Data Feb2022.R + ## western redcedar height-diameter regression form sweep -#thplHeightFromDiameter$gamPhysio = gam(TotalHt ~ s(DBH, elevation, slope, sin(3.14159/180 * aspect), cos(3.14159/180 * aspect), topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 85, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, select = TRUE, weights = dbhWeight) # bs = "ts" -> 367, gamma = 2 -> 367, k = 169 min vs 367 default, method = "REML" -> 367 -#thplHeightFromDiameter$sharmaPartonBalPhysio = gsl_nls(TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^(a2 + a2p * isPlantation) * (1 + a3 * elevation + a4 * sin(3.14159/180 * aspect) + a5 * cos(3.14159/180 * aspect) + a6 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^(b2 + b2p * isPlantation)*DBH))^(b3 + b3p * isPlantation), thpl2016, start = list(a1 = 39.8, a1p = -12.3, a2 = 0.52, a2p = 0.0027, a3 = 0.00001, a4 = 0.0131, a5 = 0.0046, a6 = 0.0060, b1 = -0.0098, b1p = -0.0143, b2 = 0.125, b2p = -0.186, b3 = 1.12, b3p = 0.0086), weights = thplHeightFromDiameterWeights) -thpl2016 = trees2016 %>% filter(Species == "RC", isLiveUnbroken, is.na(TotalHt) == FALSE) %>% # live western redcedars measured for height + +#thpl HeightFromDiameter$gamPhysio = gam(TotalHt ~ s(DBH, elevation, slope, sin(3.14159/180 * aspect), cos(3.14159/180 * aspect), topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 85, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, select = TRUE, weights = dbhWeight) + +# bs= "ts" -> 367, gamma = 2 -> 367, k = 169 min vs 367 default, method = "REML" -> 367 + +#thpl HeightFromDiameter$sharmaPartonBalPhysio = gsl_nls(TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^(a2 + a2p * isPlantation) * (1 + a3 * elevation + a4 * sin(3.14159/180 * aspect) + a5 * cos(3.14159/180 * aspect) + a6 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^(b2 + b2p * isPlantation)*DBH))^(b3 + b3p * isPlantation), thpl2016, start = list(a1 = 39.8, a1p = -12.3, a2 = 0.52, a2p = 0.0027, a3 = 0.00001, a4 = 0.0131, a5 = 0.0046, a6 = 0.0060, b1 = -0.0098, b1p = -0.0143, b2 = 0.125, b2p = -0.186, b3 = 1.12, b3p = 0.0086), weights = thplHeightFromDiameterWeights) + +thpl2016 = trees2016 %>% + filter(Species == "THPL", isLiveUnbroken, is.na(TotalHt) == FALSE) %>% # live western redcedars measured for height mutate(dbhWeight = pmin(TreeCount/(0.14*DBH^1.20), 5*TreeCount), heightWeight = pmin(TreeCount/(2.29*(TotalHt - 1.37)^1.45), 5*TreeCount)) + # no trees without physiographic variables thpl2016gamConstraint = c(DBH = -1.2264/0.5099, TotalHt = 1.37, standBasalAreaPerHectare = median(thpl2016$standBasalAreaPerHectare), basalAreaLarger = median(thpl2016$basalAreaLarger), standBasalAreaApprox = median(thpl2016$standBasalAreaApprox), tallerApproxBasalArea = median(thpl2016$tallerApproxBasalArea), elevation = median(thpl2016$elevation), slope = median(thpl2016$slope), aspect = median(thpl2016$aspect), topographicShelterIndex = median(thpl2016$topographicShelterIndex), relativeHeight = median(thpl2016$relativeHeight), relativeDiameter = median(thpl2016$relativeDiameter)) # point constraint for mgcv::s() @@ -13,46 +21,56 @@ thpl2016defaultWeight = thpl2016 %>% mutate(dbhWeight = pmin(TreeCount/DBH, 5*Tr heightWeight = pmin(TreeCount/TotalHt, 5*TreeCount)) thpl2016defaultWeightPhysio = thpl2016defaultWeight %>% filter(is.na(elevation) == FALSE) -thplOptions = tibble(fitHeight = TRUE, - fitHeightNlrob = FALSE, - fitHeightGnls = FALSE, - fitHeightMixed = FALSE, - fitDbh = FALSE, - fitDbhNlrob = FALSE, - fitDbhMixed = FALSE) - -if (thplOptions$fitHeight) -{ - thplHeightFromDiameter = list(linear = fit_lm("linear", TotalHt ~ 0 + DBH, thpl2016)) # isPlantation*DBH not significant (p = 0.044) +# thplOptions = tibble(fitHeight = TRUE, +# fitHeightNlrob = FALSE, +# fitHeightGnls = FALSE, +# fitHeightMixed = FALSE, +# fitDbh = TRUE, +# fitDbhNlrob = FALSE, +# fitDbhMixed = FALSE) + +#make a tibble to store the parameters and later call them into the code +thplOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response + fitHeightNlrob = FALSE, #robust non-linear least square, height as response + fitHeightGnls = FALSE, #generalized least square, height as response + fitHeightMixed = FALSE, #non-linear mixed effects, height as response + fitDbh = TRUE, #non-linear least square, dbh as response + fitDbhNlrob = FALSE, #robust non-linear least square, dbh as response + fitDbhMixed = FALSE, #non-linear mixed effects, dbh as response + includeInvestigatory = TRUE #added investigatory plots, and figures of the results +) + +if (thplOptions$fitHeight) { #if the value in the column fitHeight of thplOptions table is TRUE execute the expression within the curly braces. + thplHeightFromDiameter = list(linear = fit_lm("linear", TotalHt ~ 0 + DBH, thpl2016)) # isPlantation*DBH not significant (p = 0.044) #creates output from the model fitting and validation 10*10=100 rows of all combination of folds and repetition and stores it as a list and adds all the following models in a similar fashion to the existing list (notice the $ sign in the code from the second line withing the curly braces) thplHeightFromDiameter$parabolic = fit_lm("parabolic", TotalHt ~ 0 + DBH + I(DBH^2), thpl2016) # isPlantation*DBH not quite significant (p = 0.106), isPlantation*DBH^2 not significant thplHeightFromDiameter$chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131)) # a1p, b1p, b2p not significant thplHeightFromDiameter$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) # a3, a3p, b1p, b2p not significant thplHeightFromDiameter$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) # a2, a3, a4, a5, a6, a7, a8p, b2p not significant - thplHeightFromDiameter$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 58, a1p = -16, a2 = 0, a2p = 0.4, a8 = 0.3, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) # a2, a10, a10p not significant + #thplHeightFromDiameter$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 58, a1p = -16, a2 = 0, a2p = 0.4, a8 = 0.3, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) # a2, a10, a10p not significant thplHeightFromDiameter$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.3, b1 = -0.012, b2 = 1.1), significant = FALSE) # a2, a10, a10p not significant - thplHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), thpl2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() + #thplHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), thpl2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() thplHeightFromDiameter$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) # a4, a5, a6, a7, a8p, b2p not significant thplHeightFromDiameter$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 72, a10 = -3.2, b1 = -0.012, b2 = 1.09)) # a10p not significant thplHeightFromDiameter$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) # a10, a10p not significant - thplHeightFromDiameter$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016, start = list(a1 = 0.560, b1 = 0.069)) # a1p, b1p not significant + #thplHeightFromDiameter$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016, start = list(a1 = 0.560, b1 = 0.069)) # a1p, b1p not significant thplHeightFromDiameter$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) # b2p not significant thplHeightFromDiameter$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), thpl2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) # a1p, b1p, b2p not significant thplHeightFromDiameter$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), thpl2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) # b1p not significant thplHeightFromDiameter$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) # a2p, a3p not significant thplHeightFromDiameter$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, thpl2016, start = list(a1 = 0.542, b1 = 0.939)) # a1p, b1p not significant - thplHeightFromDiameter$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) - thplHeightFromDiameter$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) # dp not significant, susceptible to NaN-inf + #thplHeightFromDiameter$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #thplHeightFromDiameter$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) # dp not significant, susceptible to NaN-inf thplHeightFromDiameter$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)) # a1p, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)) # a1p, b1p, b2p, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) # b1, b1p, a4, a5, a6, a7, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant - thplHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant + #thplHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant thplHeightFromDiameter$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) # a4, a5, a5, a6, a7, b1p, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 21, a10 = 0, b1 = 0.25, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = 0, b4 = 1.12), significant = FALSE) # a10, a10p not significant thplHeightFromDiameter$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 36, a8 = 0.18, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = -0.03, b4 = 1.09), significant = FALSE) # a1p, a10, a10p, b2p not significant - thplHeightFromDiameter$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) # b1, b1p, b2p, b3p not significant - thplHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant + #thplHeightFromDiameter$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) # b1, b1p, b2p, b3p not significant + #thplHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant thplHeightFromDiameter$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), thpl2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) # a1p, b1p, b2p not significant thplHeightFromDiameter$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) # b2p not significant thplHeightFromDiameter$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) # a1p, a2, a3, b1p, b2p not significant @@ -62,21 +80,21 @@ if (thplOptions$fitHeight) { thplHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) thplHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) - thplHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor - thplHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) - thplHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) - thplHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), thpl2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor + #thplHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + #thplHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) + #thplHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) + # thplHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), thpl2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor thplHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) thplHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) thplHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) - thplHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016, start = list(a1 = 0.560, b1 = 0.069)) - thplHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) - thplHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), thpl2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + #thplHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016, start = list(a1 = 0.560, b1 = 0.069)) + #thplHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + # thplHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), thpl2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) thplHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), thpl2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) - thplHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) - thplHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, thpl2016, start = list(a1 = 0.542, b1 = 0.939)) - thplHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) - thplHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor + #thplHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + #thplHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, thpl2016, start = list(a1 = 0.542, b1 = 0.939)) + #thplHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #thplHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor thplHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor thplHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor thplHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor @@ -84,18 +102,18 @@ if (thplOptions$fitHeight) thplHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor thplHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor thplHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) - thplHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) - thplHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant - thplHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor + #thplHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) + #thplHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant + #thplHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor thplHeightFromDiameterNlrob$sibbesen = fit_nlrob("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), thpl2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) - thplHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor - thplHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) - thplHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) - #lapply(thplHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) + #thplHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor + #thplHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + #thplHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + lapply(thplHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) } else { thplHeightFromDiameterNlrob = list() } - + #fitting models with defaultweight 'thpl2016defaultWeight' which were fitted earlier without any weights thplHeightFromDiameterGslNlsDefault = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, thpl2016defaultWeight, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) thplHeightFromDiameterGslNlsDefault$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, thpl2016defaultWeight, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) thplHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016defaultWeightPhysio, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) @@ -105,39 +123,39 @@ if (thplOptions$fitHeight) thplHeightFromDiameterGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016defaultWeightPhysio, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) thplHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016defaultWeight, start = list(a1 = 74, a10 = -3.2, b1 = -0.011, b2 = 1.09)) thplHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016defaultWeightPhysio, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) - thplHeightFromDiameterGslNlsDefault$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016defaultWeight, start = list(a1 = 0.560, b1 = 0.069)) + #thplHeightFromDiameterGslNlsDefault$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016defaultWeight, start = list(a1 = 0.560, b1 = 0.069)) thplHeightFromDiameterGslNlsDefault$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) thplHeightFromDiameterGslNlsDefault$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), thpl2016defaultWeight, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) thplHeightFromDiameterGslNlsDefault$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), thpl2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) thplHeightFromDiameterGslNlsDefault$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016defaultWeight, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) thplHeightFromDiameterGslNlsDefault$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, thpl2016defaultWeight, start = list(a1 = 0.542, b1 = 0.939)) - thplHeightFromDiameterGslNlsDefault$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016defaultWeight, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) - thplHeightFromDiameterGslNlsDefault$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016defaultWeight, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) + #thplHeightFromDiameterGslNlsDefault$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016defaultWeight, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #thplHeightFromDiameterGslNlsDefault$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016defaultWeight, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) thplHeightFromDiameterGslNlsDefault$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)) thplHeightFromDiameterGslNlsDefault$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 38, b1 = 0.12, b2 = -0.013, b3 = -0.1, b4 = 1.02)) thplHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016defaultWeightPhysio, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) thplHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016defaultWeightPhysio, start = list(a1 = 23, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.01, b2p = -0.010, b3 = -0.012, b4 = 1.14), significant = FALSE) - thplHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) + #thplHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) thplHeightFromDiameterGslNlsDefault$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016defaultWeightPhysio, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) thplHeightFromDiameterGslNlsDefault$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 19, a10 = -0.3, b1 = 0.29, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.03, b4 = 1.13), significant = FALSE) thplHeightFromDiameterGslNlsDefault$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016defaultWeightPhysio, start = list(a1 = 36, a8 = 0.18, a10 = 0, b1 = 0.2, b2 = -0.01, b3 = 0.03, b4 = 1.09), significant = FALSE) - thplHeightFromDiameterGslNlsDefault$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016defaultWeight, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) - thplHeightFromDiameterGslNlsDefault$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 53.2, a1p = -8.857, a2 = -0.002, a2p = 0.10, b1 = -0.016, b2 = -0.025, b3 = -0.078, b4 = 1.126)) + #thplHeightFromDiameterGslNlsDefault$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016defaultWeight, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) + #thplHeightFromDiameterGslNlsDefault$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016defaultWeight, start = list(a1 = 53.2, a1p = -8.857, a2 = -0.002, a2p = 0.10, b1 = -0.016, b2 = -0.025, b3 = -0.078, b4 = 1.126)) thplHeightFromDiameterGslNlsDefault$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), thpl2016defaultWeight, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) thplHeightFromDiameterGslNlsDefault$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) thplHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) thplHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + # + # thplHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + # thplHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + # thplHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # k reduces from 85 to 18 without aspect + # thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types - thplHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model - thplHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # k reduces from 85 to 18 without aspect - thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - - save(file = "trees/height-diameter/data/THPL TotalHt.Rdata", thplHeightFromDiameter, thplHeightFromDiameterNlrob, thplHeightFromDiameterGslNlsDefault) + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL TotalHt.Rdata", thplHeightFromDiameter, thplHeightFromDiameterNlrob, thplHeightFromDiameterGslNlsDefault) } if (htDiaOptions$includeInvestigatory) { @@ -189,20 +207,20 @@ if (htDiaOptions$includeInvestigatory) if (thplOptions$fitHeightGnls) { thplHeightFromDiameterGnls = list(chapmanRichards = fit_gnls("Chapman-Richards GNLS", TotalHt ~ 1.37 + a1*(1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), control = gnlsControl(nlsTol = 0.001))) # step halving at nlsTol = 1 with corSymm - thplHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, thpl2016, start = thplHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + #thplHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, thpl2016, start = thplHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm thplHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm thplHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation - thplHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = thplHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation + #thplHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = thplHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation thplHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation thplHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = thplHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped thplHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = thplHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm - - save(file = "trees/height-diameter/data/THPL TotalHt gnls.Rdata", thplHeightFromDiameterGnls) + + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL TotalHt gnls.Rdata", thplHeightFromDiameterGnls) } if (htDiaOptions$includeInvestigatory) { thplHeightFromDiameterResultsGnls %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic) %>% arrange(method) - + #bind_cols(parameter = c("a1", "a2", "a3", "b1", "b2"), bal = confint2(thplHeightFromDiameter$weibullBAL, level = 0.99), balN = confint2(thplHeightFromDiameter$weibullBalNatural, level = 0.99), balP = confint2(thplHeightFromDiameter$weibullBalPlantation, level = 0.99)) %>% # mutate(bal005 = bal[, 1], bal995 = bal[, 2], balN005 = balN[, 1], balN995 = balN[, 2], balP005 = balP[, 1], balP995 = balP[, 2]) %>% # select(-bal, -balN, -balP) @@ -211,7 +229,7 @@ if (htDiaOptions$includeInvestigatory) geom_smooth(aes(x = thpl2016natural$DBH, y = thpl2016natural$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + labs(x = "natural regeneration DBH, cm", y = "western redcedar naturally regenerated height, m") + - ggplot() + + ggplot() + geom_point(aes(x = thpl2016plantation$DBH, y = thpl2016plantation$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + geom_smooth(aes(x = thpl2016plantation$DBH, y = thpl2016plantation$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + @@ -231,8 +249,7 @@ if (htDiaOptions$includeInvestigatory) } -if (thplOptions$fitHeightMixed) -{ +if (thplOptions$fitHeightMixed){ #fitting height diameter using mixed effect models thplHeightFromDiameterMixed = list(chapmanRichards = fit_nlme("Chapman-Richards", TotalHt ~ 1.37 + (a1 + a1r)*(1 - exp(b1*DBH))^b2, thpl2016, fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 48.2, b1 = -0.015, b2 = 1.131)), control = nlmeControl(maxIter = 250))) @@ -244,9 +261,9 @@ if (thplOptions$fitHeightMixed) start = list(fixed = c(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12)), control = nlmeControl(maxIter = 250), significant = FALSE) thplHeightFromDiameterMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15))) - thplHeightFromDiameterMixed$curtis = fit_nlme("Curtis", TotalHt ~ 1.37 + (a1 + a1r) * DBH / (1 + DBH)^b1, thpl2016, - fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, - start = list(fixed = c(a1 = 0.560, b1 = 0.069)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # max iterations in job + # thplHeightFromDiameterMixed$curtis = fit_nlme("Curtis", TotalHt ~ 1.37 + (a1 + a1r) * DBH / (1 + DBH)^b1, thpl2016, + # fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 0.560, b1 = 0.069)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # max iterations in job thplHeightFromDiameterMixed$hossfeld = fit_nlme("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)), control = nlmeControl(maxIter = 250)) @@ -262,12 +279,12 @@ if (thplOptions$fitHeightMixed) thplHeightFromDiameterMixed$power = fit_nlme("power", TotalHt ~ 1.37 + (a1 + a1r)*DBH^b1, thpl2016, fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 0.542, b1 = 0.939)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) # job >500 iterations without relaxed tolerances - thplHeightFromDiameterMixed$ratkowsky = fit_nlme("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, - fixedFormula = a1 + a1p + b1 + b1p + b2 + b2p ~ 1, randomFormula = a1r ~ 1, - start = list(fixed = c(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151))) - thplHeightFromDiameterMixed$richardsW = fit_nlme("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation + Har) * (1 + ((1.37/(Ha + Hap*isPlantation + Har))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, - fixedFormula = Ha + Hap + d + kU + kUp ~ 1, randomFormula = Har ~ 1, - start = list(fixed = c(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008))) + #thplHeightFromDiameterMixed$ratkowsky = fit_nlme("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, + # fixedFormula = a1 + a1p + b1 + b1p + b2 + b2p ~ 1, randomFormula = a1r ~ 1, + #start = list(fixed = c(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151))) + #thplHeightFromDiameterMixed$richardsW = fit_nlme("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation + Har) * (1 + ((1.37/(Ha + Hap*isPlantation + Har))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, + #fixedFormula = Ha + Hap + d + kU + kUp ~ 1, randomFormula = Har ~ 1, + #start = list(fixed = c(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008))) thplHeightFromDiameterMixed$sharmaParton = fit_nlme("Sharma-Parton", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, fixedFormula = a1 + b1 + b1p + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve @@ -295,25 +312,24 @@ if (thplOptions$fitHeightMixed) thplHeightFromDiameterMixed$weibullBal = fit_nlme("Weibull BA+L", TotalHt ~ 1.37 + (a1 + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, fixedFormula = a1 + a2 + a2p + a3 + a3p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131))) - + thplHeightFromDiameterMixed$gamm = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) thplHeightFromDiameterMixed$gammBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) - save(file = "trees/height-diameter/data/THPL TotalHt mixed.Rdata", thplHeightFromDiameterMixed) + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL TotalHt mixed.Rdata", thplHeightFromDiameterMixed) } - + ## western redcedar diameter-height regressions -if (thplOptions$fitDbh) -{ +if (thplOptions$fitDbh) { thplDiameterFromHeight = list(linear = fit_lm("linear", DBH ~ 0 + I(TotalHt - 1.37), thpl2016)) # isPlantation*(TotalHt - 1.37) not significant thplDiameterFromHeight$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), thpl2016) # (TotalHt - 1.37)^2 not significant thplDiameterFromHeight$chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 500, xtol = 1E-5)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: singular gradient with nls(), no convergence from nls_multstart(), NaN-inf with nlrob() thplDiameterFromHeight$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # NaN-inf with nls() and nlrob - thplDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() - thplDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 - thplDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() + #thplDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() + #thplDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 + #thplDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() thplDiameterFromHeight$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) # a1p and b2p not significant, poor convergence with b1p, step factor with nlrob() thplDiameterFromHeight$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # a1p, b1p not significant, step factor with nlrob() thplDiameterFromHeight$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), thpl2016, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) # no physiographic effects significant, a1-b1 parameter evaporation: step factor with nlrob() @@ -349,7 +365,7 @@ if (thplOptions$fitDbh) if (thplOptions$fitDbhNlrob) { thplDiameterFromHeightNlrob = list(naslund = fit_nlrob("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), thpl2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) - thplDiameterFromHeightNlrob$power = fit_nlrob("power", DBH ~ a1*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 1.93, b1 = 1.08)) + #thplDiameterFromHeightNlrob$power = fit_nlrob("power", DBH ~ a1*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 1.93, b1 = 1.08)) #thplDiameterFromHeightNlrob$powerAbat = fit_nlrob("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) #thplDiameterFromHeightNlrob$powerPhysio = fit_nlrob("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) #thplDiameterFromHeightNlrob$powerRelHt = fit_nlrob("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) @@ -373,15 +389,15 @@ if (thplOptions$fitDbh) } else { thplDiameterFromHeightNlrob = list() } - + thpl2016defaultWeight <- thpl2016defaultWeight %>% filter(TotalHt > 5) #the code was not running and giving an error, probably because some variable used in the following models were not valid. Therefore subset of trees taller that 5 ft is taken for further analysis. thplDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) thplDiameterFromHeightGslNlsDefault$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016defaultWeight, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) - thplDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) + #thplDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) + #thplDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) thplDiameterFromHeightGslNlsDefault$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) + #thplDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) thplDiameterFromHeightGslNlsDefault$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), thpl2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) + #thplDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), thpl2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) thplDiameterFromHeightGslNlsDefault$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) thplDiameterFromHeightGslNlsDefault$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.93, b1 = 1.08)) #thplDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) @@ -392,9 +408,9 @@ if (thplOptions$fitDbh) thplDiameterFromHeightGslNlsDefault$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a2 = -0.01, a4 = -0.0006, b1 = 1.2, b2 = -0.009), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a3 = -0.003, a4 = -0.0006, a9 = 0.4, b1 = 1.27, b2 = -0.01), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 1.3, a3 = -0.003, a9 = 0.25, b1 = 1.3, b2 = -0.008), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + #thplDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant + #thplDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant #thplDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), thpl2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) thplDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, thpl2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) thplDiameterFromHeightGslNlsDefault$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) @@ -402,24 +418,23 @@ if (thplOptions$fitDbh) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.5, a2 = -0.009, a8 = -0.005, b1 = 1.2, b2 = -0.04), significant = FALSE) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.41, a2 = -0.009, a8 = -0.005, a9 = 0, b1 = 1.4, b2 = -0.05), significant = FALSE) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 1.5, a2 = -0.008, a9 = 0, a9p = 0, b1 = 1.4, b2 = 0), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + #thplDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) - thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant - thplDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) + #thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant + #thplDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) + + # # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined + # thplDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with scat() + # thplDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop ABA and elevation on AIC + # thplDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and topographic shelter on AIC + # thplDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + # thplDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and aspect on AIC - # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38) - thplDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with scat() - thplDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop ABA and elevation on AIC - thplDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and topographic shelter on AIC - thplDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - thplDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and aspect on AIC - - save(file = "trees/height-diameter/data/THPL DBH.Rdata", thplDiameterFromHeight, thplDiameterFromHeightNlrob, thplDiameterFromHeightGslNlsDefault) + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL DBH.Rdata", thplDiameterFromHeight, thplDiameterFromHeightNlrob, thplDiameterFromHeightGslNlsDefault) } -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { print(thplDiameterFromHeightResults %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic), n = 25) ggplot(thpl2016) + @@ -454,8 +469,7 @@ if (htDiaOptions$includeInvestigatory) theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) } -if (thplOptions$fitDbhMixed) -{ +if (thplOptions$fitDbhMixed) { thplDiameterFromHeightMixed = list(chapmanReplace = fit_nlme("Chapman-Richards replace", DBH ~ (a1 + a1r)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016, fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 200, b1 = 0.01, b2 = 0.95)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001))) # singularity in backsolve, max iterations @@ -558,24 +572,30 @@ if (thplOptions$fitDbhMixed) thplDiameterFromHeightMixed$weibull = fit_nlme("Weibull inverse", DBH ~ ((a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016, fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = -300, b1 = 0.04, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve - + thplDiameterFromHeightMixed$gamm = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) thplDiameterFromHeightMixed$gammAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) thplDiameterFromHeightMixed$gammRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) - - save(file = "trees/height-diameter/data/THPL DBH mixed.Rdata", thplDiameterFromHeightMixed) + + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL DBH mixed.Rdata", thplDiameterFromHeightMixed) } +# ## collect model results and parameters +# if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) { +# if (exists("thplHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/THPL TotalHt.Rdata") } +# #if (exists("thplHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/THPL TotalHt gnls.Rdata") } +# if (exists("thplHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/THPL TotalHt mixed.Rdata") } +# if (exists("thplDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/THPL DBH.Rdata") } +# if (exists("thplDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/THPL DBH mixed.Rdata") } + ## collect model results and parameters -if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) -{ +if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) { if (exists("thplHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/THPL TotalHt.Rdata") } #if (exists("thplHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/THPL TotalHt gnls.Rdata") } if (exists("thplHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/THPL TotalHt mixed.Rdata") } if (exists("thplDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/THPL DBH.Rdata") } if (exists("thplDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/THPL DBH mixed.Rdata") } - thplCoefficients = bind_rows(bind_rows(bind_rows(lapply(thplHeightFromDiameter, get_list_coefficients)), #bind_rows(lapply(thplHeightFromDiameterGnls, get_model_coefficients)), bind_rows(lapply(thplHeightFromDiameterGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), @@ -603,12 +623,12 @@ if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & th mutate(species = "THPL") check_plot_results(thplResults) - save(file = "trees/height-diameter/data/THPL results.Rdata", thplCoefficients, thplResults) + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL results.Rdata", thplCoefficients, thplResults) } else if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) { if (exists("thplHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/THPL TotalHt.Rdata") } if (exists("thplDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/THPL DBH.Rdata") } - + thplCoefficients = bind_rows(bind_rows(bind_rows(lapply(thplHeightFromDiameter, get_list_coefficients))) %>% mutate(responseVariable = "height"), bind_rows(bind_rows(lapply(thplDiameterFromHeight, get_list_coefficients))) %>% @@ -622,7 +642,7 @@ if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & th mutate(species = "THPL") check_plot_results(thplResults) - save(file = "trees/height-diameter/data/THPL results.Rdata", thplCoefficients, thplResults) + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL results.Rdata", thplCoefficients, thplResults) } @@ -642,7 +662,7 @@ if (thplOptions$fitHeight & thplOptions$fitDbh) #AIC(thplHeightFromDiameterPreferred$hossfeld, thplHeightFromDiameterPreferred$michaelisMenten, thplHeightFromDiameterPreferred$prodan, thplHeightFromDiameterPreferred$ratkowsky) thplDiameterFromHeightPreferred = list(gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1)) - thplDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) + #thplDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), thpl2016, folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 1.93, b1 = 1.08), folds = 1, repetitions = 1) #thplDiameterFromHeightPreferred$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) @@ -650,7 +670,7 @@ if (thplOptions$fitHeight & thplOptions$fitDbh) thplDiameterFromHeightPreferred$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) - save(file = "trees/height-diameter/data/THPL preferred models.Rdata", thplHeightFromDiameterPreferred, thplDiameterFromHeightPreferred) + save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL preferred models.Rdata", thplHeightFromDiameterPreferred, thplDiameterFromHeightPreferred) } @@ -660,7 +680,7 @@ if (htDiaOptions$includeInvestigatory) thplBasalAreaFromHeightKorf = gsl_nls(basalArea ~ a1*(exp(b1*(imputedHeight - 1.37)^b2) - 1), thpl2016, start = list(a1 = 90, b1 = 0.000003, b2 = 2.18), weights = heightWeight^2) # a1p, b1p, b2p not significant thplBasalAreaFromHeightPower = gsl_nls(basalArea ~ a1*(imputedHeight - 1.37)^(b1 + b1p * isPlantation), thpl2016, start = list(a1 = 3/7 * 0.25 * pi * 0.01^2, b1 = 2.14, b1p = 0.34), weights = heightWeight^2) # a1p not significant #confint2(thplBasalAreaFromHeightPower, level = 0.99) - + tribble(~method, ~aic, ~biasCm2, ~maeM2, ~nse, "Korf", AIC(thplBasalAreaFromHeightKorf), 100^2 * mean(residuals(thplBasalAreaFromHeightKorf)), mean(abs(residuals(thplBasalAreaFromHeightKorf))), 1 - sum(residuals(thplBasalAreaFromHeightKorf)^2) / sum((thpl2016$basalArea - mean(thpl2016$basalArea)^2)), "power", AIC(thplBasalAreaFromHeightPower), 100^2 * mean(residuals(thplBasalAreaFromHeightPower)), mean(abs(residuals(thplBasalAreaFromHeightPower))), 1 - sum(residuals(thplBasalAreaFromHeightPower)^2) / sum((thpl2016$basalArea - mean(thpl2016$basalArea)^2))) %>% @@ -734,13 +754,13 @@ if (htDiaOptions$includeInvestigatory) plot.gam(thplHeightGam, scale = 0, scheme = 2) thplDbhGam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), - #s(standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant - #s(tallerApproxBasalArea, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant - #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant - #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant - #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant - #s(topographicShelterIndex, bs = "ts", k = 3, pc = gamConstraint), # not significant - #s(relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint), # not significant + #s(standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(tallerApproxBasalArea, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(topographicShelterIndex, bs = "ts", k = 3, pc = gamConstraint), # not significant + #s(relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint), # not significant data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) k.check(thplDbhGam) summary(thplDbhGam) @@ -763,7 +783,7 @@ if (htDiaOptions$includeInvestigatory) min.node.size = c(1, 2))) thplHeightForest varImp(thplHeightForest) - + thplDbhForest = train(DBH ~ TotalHt + standBasalAreaApprox + tallerApproxBasalArea + elevation + slope + aspect + topographicShelterIndex + relativeHeight, data = thpl2016, method = "ranger", trControl = repeatedCrossValidation, importance = "impurity_corrected", tuneGrid = expand.grid(mtry = c(7, 8), @@ -772,3 +792,4 @@ if (htDiaOptions$includeInvestigatory) thplDbhForest varImp(thplDbhForest) } + diff --git a/trees/height-diameter/setup.R b/trees/height-diameter/setup.R index 5583063..a772038 100644 --- a/trees/height-diameter/setup.R +++ b/trees/height-diameter/setup.R @@ -24,82 +24,90 @@ library(tidyr) library(WeightedROC) library(writexl) -theme_set(theme_bw() + theme(axis.line = element_line(linewidth = 0.3), - legend.background = element_rect(fill = alpha("white", 0.5)), - legend.margin = margin(), - legend.key.height = unit(0.85, "line"), - legend.spacing.y = unit(0, "line"), + +####### ----- FUNCTIONS ------ ###### + + +#theme set() is a function from ggplot, it is used to customize plot aesthetics +#theme_bw() sets the background to white with black grid lines +#and the theme() functions define the various elements within the theme. +theme_set(theme_bw() + theme(axis.line = element_line(linewidth = 0.3), #makes the axis lines thinner, the default is 0.5 + legend.background = element_rect(fill = alpha("white", 0.5)),# background, transparency 50% white. + legend.margin = margin(), #default margin + legend.key.height = unit(0.85, "line"), #legend box vertical spacing 0.85 line unit + legend.spacing.y = unit(0, "line"), #remove vertical spacing between legen items legend.title = element_text(size = 10), panel.border = element_blank(), - plot.title = element_text(size = 10))) + plot.title = element_text(size = 10))) #+ theme(axis.title.y = element_text(angle = 0, vjust = 0.5)) #rotate and justification of Y axis label, usually not required + htDiaOptions = tibble(folds = 10, repetitions = 10, - includeInvestigatory = FALSE, # default to excluding plotting and other add ons in species scripts + includeInvestigatory = FALSE, # default to excluding plotting and other add ons in species scripts #it is like telling R that I do not want the code for plots/investigatory statistics to be run (coded somewhere below, if I set this as FALSE) retainModelThreshold = 10) # cross validation retains model objects if folds * repetitions is less than or equal to this threshold, e.g. 25 = retaining models up to and including 5x5 cross validation but sufficient DDR for loading all results may be an issue (5x5 easily exceeds 90 GB) -#plotLetters = c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L") -plotLetters = c("(a)", "(b)", "(c)", "(d)", "(e)", "(f)", "(g)", "(h)", "(i)", "(j)", "(k)", "(l)") +plotLetters = c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L") +#plotLetters = c("(a)", "(b)", "(c)", "(d)", "(e)", "(f)", "(g)", "(h)", "(i)", "(j)", "(k)", "(l)") -append_model_results = function(loadedResults, modelList, responseVariable, fitSet = "primary", fixedWeight = NA_real_) +append_model_results = function(loadedResults, modelList, responseVariable, fitSet = "primary", fixedWeight = NA_real_) #fitSet and fixedWeight are like constantsa and we need to input rest of the arguments only { - return(bind_rows(loadedResults, - bind_rows(lapply(modelList, get_list_stats, fitSet = fitSet, fixedWeight = fixedWeight)) %>% - mutate(responseVariable = responseVariable))) + return(bind_rows(loadedResults, #stack the results from lapply and loadedResults, loadedResults is probably an initialized tibble or a tibble with same dimension as the tibble output from lapply() + bind_rows(lapply(modelList, get_list_stats, fitSet = fitSet, fixedWeight = fixedWeight)) %>% #lappy: applies a given function to all elements in the list or vector. check the general syntax for a detailed information + mutate(responseVariable = responseVariable))) #add a column "responseVariable" to the stacked results including both loadedResults and lapply() } -check_plot_results = function(results) +check_plot_results = function(results) #it is a function of "results" { numberOfBins = 30 # specify default to suppress messages about binwidth ggplot(results) + geom_histogram(aes(x = bias, fill = responseVariable), bins = numberOfBins) + labs(x = "bias, m or cm") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = mab, fill = responseVariable), bins = numberOfBins) + labs(x = "MAB, m or cm") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = mapb, fill = responseVariable), bins = numberOfBins) + labs(x = "MAB, %") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = mae, fill = responseVariable), bins = numberOfBins) + labs(x = "MAE, m or cm") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = mape, fill = responseVariable), bins = numberOfBins) + labs(x = "MAE, %") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = nse, fill = responseVariable), bins = numberOfBins) + labs(x = "model efficiency") + scale_x_continuous(trans = scales::pseudo_log_trans()) + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = rmse, fill = responseVariable), bins = numberOfBins) + labs(x = "RMSE, m or cm") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = rmspe, fill = responseVariable), bins = numberOfBins) + labs(x = "RMSE, %") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = aic, fill = responseVariable), bins = numberOfBins) + labs(x = "AIC") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = aict, fill = responseVariable), bins = numberOfBins) + labs(x = "AIC, ~t") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = bic, fill = responseVariable), bins = numberOfBins) + labs(x = "BIC") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = bict, fill = responseVariable), bins = numberOfBins) + labs(x = "BIC, ~t") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = meanAbsolutePlantationEffect, fill = responseVariable), bins = numberOfBins) + labs(x = "MAPE, m or cm") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = meanAbsolutePercentPlantationEffect, fill = responseVariable), bins = numberOfBins) + labs(x = "MAPE, %") + - ggplot(results) + + ggplot(results) + geom_histogram(aes(x = fitTimeInS, fill = responseVariable), bins = numberOfBins) + labs(x = "fit time, s") + scale_x_log10() + - guide_area() + + guide_area() + theme(legend.justification = c(1, 0), legend.position.inside = c(0.9, 0.1)) + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout(guides = "collect") & + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout(guides = "collect") & labs(y = "model fits", fill = NULL) & scale_fill_discrete(breaks = c("height", "DBH")) } @@ -115,16 +123,16 @@ confint_nlrob = function(regression, level = 0.99, df = df.residual(regression), stop("Either regression$weights is not set or trainingWeights was not specified.") } squaredDeviation = sum(trainingWeights * regression$rweights * residuals(regression)^2) / df.residual(regression) - gradient = regression$m$gradient() + gradient = regression$m$gradient() #regression$m contains model information, so this code is going inside regression model information and taking derivative of residuals with respect to parameters. levels = c((1 - level)/2, 1 - (1 - level)/2) - parameterValues = regression$m$getPars() - confidenceInterval = parameterValues + sqrt(diag(squaredDeviation * solve(t(gradient) %*% gradient))) %o% qt(p = levels, df = df) - colnames(confidenceInterval) = sprintf("%g%%", 100*levels) - rownames(confidenceInterval) = names(parameterValues) + parameterValues = regression$m$getPars() #value of parameter estimates from teh regression model + confidenceInterval = parameterValues + sqrt(diag(squaredDeviation * solve(t(gradient) %*% gradient))) %o% qt(p = levels, df = df) #matrix method for confidence interval calculation %*% is matrix multiplication and %o% is outer product (not the same as scalar/dot product) + colnames(confidenceInterval) = sprintf("%g%%", 100*levels) #%g%% defines the format of printing; print "%" after 100*levels value in the column name + rownames(confidenceInterval) = names(parameterValues) #gives names of parameter values stored in the summary stat of a model return(confidenceInterval) } -create_model_stats = function(name, fittingMethod = "unknown", fitSet = NA_character_, fixedWeight = NA_real_) +create_model_stats = function(name, fittingMethod = "unknown", fitSet = NA_character_, fixedWeight = NA_real_) #initializing a tibble for storing model stats later { if (is.null(name) | is.na(fittingMethod)) { @@ -151,29 +159,29 @@ create_model_stats = function(name, fittingMethod = "unknown", fitSet = NA_chara # future_map() sometimes works but doesn't reliably pass smooth parameters like constraints fit_gam = function(name, formula, data, constraint = c(), family = gaussian(), folds = htDiaOptions$folds, repetitions = htDiaOptions$repetitions, returnModel = folds * repetitions <= htDiaOptions$retainModelThreshold, bam = FALSE, mixed = FALSE, nthreads = 1, significant = TRUE, tDegreesOfFreedom = 8) { - if (bam & mixed) + if (bam & mixed) #here bam=FALSE, mixed=FALSE, are defaults, if we enter both as true, stop it and print the warning message. if we choose bam() we cannot use mixed effects { - stop("bam() does not support fixed effects. One of fit_gam()'s bam or mixed arguments can be true but not both.") + stop("bam() does not support fixed effects. One of fit_gam()'s bam or mixed arguments can be true but not both.") #I think, in the print string, the word "fixed" should be replaced by "mixed". } - if (mixed & (nthreads > 1)) + if (mixed & (nthreads > 1))#if mixed is true, it will call gamm() instead of bam() or gam() which does not support multi thread functionality { - stop("gamm() does not support nthreads.") + stop("gamm() does not support nthreads.") #if all these conditions are passed thorugh, then do the next step } - responseVariable = formula[2] # displays as TotalHt or DBH but compares at TotalHt() or DBH() - message(paste0("Fitting ", name, " for ", folds, "x", repetitions, " ", responseVariable, " using ", if_else(mixed, "gamm", if_else(bam, "bam", "gam")), "()...")) - progressBar = progressor(steps = folds * repetitions) + responseVariable = formula[2] # displays as TotalHt or DBH but compares at TotalHt() or DBH() #the formula (equation) is indexed, so formula[1] give you operator sign ~,formula[2]=LHS of equation, formula[3]=RHS of equation. + message(paste0("Fitting ", name, " for ", folds, "x", repetitions, " ", responseVariable, " using ", if_else(mixed, "gamm", if_else(bam, "bam", "gam")), "()...")) #paste this message for each iteration of the running code.#If mixed = TRUE, use "gamm",Else if bam = TRUE, use "bam" Else use "gam", check syntax of ifelse() if necessary + progressBar = progressor(steps = folds * repetitions) #design of progress bar - # work around https://github.com/HenrikBengtsson/globals/issues/87 to enable GAM fitting using future_map() - localFormula = local({ gamConstraint = constraint - formula(paste(deparse(formula), collapse = " ")) }) - if (responseVariable == "TotalHt()") + # work around https://github.com/HenrikBengtsson/globals/issues/87 to enable GAM fitting using future_map() #to make the constrains passable, it won't be possible + localFormula = local({ gamConstraint = constraint #creating a local formula, that is basically the same as above. + formula(paste(deparse(formula), collapse = " ")) }) # to understand the syntax, see ?deparse() and ?paste() in r documentation #collapse=" " defines the separator/concatenator, in this case, the strings will be concatenated using the " " or space + if (responseVariable == "TotalHt()") #lets continue the conditional statements after the local formula. { if (bam) { if ((folds == 1) & (repetitions == 1)) { - startFit = Sys.time() + startFit = Sys.time() #tracking the model fitting time allFit = bam(formula = localFormula, data = data, family = family, method = "REML", select = TRUE, weights = dbhWeight, nthreads = nthreads) allFitStats = get_height_stats(name = name, model = allFit, trainingData = data, validationData = data, significant = significant, tDegreesOfFreedom = tDegreesOfFreedom) allFitStats$fitTimeInS = get_elapsed_time(startFit) @@ -302,7 +310,7 @@ fit_gnls = function(name, modelFormula, data, start, control = gnlsControl(maxIt responseVariable = modelFormula[2] message(paste0("Fitting ", name, " for ", folds, "x", repetitions, " ", responseVariable, " using gnls()...")) progressBar = progressor(steps = folds * repetitions) - + if (responseVariable == "TotalHt()") { startFit = Sys.time() @@ -569,7 +577,7 @@ fit_nlrob = function(name, formula, data, start, control = nls.control(maxiter = responseVariable = formula[2] message(paste0("Fitting ", name, " for ", folds, "x", repetitions, " ", responseVariable, " using nlrob()...")) progressBar = progressor(steps = folds * repetitions) - + if (responseVariable == "TotalHt()") { startFit = Sys.time() @@ -602,7 +610,7 @@ fit_nlrob = function(name, formula, data, start, control = nls.control(maxiter = { stop("Expected response variable to be DBH.") } - + startFit = Sys.time() allFit = nlrob(formula = formula, data = data, maxit = maxit, start = start, weights = heightWeight, control = control) if ((folds == 1) & (repetitions == 1)) @@ -627,7 +635,7 @@ fit_nlrob = function(name, formula, data, start, control = nls.control(maxiter = return(get_fit_return_value(model, modelStats, returnModel)) } } - + splitsAndFits = vfold_cv(data, v = folds, repeats = repetitions) %>% mutate(fit = future_map(splits, fitFunction)) return(get_cross_validation_return_value(splitsAndFits, returnModel)) } @@ -681,7 +689,7 @@ get_dbh_stats = function(name, model, trainingData, validationData, validationWe { warning(paste0(dbhModelStats$fitting, " ", formula(model)[2], " model using ", name, " is not converged.")) } - + if (is(model, "gamm")) { predictedDbh = predict(model$gam, validationData) @@ -713,7 +721,7 @@ get_dbh_stats = function(name, model, trainingData, validationData, validationWe plantationEffectPct = 100 * plantationEffect / meanDbh, .groups = "drop") %>% filter(n > 0) - + nObservations = sum(trainingData$TreeCount) if (is(model, "gam")) { @@ -733,7 +741,7 @@ get_dbh_stats = function(name, model, trainingData, validationData, validationWe standardDeviation = sqrt(1/residualDegreesOfFreedom * sum(validationWeights * validationResiduals^2)) / sqrt(validationWeights) logLikelihoodGaussian = sum(validationData$TreeCount * dnorm(validationResiduals, sd = standardDeviation, log = TRUE)) logLikelihoodT = sum(validationData$TreeCount * dt(validationResiduals / standardDeviation, df = tDegreesOfFreedom, log = TRUE) - log(standardDeviation)) - + heightDiameterRatio = validationData$TotalHt / (0.01 * predictedDbh) speciesLimits = get_species_limits(validationData) validationTreeCountTotal = sum(validationData$TreeCount) @@ -817,7 +825,7 @@ get_height_stats = function(name, model, trainingData, validationData, validatio { warning(paste0(heightModelStats$fitting, " ", formula(model)[2], " model using ", name, " is not converged.")) } - + dbhClassSize = 10 # cm if (is(model, "gamm")) { @@ -854,7 +862,7 @@ get_height_stats = function(name, model, trainingData, validationData, validatio plantationEffectPct = 100 * plantationEffect / meanHeight, .groups = "drop") %>% filter(n > 0) - + nObservations = sum(trainingData$TreeCount) if (is(model, "gam")) { @@ -894,7 +902,7 @@ get_height_stats = function(name, model, trainingData, validationData, validatio heightModelStats$rmse = sqrt(sum(validationData$TreeCount * validationResiduals^2) / validationTreeCountTotal) heightModelStats$rmspe = 100 * sqrt(sum(validationData$TreeCount * (validationResiduals / validationData$TotalHt)^2) / validationTreeCountTotal) heightModelStats$significant = significant - + naturalRegenIndices = which(validationData$isPlantation == FALSE) heightNaturalRegen = validationData$TotalHt[naturalRegenIndices] predictedHeightNaturalRegen = predictedHeight[naturalRegenIndices] @@ -954,12 +962,12 @@ get_list_coefficients = function(modelCrossValidationListOrStatsTibble, fitSet = { # cross validation tibble coefficients = bind_rows(lapply(modelCrossValidationListOrStatsTibble$fit, function(fit) - { - return(fit$stats$coefficients %>% - mutate(name = fit$stats$name, - fitting = fit$stats$fitting, - significant = fit$stats$significant)) - })) %>% + { + return(fit$stats$coefficients %>% + mutate(name = fit$stats$name, + fitting = fit$stats$fitting, + significant = fit$stats$significant)) + })) %>% mutate(repetition = as.numeric(str_replace(modelCrossValidationListOrStatsTibble$id, "Repeat", "")), fold = as.numeric(str_replace(modelCrossValidationListOrStatsTibble$id2, "Fold", ""))) } else if (is(modelCrossValidationListOrStatsTibble, "tbl_df")) @@ -985,7 +993,7 @@ get_list_coefficients = function(modelCrossValidationListOrStatsTibble, fitSet = fixedWeightArgument = fixedWeight coefficients %<>% mutate(fitSet = fitSetArgument, fixedWeight = fixedWeightArgument) %>% - relocate(fitSet, fixedWeight, name, repetition, fold) + relocate(fitSet, fixedWeight, name, repetition, fold) return(coefficients) } @@ -1050,7 +1058,7 @@ get_model_coefficients = function(model) coefficients = tibble(!!!set_names(model$coefficients, names(model$coefficients))) } } - + if ("(Intercept)" %in% names(coefficients)) { coefficients %<>% rename(a0 = `(Intercept)`) @@ -1158,7 +1166,7 @@ get_prediction_stats = function(name, responseVariable, trainingData, predicted, standardDeviation = sqrt(1/residualDegreesOfFreedom * sum(validationWeights * validationResiduals^2)) / sqrt(validationWeights) logLikelihoodGaussian = sum(validationData$TreeCount * dnorm(validationResiduals, sd = standardDeviation, log = TRUE)) logLikelihoodT = sum(validationData$TreeCount * dt(validationResiduals / standardDeviation, df = tDegreesOfFreedom, log = TRUE) - log(standardDeviation)) - + speciesLimits = get_species_limits(validationData) validationTreeCountTotal = sum(validationData$TreeCount) modelStats$aic = -2*logLikelihoodGaussian + 2 * effectiveDegreesOfFreedom # calculate AIC and BIC manually because nlrob objects implement weighting differently from nls and gslnls @@ -1321,87 +1329,87 @@ plot_auc_bank = function(aucs, fillLabel = "median AUC", omitMab = FALSE, xLimit if (omitMab) { aucBank = ggplot() + - geom_raster(aes(x = species, y = name, fill = aucMae), aucs) + - labs(fill = fillLabel) + - scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + - new_scale_fill() + - geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucMae), NA_real_, significant))), aucs) + - scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), guide = guide_legend(order = 2)) + - geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucMabRank <= 2, aucMabRank <= 2)), fill = "transparent") + - labs(title = bquote(.(plotLetters[1])~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + - #labs(title = bquote(bold(.(plotLetters[1]))~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + - scale_y_discrete(limits = rev) + geom_raster(aes(x = species, y = name, fill = aucMae), aucs) + + labs(fill = fillLabel) + + scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + + new_scale_fill() + + geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucMae), NA_real_, significant))), aucs) + + scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), guide = guide_legend(order = 2)) + + geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucMabRank <= 2, aucMabRank <= 2)), fill = "transparent") + + labs(title = bquote(.(plotLetters[1])~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + + #labs(title = bquote(bold(.(plotLetters[1]))~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + + scale_y_discrete(limits = rev) letterOffset = 1 } else { aucBank = ggplot() + - geom_raster(aes(x = species, y = name, fill = aucMab), aucs) + - labs(fill = fillLabel) + - scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + - new_scale_fill() + - geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucMab), NA_real_, significant))), aucs) + - scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + - geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucMabRank <= 2, aucMabRank <= 2)), fill = "transparent") + - labs(title = bquote(.(plotLetters[1])~"MAB"), x = NULL, y = NULL, color = NULL, fill = NULL) + - #labs(title = bquote(bold(.(plotLetters[1]))~"MAB"), x = NULL, y = NULL, color = NULL, fill = NULL) + - scale_y_discrete(limits = rev) + - ggplot() + - geom_raster(aes(x = species, y = name, fill = aucMae), aucs) + - labs(fill = fillLabel) + - scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + - new_scale_fill() + - geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucMae), NA_real_, significant))), aucs) + - geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucMaeRank <= 2, aucMaeRank <= 2)), fill = "transparent") + - scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + - labs(title = bquote(.(plotLetters[2])~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + - #labs(title = bquote(bold(.(plotLetters[2]))~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + - scale_y_discrete(labels = NULL, limits = rev) - letterOffset = 2 - } - - aucBank = aucBank + - ggplot() + - geom_raster(aes(x = species, y = name, fill = aucRmse), aucs) + + geom_raster(aes(x = species, y = name, fill = aucMab), aucs) + labs(fill = fillLabel) + scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + new_scale_fill() + - geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucRmse), NA_real_, significant))), aucs) + - geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucRmseRank <= 2, aucRmseRank <= 2)), fill = "transparent") + + geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucMab), NA_real_, significant))), aucs) + scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + - labs(title = bquote(.(plotLetters[letterOffset + 1])~"RMSE"), x = NULL, y = NULL, color = NULL, fill = NULL) + - #labs(title = bquote(bold(.(plotLetters[letterOffset + 1]))~"RMSE"), x = NULL, y = NULL, color = NULL, fill = NULL) + - scale_y_discrete(labels = NULL, limits = rev) + - ggplot() + - geom_raster(aes(x = species, y = name, fill = aucDeltaAicN), aucs) + + geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucMabRank <= 2, aucMabRank <= 2)), fill = "transparent") + + labs(title = bquote(.(plotLetters[1])~"MAB"), x = NULL, y = NULL, color = NULL, fill = NULL) + + #labs(title = bquote(bold(.(plotLetters[1]))~"MAB"), x = NULL, y = NULL, color = NULL, fill = NULL) + + scale_y_discrete(limits = rev) + + ggplot() + + geom_raster(aes(x = species, y = name, fill = aucMae), aucs) + labs(fill = fillLabel) + scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + new_scale_fill() + - geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucDeltaAicN), NA_real_, significant))), aucs) + - geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucDeltaAicNRank <= 2, aucDeltaAicNRank <= 2)), fill = "transparent") + + geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucMae), NA_real_, significant))), aucs) + + geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucMaeRank <= 2, aucMaeRank <= 2)), fill = "transparent") + scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + - labs(title = bquote(.(plotLetters[letterOffset + 2])~"ΔAICn"), x = NULL, y = NULL, color = NULL, fill = NULL) + - #labs(title = bquote(bold(.(plotLetters[letterOffset + 2]))~"ΔAICn"), x = NULL, y = NULL, color = NULL, fill = NULL) + - scale_y_discrete(labels = NULL, limits = rev) + + labs(title = bquote(.(plotLetters[2])~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + + #labs(title = bquote(bold(.(plotLetters[2]))~"MAE"), x = NULL, y = NULL, color = NULL, fill = NULL) + + scale_y_discrete(labels = NULL, limits = rev) + letterOffset = 2 + } + + aucBank = aucBank + ggplot() + - geom_raster(aes(x = species, y = name, fill = aucNse), aucs) + - labs(fill = fillLabel) + - scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + - new_scale_fill() + - geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucNse), NA_real_, significant))), aucs) + - geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucNseRank <= 2, aucNseRank <= 2)), fill = "transparent") + - scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + - labs(title = bquote(.(plotLetters[letterOffset + 3])~"model efficiency"), x = NULL, y = NULL, color = NULL, fill = NULL) + - #labs(title = bquote(bold(.(plotLetters[letterOffset + 3]))~"model efficiency"), x = NULL, y = NULL, color = NULL, fill = NULL) + - scale_y_discrete(labels = NULL, limits = rev) + + geom_raster(aes(x = species, y = name, fill = aucRmse), aucs) + + labs(fill = fillLabel) + + scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + + new_scale_fill() + + geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucRmse), NA_real_, significant))), aucs) + + geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucRmseRank <= 2, aucRmseRank <= 2)), fill = "transparent") + + scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + + labs(title = bquote(.(plotLetters[letterOffset + 1])~"RMSE"), x = NULL, y = NULL, color = NULL, fill = NULL) + + #labs(title = bquote(bold(.(plotLetters[letterOffset + 1]))~"RMSE"), x = NULL, y = NULL, color = NULL, fill = NULL) + + scale_y_discrete(labels = NULL, limits = rev) + + ggplot() + + geom_raster(aes(x = species, y = name, fill = aucDeltaAicN), aucs) + + labs(fill = fillLabel) + + scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + + new_scale_fill() + + geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucDeltaAicN), NA_real_, significant))), aucs) + + geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucDeltaAicNRank <= 2, aucDeltaAicNRank <= 2)), fill = "transparent") + + scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + + labs(title = bquote(.(plotLetters[letterOffset + 2])~"ΔAICn"), x = NULL, y = NULL, color = NULL, fill = NULL) + + #labs(title = bquote(bold(.(plotLetters[letterOffset + 2]))~"ΔAICn"), x = NULL, y = NULL, color = NULL, fill = NULL) + + scale_y_discrete(labels = NULL, limits = rev) + + ggplot() + + geom_raster(aes(x = species, y = name, fill = aucNse), aucs) + + labs(fill = fillLabel) + + scale_fill_scico(palette = "bam", limits = c(0, 1), guide = guide_colorbar(order = 1, theme = aucColorbarTheme)) + + new_scale_fill() + + geom_raster(aes(x = species, y = name, fill = as.factor(if_else(is.na(aucNse), NA_real_, significant))), aucs) + + geom_tile(aes(x = species, y = name, color = as.factor(isBaseForm), linewidth = isBaseForm), aucs %>% filter(if_else(isBaseForm, aucNseRank <= 2, aucNseRank <= 2)), fill = "transparent") + + scale_fill_manual(breaks = c(1, 0, NA), labels = c("", "not\nsignificant", "fitting did not\nconverge"), values = c("transparent", "grey70", "red2"), na.value = "red2", guide = guide_legend(order = 2)) + + labs(title = bquote(.(plotLetters[letterOffset + 3])~"model efficiency"), x = NULL, y = NULL, color = NULL, fill = NULL) + + #labs(title = bquote(bold(.(plotLetters[letterOffset + 3]))~"model efficiency"), x = NULL, y = NULL, color = NULL, fill = NULL) + + scale_y_discrete(labels = NULL, limits = rev) + plot_annotation(theme = theme(plot.margin = margin())) + plot_layout(nrow = 1, guides = "collect") & - guides(color = guide_legend(override.aes = list(linewidth = 0.5)), linewidth = "none") & - scale_color_manual(breaks = c(FALSE, TRUE), labels = c("preferred\ngeneralization", "preferred\nbase form"), values = c("dodgerblue", "grey25")) & - scale_linewidth_manual(breaks = c(FALSE, TRUE), values = c(0.3, 0.2)) & - scale_x_discrete(limits = xLimits) & - #scale_x_discrete(labels = c("PSME", "ALRU", "TSHE", "ACMA", "UMCA", "THPL", "other"), limits = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species")) & - theme(axis.text.x = element_text(angle = 90, size = 10, hjust = 1, vjust = 0.5), axis.text.y = element_text(size = 10), - legend.position = "bottom", legend.spacing.y = unit(0.4, "line"), legend.justification = c(legendHjustification, 0.5), legend.title = element_text(size = 11), - panel.grid = element_blank(), plot.margin = margin(r = plotRightMargin), plot.title = element_text(margin = margin(b = 0.5))) + guides(color = guide_legend(override.aes = list(linewidth = 0.5)), linewidth = "none") & + scale_color_manual(breaks = c(FALSE, TRUE), labels = c("preferred\ngeneralization", "preferred\nbase form"), values = c("dodgerblue", "grey25")) & + scale_linewidth_manual(breaks = c(FALSE, TRUE), values = c(0.3, 0.2)) & + scale_x_discrete(limits = xLimits) & + #scale_x_discrete(labels = c("PSME", "ALRU", "TSHE", "ACMA", "UMCA", "THPL", "other"), limits = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species")) & + theme(axis.text.x = element_text(angle = 90, size = 10, hjust = 1, vjust = 0.5), axis.text.y = element_text(size = 10), + legend.position = "bottom", legend.spacing.y = unit(0.4, "line"), legend.justification = c(legendHjustification, 0.5), legend.title = element_text(size = 11), + panel.grid = element_blank(), plot.margin = margin(r = plotRightMargin), plot.title = element_text(margin = margin(b = 0.5))) return(aucBank) } @@ -1414,7 +1422,7 @@ plot_exploratory = function(liveUnbrokenTrees, titleLetters = plotLetters, speci heightQuantiles = liveUnbrokenTrees %>% mutate(heightClass = 1 * (ceiling(TotalHt / 1) - 0.5)) %>% group_by(heightClass) %>% reframe(count = n(), quantiles = c("min", "q025", "q10", "q20", "q25", "q30", "q40", "median", "q60", "q70", "q75", "q80", "q90", "q975", "max"), dbh = quantile(DBH, probs = c(0, 0.025, 0.1, 0.2, 0.25, 0.3, 0.4, 0.5, 0.6, 0.7, 0.75, 0.8, 0.9, 0.975, 1), na.rm = TRUE), mean = mean(DBH, na.rm = TRUE), .groups = "drop") %>% pivot_wider(names_from = quantiles, values_from = dbh) - + distributionLegendPosition = "inside" treeLegendPosition = "inside" if (omitLegends) @@ -1454,50 +1462,50 @@ plot_exploratory = function(liveUnbrokenTrees, titleLetters = plotLetters, speci exploratoryPlots = exploratoryPlots + ggplot(dbhQuantiles) + - geom_ribbon(aes(x = diameterClass, ymin = 100 * (q025 - mean) / mean^heightPower, ymax = 100 * (q975 - mean) / mean^heightPower, alpha = "95% probability"), fill = "forestgreen") + - geom_ribbon(aes(x = diameterClass, ymin = 100 * (q10 - mean) / mean^heightPower, ymax = 100 * (q90 - mean) / mean^heightPower, alpha = "80% probability"), fill = "forestgreen") + - geom_ribbon(aes(x = diameterClass, ymin = 100 * (q25 - mean) / mean^heightPower, ymax = 100 * (q75 - mean) / mean^heightPower, alpha = "50% probability"), fill = "forestgreen") + - geom_path(aes(x = diameterClass, y = 100 * (min - mean) / mean^heightPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + - #geom_path(aes(x = diameterClass, y = 100 * (q10 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = diameterClass, y = 100 * (q20 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = diameterClass, y = 100 * (q30 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = diameterClass, y = 100 * (q40 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_segment(x = 0, xend = 185, y = 0, yend = 0, color = "forestgreen", linewidth = 0.4) + - geom_path(aes(x = diameterClass, y = 100 * (q60 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = diameterClass, y = 100 * (q70 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = diameterClass, y = 100 * (q80 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - #geom_path(aes(x = diameterClass, y = 100 * (q90 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = diameterClass, y = 100 * (max - mean) / mean^heightPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + - coord_cartesian(xlim = c(0, 196), ylim = c(-50, 150)) + - scale_alpha_manual(breaks = c("95% probability", "80% probability", "50% probability"), values = c(0.1, 0.2, 0.3)) + - scale_color_manual(breaks = c("10% contour", "max or min"), values = c("grey50", "grey70")) + - scale_linetype_manual(breaks = c("10% contour", "max or min"), values = c("dashed", "dotted")) + - labs(x = dbhXlabel, y = "departure from mean height, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[2] != "") { bquote(.(titleLetters[2])~.(speciesLabel)) } else { NULL }) + - #labs(x = dbhXlabel, y = "departure from mean height, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[2] != "") { bquote(bold(.(titleLetters[2]))~.(speciesLabel)) } else { NULL }) + - theme(legend.position = "none") + + geom_ribbon(aes(x = diameterClass, ymin = 100 * (q025 - mean) / mean^heightPower, ymax = 100 * (q975 - mean) / mean^heightPower, alpha = "95% probability"), fill = "forestgreen") + + geom_ribbon(aes(x = diameterClass, ymin = 100 * (q10 - mean) / mean^heightPower, ymax = 100 * (q90 - mean) / mean^heightPower, alpha = "80% probability"), fill = "forestgreen") + + geom_ribbon(aes(x = diameterClass, ymin = 100 * (q25 - mean) / mean^heightPower, ymax = 100 * (q75 - mean) / mean^heightPower, alpha = "50% probability"), fill = "forestgreen") + + geom_path(aes(x = diameterClass, y = 100 * (min - mean) / mean^heightPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + + #geom_path(aes(x = diameterClass, y = 100 * (q10 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = diameterClass, y = 100 * (q20 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = diameterClass, y = 100 * (q30 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = diameterClass, y = 100 * (q40 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_segment(x = 0, xend = 185, y = 0, yend = 0, color = "forestgreen", linewidth = 0.4) + + geom_path(aes(x = diameterClass, y = 100 * (q60 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = diameterClass, y = 100 * (q70 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = diameterClass, y = 100 * (q80 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + #geom_path(aes(x = diameterClass, y = 100 * (q90 - mean) / mean^heightPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = diameterClass, y = 100 * (max - mean) / mean^heightPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + + coord_cartesian(xlim = c(0, 196), ylim = c(-50, 150)) + + scale_alpha_manual(breaks = c("95% probability", "80% probability", "50% probability"), values = c(0.1, 0.2, 0.3)) + + scale_color_manual(breaks = c("10% contour", "max or min"), values = c("grey50", "grey70")) + + scale_linetype_manual(breaks = c("10% contour", "max or min"), values = c("dashed", "dotted")) + + labs(x = dbhXlabel, y = "departure from mean height, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[2] != "") { bquote(.(titleLetters[2])~.(speciesLabel)) } else { NULL }) + + #labs(x = dbhXlabel, y = "departure from mean height, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[2] != "") { bquote(bold(.(titleLetters[2]))~.(speciesLabel)) } else { NULL }) + + theme(legend.position = "none") + ggplot(heightQuantiles) + - geom_ribbon(aes(x = heightClass, ymin = 100 * (q025 - mean) / mean^dbhPower, ymax = 100 * (q975 - mean) / mean^dbhPower, alpha = "95% probability"), fill = "burlywood4") + - geom_ribbon(aes(x = heightClass, ymin = 100 * (q10 - mean) / mean^dbhPower, ymax = 100 * (q90 - mean) / mean^dbhPower, alpha = "80% probability"), fill = "burlywood4") + - geom_ribbon(aes(x = heightClass, ymin = 100 * (q25 - mean) / mean^dbhPower, ymax = 100 * (q75 - mean) / mean^dbhPower, alpha = "50% probability"), fill = "burlywood4") + - geom_path(aes(x = heightClass, y = 100 * (min - mean) / mean^dbhPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + - #geom_path(aes(x = heightClass, y = 100 * (q10 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = heightClass, y = 100 * (q20 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = heightClass, y = 100 * (q30 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = heightClass, y = 100 * (q40 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_segment(x = 0, xend = 77.5, y = 0, yend = 0, color = "burlywood4", linewidth = 0.4) + - geom_path(aes(x = heightClass, y = 100 * (q60 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = heightClass, y = 100 * (q70 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = heightClass, y = 100 * (q80 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - #geom_path(aes(x = heightClass, y = 100 * (q90 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + - geom_path(aes(x = heightClass, y = 100 * (max - mean) / mean^dbhPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + - coord_cartesian(xlim = c(0, 80), ylim = c(-50, 150)) + - guides(alpha = guide_legend(order = 1, override.aes = list(fill = "grey30")), color = guide_legend(order = 2), linetype = guide_legend(order = 2)) + - scale_alpha_manual(breaks = c("95% probability", "80% probability", "50% probability"), values = c(0.1, 0.2, 0.3)) + - scale_color_manual(breaks = c("10% contour", "max or min"), values = c("grey50", "grey70")) + - scale_linetype_manual(breaks = c("10% contour", "max or min"), values = c("dashed", "dotted")) + - labs(x = heightXlabel, y = "departure from mean DBH, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[3] != "") { bquote(.(titleLetters[3])~.(speciesLabel)) } else { NULL }) + - #labs(x = heightXlabel, y = "departure from mean DBH, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[3] != "") { bquote(bold(.(titleLetters[3]))~.(speciesLabel)) } else { NULL }) + - theme(legend.justification = c(1, 1), legend.position = distributionLegendPosition, legend.position.inside = c(1, distributionLegendPositionY)) + + geom_ribbon(aes(x = heightClass, ymin = 100 * (q025 - mean) / mean^dbhPower, ymax = 100 * (q975 - mean) / mean^dbhPower, alpha = "95% probability"), fill = "burlywood4") + + geom_ribbon(aes(x = heightClass, ymin = 100 * (q10 - mean) / mean^dbhPower, ymax = 100 * (q90 - mean) / mean^dbhPower, alpha = "80% probability"), fill = "burlywood4") + + geom_ribbon(aes(x = heightClass, ymin = 100 * (q25 - mean) / mean^dbhPower, ymax = 100 * (q75 - mean) / mean^dbhPower, alpha = "50% probability"), fill = "burlywood4") + + geom_path(aes(x = heightClass, y = 100 * (min - mean) / mean^dbhPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + + #geom_path(aes(x = heightClass, y = 100 * (q10 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = heightClass, y = 100 * (q20 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = heightClass, y = 100 * (q30 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = heightClass, y = 100 * (q40 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_segment(x = 0, xend = 77.5, y = 0, yend = 0, color = "burlywood4", linewidth = 0.4) + + geom_path(aes(x = heightClass, y = 100 * (q60 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = heightClass, y = 100 * (q70 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = heightClass, y = 100 * (q80 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + #geom_path(aes(x = heightClass, y = 100 * (q90 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + + geom_path(aes(x = heightClass, y = 100 * (max - mean) / mean^dbhPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + + coord_cartesian(xlim = c(0, 80), ylim = c(-50, 150)) + + guides(alpha = guide_legend(order = 1, override.aes = list(fill = "grey30")), color = guide_legend(order = 2), linetype = guide_legend(order = 2)) + + scale_alpha_manual(breaks = c("95% probability", "80% probability", "50% probability"), values = c(0.1, 0.2, 0.3)) + + scale_color_manual(breaks = c("10% contour", "max or min"), values = c("grey50", "grey70")) + + scale_linetype_manual(breaks = c("10% contour", "max or min"), values = c("dashed", "dotted")) + + labs(x = heightXlabel, y = "departure from mean DBH, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[3] != "") { bquote(.(titleLetters[3])~.(speciesLabel)) } else { NULL }) + + #labs(x = heightXlabel, y = "departure from mean DBH, %", alpha = NULL, color = NULL, linetype = NULL, title = if (titleLetters[3] != "") { bquote(bold(.(titleLetters[3]))~.(speciesLabel)) } else { NULL }) + + theme(legend.justification = c(1, 1), legend.position = distributionLegendPosition, legend.position.inside = c(1, distributionLegendPositionY)) + plot_layout(nrow = 1, ncol = 3, widths = c(260, 200, 200)) return(exploratoryPlots) } @@ -1511,70 +1519,70 @@ plot_qq = function(diameterRegression1, diameterRegression2, diameterRegression3 heightColors = viridis::viridis_pal(option = "plasma", end = 0.9)(4) dbhColors = viridis::viridis_pal(end = 0.9)(4) qqPlot = ggplot() + - geom_qq_line(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.4) + - geom_qq_line(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.4) + - geom_qq_line(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.4) + - geom_qq_line(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.4) + - geom_qq(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.8, geom = "line") + - geom_qq(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.8, geom = "line") + - geom_qq(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.8, geom = "line") + - geom_qq(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.8, geom = "line") + - annotate("text", x = -10.5, y = 160, label = paste0("'a) ", speciesName, " height, '*epsilon~'~'~'N(0, '*sigma*'²)'"), hjust = 0, parse = TRUE, size = 3.4) + - coord_cartesian(xlim = c(-10, 13), ylim = c(-110, 160)) + - labs(x = NULL, y = "sample quantile", color = NULL) + - scale_color_manual(values = heightColors) + - theme(legend.key.height = unit(0.8, "line"), legend.justification = c(1, 0), legend.position.inside = c(1, 0.03)) + + geom_qq_line(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.4) + + geom_qq_line(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.4) + + geom_qq_line(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.4) + + geom_qq_line(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.4) + + geom_qq(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.8, geom = "line") + + geom_qq(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.8, geom = "line") + + geom_qq(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.8, geom = "line") + + geom_qq(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.8, geom = "line") + + annotate("text", x = -10.5, y = 160, label = paste0("'a) ", speciesName, " height, '*epsilon~'~'~'N(0, '*sigma*'²)'"), hjust = 0, parse = TRUE, size = 3.4) + + coord_cartesian(xlim = c(-10, 13), ylim = c(-110, 160)) + + labs(x = NULL, y = "sample quantile", color = NULL) + + scale_color_manual(values = heightColors) + + theme(legend.key.height = unit(0.8, "line"), legend.justification = c(1, 0), legend.position.inside = c(1, 0.03)) + ggplot() + - geom_qq_line(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.4) + - geom_qq_line(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.4) + - geom_qq_line(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.4) + - geom_qq_line(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.4) + - geom_qq(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.8, geom = "line") + - geom_qq(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.8, geom = "line") + - geom_qq(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.8, geom = "line") + - geom_qq(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.8, geom = "line") + - annotate("text", x = -10.5, y = 160, label = paste0("'b) ", speciesName, " DBH, '*epsilon~'~'~'N(0, '*sigma*'²)'"), hjust = 0, parse = TRUE, size = 3.4) + - coord_cartesian(xlim = c(-10, 16.5), ylim = c(-110, 160)) + - labs(x = NULL, y = NULL, color = NULL) + - scale_color_manual(values = dbhColors) + - theme(legend.key.height = unit(0.8, "line"),legend.justification = c(1, 0), legend.position.inside = c(1, 0.03)) + + geom_qq_line(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.4) + + geom_qq_line(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.4) + + geom_qq_line(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.4) + + geom_qq_line(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.4) + + geom_qq(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.8, geom = "line") + + geom_qq(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.8, geom = "line") + + geom_qq(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.8, geom = "line") + + geom_qq(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.8, geom = "line") + + annotate("text", x = -10.5, y = 160, label = paste0("'b) ", speciesName, " DBH, '*epsilon~'~'~'N(0, '*sigma*'²)'"), hjust = 0, parse = TRUE, size = 3.4) + + coord_cartesian(xlim = c(-10, 16.5), ylim = c(-110, 160)) + + labs(x = NULL, y = NULL, color = NULL) + + scale_color_manual(values = dbhColors) + + theme(legend.key.height = unit(0.8, "line"),legend.justification = c(1, 0), legend.position.inside = c(1, 0.03)) + ggplot() + - geom_qq_line(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + - geom_qq_line(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + - geom_qq_line(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + - geom_qq_line(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + - geom_qq(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + - geom_qq(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + - geom_qq(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + - geom_qq(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + - annotate("text", x = -10.5, y = 160, label = paste0("'c) ", speciesName, " height, '*epsilon~'~'~'t(df = ", tDegreesOfFreedom, ")'"), hjust = 0, parse = TRUE, size = 3.4) + - coord_cartesian(xlim = c(-10, 13), ylim = c(-110, 160)) + - labs(x = "theoretical quantile", y = "sample quantile", color = NULL) + - scale_color_manual(values = heightColors) + - theme(legend.justification = c(1, 0), legend.position = "none") + + geom_qq_line(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + + geom_qq_line(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + + geom_qq_line(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + + geom_qq_line(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.4, distribution = qt, dparams = list(df = tDegreesOfFreedom)) + + geom_qq(aes(sample = -residuals(diameterRegression1), color = diameterRegression1$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + + geom_qq(aes(sample = -residuals(diameterRegression2), color = diameterRegression2$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + + geom_qq(aes(sample = -residuals(diameterRegression3), color = diameterRegression3$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + + geom_qq(aes(sample = -residuals(diameterRegression4), color = diameterRegression4$name), alpha = 0.8, distribution = qt, dparams = list(df = tDegreesOfFreedom), geom = "line") + + annotate("text", x = -10.5, y = 160, label = paste0("'c) ", speciesName, " height, '*epsilon~'~'~'t(df = ", tDegreesOfFreedom, ")'"), hjust = 0, parse = TRUE, size = 3.4) + + coord_cartesian(xlim = c(-10, 13), ylim = c(-110, 160)) + + labs(x = "theoretical quantile", y = "sample quantile", color = NULL) + + scale_color_manual(values = heightColors) + + theme(legend.justification = c(1, 0), legend.position = "none") + ggplot() + # qst()'s omega (scale) parameter can be left as 1 as its only effect is rotation, xi (location) can be left as zero as its only effect is a translation in theoretical quantile - geom_qq_line(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + - geom_qq_line(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + - geom_qq_line(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + - geom_qq_line(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + - geom_qq(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + - geom_qq(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + - geom_qq(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + - geom_qq(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + - annotate("text", x = -10.5, y = 160, label = paste0("'d) ", speciesName, " DBH, '*epsilon~'~'~'t(df = ", tDegreesOfFreedom, ", '*alpha*' = ", tSkew, ")'"), hjust = 0, parse = TRUE, size = 3.4) + - coord_cartesian(xlim = c(-10, 16.5), ylim = c(-110, 160)) + - labs(x = "theoretical quantile", y = NULL, color = NULL) + - scale_color_manual(values = dbhColors) + - theme(legend.justification = c(1, 0), legend.position = "none") + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + - plot_layout(nrow = 2, ncol = 2, widths = c(10 + 13, 10 + 16.5)) + geom_qq_line(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + + geom_qq_line(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + + geom_qq_line(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + + geom_qq_line(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.4, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0)) + + geom_qq(aes(sample = -residuals(heightRegression1), color = heightRegression1$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + + geom_qq(aes(sample = -residuals(heightRegression2), color = heightRegression2$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + + geom_qq(aes(sample = -residuals(heightRegression3), color = heightRegression3$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + + geom_qq(aes(sample = -residuals(heightRegression4), color = heightRegression4$name), alpha = 0.8, distribution = sn::qst, dparams = list(nu = tDegreesOfFreedom, alpha = tSkew, omega = 1, xi = 0), geom = "line") + + annotate("text", x = -10.5, y = 160, label = paste0("'d) ", speciesName, " DBH, '*epsilon~'~'~'t(df = ", tDegreesOfFreedom, ", '*alpha*' = ", tSkew, ")'"), hjust = 0, parse = TRUE, size = 3.4) + + coord_cartesian(xlim = c(-10, 16.5), ylim = c(-110, 160)) + + labs(x = "theoretical quantile", y = NULL, color = NULL) + + scale_color_manual(values = dbhColors) + + theme(legend.justification = c(1, 0), legend.position = "none") + + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + + plot_layout(nrow = 2, ncol = 2, widths = c(10 + 13, 10 + 16.5)) return(qqPlot) } ## load data # Notable properties of cruise data loaded into trees2016 -# - Plots are either count plots, where trees aren't measured, or count plots, where all trees and snags are measured +# - Plots are either count plots, where trees aren't measured, or measure plots, where all trees and snags are measured # for DBH and a subset measured for height. Thus, all stems with heights (TotalHt if unbroke, Ht2 if broken) are # also have DBH measurements. # - Trees are on CO (count) and IP (measure) plots. Count plots are variable radius and count trees by species. @@ -1584,34 +1592,91 @@ plot_qq = function(diameterRegression1, diameterRegression2, diameterRegression3 # - Trees on variable radius measure plots generally have TreeCount = 1, as expected, but 462 records have TreeCount # = 2. Since it's very unlikely two trees are on the same plot with the same DBH and, often, the same height, these # records are assumed to be incorrect and the tree count is changed to one. -stands2022 = read_xlsx("GIS/Planning/Elliott Stand Data Feb2022.xlsx") %>% - mutate(Cruised_Si = na_if(Cruised_Si, 0), - ODSL_Site_ = na_if(ODSL_Site_, 0), - siteSpecies = if_else(startsWith(ODSL_VEG_L, "1W") | startsWith(ODSL_VEG_L, "WX"), "hemlock", - if_else(startsWith(ODSL_VEG_L, "1H") | startsWith(ODSL_VEG_L, "HX"), "hardwood", - if_else(startsWith(ODSL_VEG_L, "OT"), "other", - "Douglas-fir"))), - standAge2016 = pmax(if_else((Age_2020 - 4) > (Age_2015 + 1), Age_2015 + 1, Age_2020 - 4), 0), - standArea = 0.404686 * GrossAc, # ac to ha - isPlantation = standAge2016 < 70) -plots2016 = read_xlsx("GIS/Trees/2015-16 cruise/CruisePlots_All_20151211.xlsx") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 -trees2016 = left_join(left_join(read_xlsx("trees/Elliott final cruise records 2015-16.xlsx", sheet = "CRUISERECS"), - stands2022 %>% select(StandID, standAge2016, standArea, isPlantation), - by = c("StandID")), - plots2016 %>% select(STAND, PltInteger, elevation, slope, aspect, topographicShelterIndex, x, y) %>% rename(PlotID = PltInteger), - by = c("PlotID")) %>% - mutate(speciesGroup = factor(if_else(Species %in% c("DF", "RA", "WH", "BM", "OM", "RC"), Species, "other"), levels = c("DF", "RA", "WH", "BM", "OM", "RC", "other")), - BHAge = na_if(BHAge, 0), # years +#stands2022 = read_xlsx("GIS/Planning/Elliott Stand Data Feb2022.xlsx") %>% +#mutate(Cruised_Si = na_if(Cruised_Si, 0), +#ODSL_Site_ = na_if(ODSL_Site_, 0), +#siteSpecies = if_else(startsWith(ODSL_VEG_L, "1W") | startsWith(ODSL_VEG_L, "WX"), "hemlock", +#if_else(startsWith(ODSL_VEG_L, "1H") | startsWith(ODSL_VEG_L, "HX"), "hardwood", +#if_else(startsWith(ODSL_VEG_L, "OT"), "other", +#"Douglas-fir"))), +#standAge2016 = pmax(if_else((Age_2020 - 4) > (Age_2015 + 1), Age_2015 + 1, Age_2020 - 4), 0), +#standArea = 0.404686 * GrossAc, # ac to ha +#isPlantation = standAge2016 < 70) + +#plots2016 = read_xlsx("GIS/Trees/2015-16 cruise/CruisePlots_All_20151211.xlsx") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 + +#trees2016 = left_join(left_join(read_xlsx("trees/Elliott final cruise records 2015-16.xlsx", sheet = "CRUISERECS"), +#stands2022 %>% select(StandID, standAge2016, standArea, isPlantation), +#by = c("StandID")), +#plots2016 %>% select(STAND, PltInteger, elevation, slope, aspect, topographicShelterIndex, x, y) %>% rename(PlotID = PltInteger), +#by = c("PlotID")) %>% +#mutate(speciesGroup = factor(if_else(Species %in% c("DF", "RA", "WH", "BM", "OM", "RC"), Species, "other"), levels = c("DF", "RA", "WH", "BM", "OM", "RC", "other")), +#BHAge = na_if(BHAge, 0), # years +#DBH = na_if(2.54 * DBH, 0), # inches to cm +#Dia1 = na_if(2.54 * Dia1, 0), +#CrownRatio = na_if(CrownRatio, 0), +#Ht1 = na_if(0.3048 * Ht1, 0), # feet to m +#Ht2 = na_if(0.3048 * Ht2, 0), +#isConifer = Species %in% c("DF", "WH", "RC", "SS", "CX", "PC", "PY", "GF", "LP"), +#isLive = (CompCode %in% c("D.", "SN")) == FALSE, +#isLiveUnbroken = isLive & (CompCode != "BT"), +#plotRadius = if_else(SamplingMethod == "BAF", 100 / 2.54 * 0.3048 / (12 * sqrt(SampleFactor / 10890)), 0.3048 * sqrt(43560 / (pi * SampleFactor))), # m +#SampleFactor = 2.47105 * if_else(SamplingMethod == "BAF", 0.092903, 1) * SampleFactor, # convert BAF from ft²/ac to m²/ha and TPA to TPH, BAF conversion is BAF ft²/ac * 2.47105 ac/ha * 0.092903 m²/ft² = 0.229568 m²/ha / ft²/ac +#TotalHt = na_if(0.3048 * TotalHt, 0), +#TreeCount = if_else((PlotType == "IP") & (SamplingMethod == "BAF") & (TreeCount > 1), 1, TreeCount), # fix tree duplication per notes above +#basalArea = 0.25 * pi * (0.01*DBH)^2, # m² +#breastHeight = 1.37, # m, used for offset in lm() height regressions +#heightDiameterRatio = TotalHt / (0.01 * DBH), # (DBH conversion from cm to m) +#imputedHeight = if_else(is.na(TotalHt) == FALSE, TotalHt, if_else(is.na(DBH) == FALSE, impute_height(Species, DBH, isPlantation), NA_real_)), # where possible, perform basic height imputation +#treeBasalAreaPerHectare = SampleFactor * TreeCount * if_else(SamplingMethod == "BAF", 1, basalArea)) %>% # m²/ha, measure plots have TreeCount = 1 for each tree, count plots have TreeCount = 0-41 depending on the number of trees present +#group_by(StandID) %>% + +######### --------- FUNCTIONS END -----------##### + +stands2022 = read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desktop\Winter 2025\FOR 599\Elliott_stands_2015-16.csv)")%>% + mutate(standAge2016=standAge2015+1, + isPlantation = standAge2016 < 70) +#%>% +#mutate(Cruised_Si = na_if(Cruised_Si, 0), +#ODSL_Site_ = na_if(ODSL_Site_, 0), +#siteSpecies = if_else(startsWith(ODSL_VEG_L, "1W") | startsWith(ODSL_VEG_L, "WX"), "hemlock", +#if_else(startsWith(ODSL_VEG_L, "1H") | startsWith(ODSL_VEG_L, "HX"), "hardwood", +#if_else(startsWith(ODSL_VEG_L, "OT"), "other", +#"Douglas-fir"))), +#standAge2016 = pmax(if_else((Age_2020 - 4) > (Age_2015 + 1), Age_2015 + 1, Age_2020 - 4), 0), +#standArea = 0.404686 * GrossAc, # ac to ha +#isPlantation = standAge2016 < 70) +head(stands2022) + +plots2016 = read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desktop\Winter 2025\FOR 599\Elliott_timber_cruise_2015-16.csv)") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 +head(plots2016) +#trees2016 = left_join(left_join(read.csv("Elliott_timber_cruise_2015-16.csv", sheet = "Elliott_timber_cruise_2015-16"), +#stands2022 %>% select(standID, standAge2016, areaHa, isPlantation), +# by = c("standID")), +#plots2016 %>% select(standID, plotID, elevation, slope, aspect, topographicShelterIndex, x, y) %>% rename(plotID = PltInteger), +#by = c("plotID")) +trees2016 = left_join(read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desktop\Winter 2025\FOR 599\Elliott_timber_cruise_2015-16.csv)"), + stands2022 %>% select(standID, standAge2016, areaHa, isPlantation), + by = "standID") %>% # removed the second part of the join because it was not relevant + rename(Species=species,TotalHt=totalHt,TreeCount=treeCount,PlotID=plotID,StandID=standID,SamplingMethod=samplingMethod,CompCode=condition,CrownRatio=crownRatio,Ht1=taperHt,Dia1=taperDiameter,standArea=areaHa)%>% # renamed columns to match further analysis, this code was added to match variable names. + mutate(SamplingMethod = ifelse(SamplingMethod == "VRP", "BAF", SamplingMethod))%>% + mutate(speciesGroup = factor(if_else(Species %in% c("PSME", "ALRU2", "TSHE","ACMA3", "UMCA", "THPL"), Species, "other"), levels=c("PSME", "ALRU2", "TSHE","ACMA3", "UMCA", "THPL", "other"),labels = c("DF", "RA", "WH", "BM", "OM", "RC", "other")), + #mutate(speciesGroup = factor(if_else(Species %in% c("DF", "RA", "WH", "BM", "OM", "RC"), Species, "other"), levels = c("DF", "RA", "WH", "BM", "OM", "RC", "other")), + PlotType=case_when(plotType=="count"~"CO", #convert plot type "count" and "measure" to "CO" and "IP" respectively + plotType == "measure" ~ "IP", + TRUE ~ NA_character_), + BHAge = na_if(breastHeightAge, 0), # years DBH = na_if(2.54 * DBH, 0), # inches to cm Dia1 = na_if(2.54 * Dia1, 0), CrownRatio = na_if(CrownRatio, 0), Ht1 = na_if(0.3048 * Ht1, 0), # feet to m - Ht2 = na_if(0.3048 * Ht2, 0), - isConifer = Species %in% c("DF", "WH", "RC", "SS", "CX", "PC", "PY", "GF", "LP"), - isLive = (CompCode %in% c("D.", "SN")) == FALSE, - isLiveUnbroken = isLive & (CompCode != "BT"), + Ht2 = na_if(0.3048 * htToBrokenTop, 0), + isConifer = Species %in% c("PSME", "TSHE", "THPL"), + isLive = (CompCode %in% c("deadStanding", "snag")) == FALSE, + isLiveUnbroken = isLive & (CompCode != "brokenTop"), + SampleFactor=0.229568, #added sample factor plotRadius = if_else(SamplingMethod == "BAF", 100 / 2.54 * 0.3048 / (12 * sqrt(SampleFactor / 10890)), 0.3048 * sqrt(43560 / (pi * SampleFactor))), # m SampleFactor = 2.47105 * if_else(SamplingMethod == "BAF", 0.092903, 1) * SampleFactor, # convert BAF from ft²/ac to m²/ha and TPA to TPH, BAF conversion is BAF ft²/ac * 2.47105 ac/ha * 0.092903 m²/ft² = 0.229568 m²/ha / ft²/ac TotalHt = na_if(0.3048 * TotalHt, 0), @@ -1622,7 +1687,7 @@ trees2016 = left_join(left_join(read_xlsx("trees/Elliott final cruise records 20 imputedHeight = if_else(is.na(TotalHt) == FALSE, TotalHt, if_else(is.na(DBH) == FALSE, impute_height(Species, DBH, isPlantation), NA_real_)), # where possible, perform basic height imputation treeBasalAreaPerHectare = SampleFactor * TreeCount * if_else(SamplingMethod == "BAF", 1, basalArea)) %>% # m²/ha, measure plots have TreeCount = 1 for each tree, count plots have TreeCount = 0-41 depending on the number of trees present group_by(StandID) %>% - arrange(desc(isLiveUnbroken), desc(DBH), .by_group = TRUE) %>% # put largest diameter live trees first in each stand for calculating BAL (numbers sort before NA) + arrange(desc(isLiveUnbroken), desc(DBH), .by_group = TRUE) %>%# put largest diameter live trees first in each stand for calculating BAL (numbers sort before NA) mutate(plotsInStand = length(unique(PlotID)), # nested fixed radius and BAF plots share same plot ID standBasalAreaPerHectare = sum(isLive * treeBasalAreaPerHectare) / plotsInStand, # m²/ha basalAreaLarger = (cumsum(isLive * treeBasalAreaPerHectare) - treeBasalAreaPerHectare[1]) / plotsInStand, # m²/ha @@ -1636,12 +1701,12 @@ trees2016 = left_join(left_join(read_xlsx("trees/Elliott final cruise records 20 # top height by tallest trees in stand, regardless of plot #arrange(desc(isLiveUnbroken), desc(TotalHt), .by_group = TRUE) %>% # put tallest live trees without broken tops first in each stand #mutate(topHeightTph = pmin(cumsum(if_else(is.na(TotalHt), 0, measureTreeTphContribution)), 100), # TPH total towards the H100 definition of top height, trees not measured for TotalHt are skipped - # topHeightWeight = pmax((topHeightTph - lag(topHeightTph, default = 0)) / measureTreeTphContribution, 0), # clamp remaining fraction to [0, 1] to get individual trees' contributions to the top height average - # topHeight = sum(topHeightWeight * TotalHt, na.rm = TRUE) / sum(topHeightWeight, na.rm = TRUE), # m, tallest 100 trees per hectare - # relativeHeight = TotalHt / topHeight, # individual trees' heights as a fraction of top height, may be greater than 1, especially for retention trees (debatable if imputed heights should be included but, for now, trees not measured for height are left with NA relative height) - # tallerApproxBasalArea = (cumsum(isLive * treeBasalAreaPerHectareApprox) - treeBasalAreaPerHectareApprox[1]) / plotsInStand, - # tallerTph = cumsum(isLiveUnbroken * SampleFactor * TreeCount * if_else(SamplingMethod == "BAF", 1 / basalArea, 1)) / plotsInStand) %>% - # top height by estimating H100 on each plot and then averaging all plots (slower than pooling by stand) + #topHeightWeight = pmax((topHeightTph - lag(topHeightTph, default = 0)) / measureTreeTphContribution, 0), # clamp remaining fraction to [0, 1] to get individual trees' contributions to the top height average + #topHeight = sum(topHeightWeight * TotalHt, na.rm = TRUE) / sum(topHeightWeight, na.rm = TRUE), # m, tallest 100 trees per hectare + #relativeHeight = TotalHt / topHeight, # individual trees' heights as a fraction of top height, may be greater than 1, especially for retention trees (debatable if imputed heights should be included but, for now, trees not measured for height are left with NA relative height) + #tallerApproxBasalArea = (cumsum(isLive * treeBasalAreaPerHectareApprox) - treeBasalAreaPerHectareApprox[1]) / plotsInStand, + #tallerTph = cumsum(isLiveUnbroken * SampleFactor * TreeCount * if_else(SamplingMethod == "BAF", 1 / basalArea, 1)) / plotsInStand) #%>% + #top height by estimating H100 on each plot and then averaging all plots (slower than pooling by stand) group_by(StandID, PlotID, isLiveUnbroken) %>% arrange(desc(TotalHt), .by_group = TRUE) %>% mutate(topHeightTph = if_else(isLiveUnbroken, pmin(cumsum(if_else(is.na(TotalHt), 0, measureTreeTphContribution)), 100), NA_real_), @@ -1658,20 +1723,21 @@ trees2016 = left_join(left_join(read_xlsx("trees/Elliott final cruise records 20 tallerApproxBasalArea = (cumsum(isLive * treeBasalAreaPerHectareApprox) - treeBasalAreaPerHectareApprox[1]) / plotsInStand, tallerTph = cumsum(isLiveUnbroken * SampleFactor * TreeCount * if_else(SamplingMethod == "BAF", 1 / basalArea, 1)) / plotsInStand) %>% ungroup() +head(trees2016) heightClassBreaks = trees2016 %>% filter(isLiveUnbroken, is.na(TotalHt) == FALSE) %>% group_by(speciesGroup) %>% group_modify(~{ - quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10))) # constrain maximum number of classes based on data availability: setting the max to n / (meanClassN*k) classes averages meanClassN samples per class in validation folds => primarily affects low n species: Oregon myrtle, western redcedar, and other - return(tibble(heightBreaks = unique(ceiling(c(0, quantile(.$TotalHt, probs = quantileBreaks, na.rm = TRUE)))))) - }) %>% + quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10))) # constrain maximum number of classes based on data availability: setting the max to n / (meanClassN*k) classes averages meanClassN samples per class in validation folds => primarily affects low n species: Oregon myrtle, western redcedar, and other + return(tibble(heightBreaks = unique(ceiling(c(0, quantile(.$TotalHt, probs = quantileBreaks, na.rm = TRUE)))))) + }) %>% unstack(heightBreaks ~ speciesGroup) # list of height class breaks, named by species dbhClassBreaks = trees2016 %>% filter(isLiveUnbroken, DBH > 2.54 * 3.5) %>% group_by(speciesGroup) %>% group_modify(~{ - quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10) - 3)) - return(tibble(dbhBreaks = unique(c(2.5 * c(0, 1.5, 2.5, 3.5), 2.5 * ceiling(quantile(.$DBH, probs = quantileBreaks, na.rm = TRUE) / 2.5) + 0.5 * 2.5)))) - }) %>% + quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10) - 3)) + return(tibble(dbhBreaks = unique(c(2.5 * c(0, 1.5, 2.5, 3.5), 2.5 * ceiling(quantile(.$DBH, probs = quantileBreaks, na.rm = TRUE) / 2.5) + 0.5 * 2.5)))) + }) %>% unstack(dbhBreaks ~ speciesGroup) # list of DBH class breaks, named by species trees2016 %<>% group_by(speciesGroup) %>% @@ -1679,8 +1745,7 @@ trees2016 %<>% group_by(speciesGroup) %>% dbhClass = cut(DBH, breaks = dbhClassBreaks[[cur_group()$speciesGroup]], labels = 0.5 * (head(dbhClassBreaks[[cur_group()$speciesGroup]], -1) + tail(dbhClassBreaks[[cur_group()$speciesGroup]], -1)))) %>% ungroup() -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { # plots without spatial locations print(trees2016 %>% filter(is.na(elevation)) %>% group_by(PlotID) %>% summarize(trees = n(), .groups = "drop"), n = 51) # distribution of estimated stand basal areas @@ -1691,7 +1756,7 @@ if (htDiaOptions$includeInvestigatory) # remainingFraction = (treeTphContribution + remainingTph) / treeTphContribution, # weight = if_else(remainingFraction >= 1, 1, if_else(remainingFraction > 0, remainingFraction, 0))), # n = 40) - + # check plots for calculated stand-level quantities: BA, TPH, QMD, H100 standsFromTrees2016 = trees2016 %>% group_by(StandID) %>% summarize(plots = plotsInStand[1], measurePlots = measurePlotsInStand[1], meanTreesPerBafPlot = meanTreesPerBafPlot[1], meanTreesPerBafMeasurePlot = meanTreesPerBafMeasurePlot[1], @@ -1707,29 +1772,29 @@ if (htDiaOptions$includeInvestigatory) geom_point(aes(x = plots, y = measurePlots), standsFromTrees2016, alpha = 0.2, color = "grey25", shape = 16) + coord_cartesian(xlim = c(0, 90)) + labs(x = "plots", y = "measure plots") + - ggplot() + + ggplot() + geom_segment(aes(x = 0, y = 0, xend = 120, yend = 120), color = "grey80", linewidth = 0.3, linetype = "longdash") + geom_point(aes(x = standBasalAreaPerHectare, y = standBasalAreaApprox), standsFromTrees2016, alpha = 0.2, color = "grey25", shape = 16) + coord_cartesian(xlim = c(0, 120)) + labs(x = bquote("basal area, m"^2*" ha"^-1), y = bquote("approximate basal area, m"^2*" ha"^-1)) + - ggplot() + + ggplot() + geom_segment(aes(x = 0, y = 0, xend = 10, yend = 10), color = "grey80", linewidth = 0.3, linetype = "longdash") + geom_point(aes(x = meanTreesPerBafPlot, y = meanTreesPerBafMeasurePlot), standsFromTrees2016, alpha = 0.2, color = "grey25", shape = 16) + #coord_cartesian(xlim = c(0, 120)) + labs(x = "mean trees per BAF plot", y = "mean trees per BAF measure plot") + - ggplot() + + ggplot() + geom_line(aes(x = tph, y = qmd, group = sdi), reinekeSdi, color = "grey80", linewidth = 0.3, linetype = "longdash") + geom_point(aes(x = tph, y = qmd), standsFromTrees2016, alpha = 0.5, shape = 16) + coord_cartesian(xlim = c(50, 5000), ylim = c(5, 95)) + labs(x = "TPH", y = "QMD, cm") + scale_x_log10(breaks = c(50, 100, 200, 500, 1000, 5000), minor_breaks = c(60, 70, 80, 90, 300, 400, 600, 700, 800, 900, 2000, 3000, 4000, 6000, 7000)) + scale_y_log10(breaks = c(5, 10, 20, 50, 100), minor_breaks = c(6, 7, 8, 9, 30, 40, 60, 70, 80, 90)) + - ggplot() + + ggplot() + geom_histogram(aes(y = topHeight), standsFromTrees2016, binwidth = 2) + labs(x = "stands", y = bquote("H"[100]*", m")) + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout(nrow = 2, ncol = 3) - + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout(nrow = 2, ncol = 3) + # check plots for tree-level properties derived from stand-level properties ggplot() + geom_segment(aes(x = 1.5, y = 0, xend = 1.5, yend = 3000), color = "grey80", linewidth = 0.3, linetype = "longdash") + @@ -1738,27 +1803,27 @@ if (htDiaOptions$includeInvestigatory) labs(x = "relative height", y = "trees measured", fill = NULL) + scale_fill_manual(breaks = levels(trees2016$speciesGroup), limits = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) + theme(legend.justification = c(1, 1), legend.position.inside = c(1, 1)) + - ggplot() + + ggplot() + geom_segment(aes(x = 5.4, y = 0, xend = 5.4, yend = 3000), color = "grey80", linewidth = 0.3, linetype = "longdash") + geom_histogram(aes(x = relativeDiameter, fill = speciesGroup), trees2016, binwidth = 0.05, na.rm = TRUE) + coord_cartesian(xlim = c(0, 7.5), ylim = c(0, 2500)) + labs(x = "relative diameter", y = "trees measured", fill = NULL) + scale_fill_manual(breaks = levels(trees2016$speciesGroup), limits = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) + theme(legend.position = "none") + - ggplot() + + ggplot() + geom_segment(aes(x = 0, y = 0, xend = 125, yend = 125), color = "grey80", linewidth = 0.3, linetype = "longdash") + geom_point(aes(x = standBasalAreaPerHectare, y = basalAreaLarger, color = speciesGroup), trees2016, alpha = 0.2, shape = 16) + guides(color = "none") + labs(x = bquote("stand basal area, m"^2*" ha"^-1), y = bquote("basal area larger, m"^2*" ha"^-1), color = NULL) + scale_color_manual(breaks = levels(trees2016$speciesGroup), limits = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) + - ggplot() + + ggplot() + geom_segment(aes(x = 0, y = 0, xend = 180, yend = 180), color = "grey80", linewidth = 0.3, linetype = "longdash") + geom_point(aes(x = standBasalAreaApprox, y = tallerApproxBasalArea, color = speciesGroup), trees2016, alpha = 0.2, shape = 16) + guides(color = "none") + labs(x = bquote("approximate stand basal area, m"^2*" ha"^-1), y = bquote("basal area taller, m"^2*" ha"^-1), color = NULL) + scale_color_manual(breaks = levels(trees2016$speciesGroup), limits = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout(nrow = 2, ncol = 2) + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout(nrow = 2, ncol = 2) # correlations among predictors predictorLabels = c("DBH", "height", "height:diameter", "stand age", "BA", "BAL", "ABA", "AAT", "elevation", "slope", "sin(aspect)", "cos(aspect)", "TSI", "H100", "RelHt", "QMD", "RelDbh") @@ -1778,7 +1843,7 @@ if (htDiaOptions$includeInvestigatory) scale_y_discrete(limits = rev) + theme(axis.text.x = element_text(angle = 90, hjust = 1), legend.spacing.y = unit(0.5, "line"), strip.background = element_rect(fill = "grey95")) print(predictorCorrelation %>% filter(predictor1 %in% c("DBH", "height", "height:diameter", "BA", "ABA"), predictor2 %in% c("DBH", "height", "height:diameter")) %>% - pivot_wider(names_from = "predictor2", values_from = "correlation"), n = 21) + pivot_wider(names_from = "predictor2", values_from = "correlation"), n = 21) print(predictorCorrelation %>% filter(predictor1 %in% c("DBH"), predictor2 %in% c("BA", "ABA")) %>% pivot_wider(names_from = "predictor2", values_from = "correlation"), n = 21) @@ -1822,33 +1887,55 @@ if (htDiaOptions$includeInvestigatory) # export stand properties, including 2016 inventory where available # trees.R needs areas for all stands, so join cruised stands with all stands defined for 2016 inventory. - #write_xlsx(list(stands = left_join(stands2022 %>% mutate(StandID = as.integer(StandID)) %>% select(StandID, standAge2016, standArea, isPlantation), - # trees2016 %>% group_by(StandID) %>% - # summarize(standAge2016 = standAge2016[1], - # isPlantation = isPlantation[1], - # standArea = standArea[1], - # plotsInStand = plotsInStand[1], - # measurePlotsInStand = measurePlotsInStand[1], - # tph = tph[1], - # topHeight = topHeight[1], - # qmd = qmd[1], - # standBasalAreaPerHectare = standBasalAreaPerHectare[1], - # standBasalAreaApprox = standBasalAreaApprox[1]) %>% - # mutate(StandID = as.integer(StandID)), - # by = "StandID") %>% - # mutate(standAge2016 = if_else(is.na(standAge2016.x), standAge2016.y, standAge2016.x), - # standArea = if_else(is.na(standArea.x), standArea.y, standArea.x), - # isPlantation = if_else(is.na(isPlantation.x), isPlantation.y, isPlantation.x)) %>% - # select(-standArea.x, -standArea.y, -standAge2016.x, -standAge2016.y, -isPlantation.x, -isPlantation.y) %>% - # rename(standID2016 = StandID) %>% - # relocate(standID2016, standAge2016, standArea, isPlantation)), - # "GIS/Trees/2015-16 cruise.xlsx") + # write_xlsx(list(stands = left_join(stands2022 %>% mutate(StandID = as.integer(StandID)) %>% select(StandID, standAge2016, standArea, isPlantation), + # trees2016 %>% group_by(StandID) %>% + # summarize(standAge2016 = standAge2016[1], + # isPlantation = isPlantation[1], + # standArea = standArea[1], + # plotsInStand = plotsInStand[1], + # measurePlotsInStand = measurePlotsInStand[1], + # tph = tph[1], + # topHeight = topHeight[1], + # qmd = qmd[1], + # standBasalAreaPerHectare = standBasalAreaPerHectare[1], + # standBasalAreaApprox = standBasalAreaApprox[1]) %>% + # mutate("StandID" = as.integer(StandID)), + # by = "StandID") %>% + # mutate(standAge2016 = if_else(is.na(standAge2016.x), standAge2016.y, standAge2016.x), + # standArea = if_else(is.na(standArea.x), standArea.y, standArea.x), + # isPlantation = if_else(is.na(isPlantation.x), isPlantation.y, isPlantation.x)) %>% + # select(-standArea.x, -standArea.y, -standAge2016.x, -standAge2016.y, -isPlantation.x, -isPlantation.y) %>% + # rename(standID2016 = StandID) %>% + # relocate(standID2016, standAge2016, standArea, isPlantation)), + # "C:/Users/hamala/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/2015-16 cruise.xlsx/2015-16 cruise.xlsx") + # } + write_xlsx(list(stands = left_join(stands2022 %>% + rename (standArea=areaHa)%>% + mutate(StandID = as.integer(standID)) %>% + select(StandID, standAge2016, standArea, isPlantation),trees2016 %>%group_by(StandID) %>% + summarize(standAge2016 = standAge2016[1], + isPlantation = isPlantation[1], + standArea = standArea[1], + plotsInStand = plotsInStand[1], + measurePlotsInStand = measurePlotsInStand[1], + tph = tph[1], + topHeight = topHeight[1], + qmd = qmd[1], + standBasalAreaPerHectare = standBasalAreaPerHectare[1], + standBasalAreaApprox = standBasalAreaApprox[1]) %>% + mutate("StandID" = as.integer(StandID)), + by = "StandID") %>% + mutate(standAge2016 = if_else(is.na(standAge2016.x), standAge2016.y, standAge2016.x), + standArea = if_else(is.na(standArea.x), standArea.y, standArea.x), + isPlantation = if_else(is.na(isPlantation.x), isPlantation.y, isPlantation.x)) %>% + select(-standArea.x, -standArea.y, -standAge2016.x, -standAge2016.y, -isPlantation.x, -isPlantation.y) %>% + rename(standID2016 = StandID) %>% + relocate(standID2016, standAge2016, standArea, isPlantation)), + "C:/Users/hamala/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/2015-16 cruise.xlsx") } - ## data tabulation and basic plotting -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { # Table 1 trees2016summary = trees2016 %>% #group_by(Species) %>% @@ -1857,7 +1944,7 @@ if (htDiaOptions$includeInvestigatory) stems = sum(TreeCount), live = sum(TreeCount * isLive), plantation = sum(TreeCount * isLive * isPlantation), - retention = sum(TreeCount * isLive * (CompCode == "RT")), + retention = sum(TreeCount * isLive * (CompCode == "retention")), dbh = sum(TreeCount * isLive * (is.na(DBH) == FALSE), na.rm = TRUE), height = sum(TreeCount * isLive * (is.na(TotalHt) == FALSE), na.rm = TRUE), brokenTop = sum(TreeCount * isLive * (is.na(Ht2) == FALSE), na.rm = TRUE), @@ -1875,10 +1962,10 @@ if (htDiaOptions$includeInvestigatory) arrange(desc(stems)) %>% bind_rows(summarize(., across(where(is.numeric), ~if_else(is.integer(.x), max(.x), sum(.x))))) %>% mutate(speciesGroup = replace_na(as.character(speciesGroup), "total")) - #mutate(Species = replace_na(as.character(Species), "total")) + #mutate(Species = replace_na(as.character(Species), "total")) print(trees2016summary, n = 25) trees2016 %>% group_by(isConifer) %>% summarize(heightMeasureTrees = sum(TreeCount * isLive * (is.na(TotalHt) == FALSE))) - + # plot data summary trees2016 %>% group_by(PlotID) %>% @@ -1898,7 +1985,7 @@ if (htDiaOptions$includeInvestigatory) measureSnags = sum(TreeCount * (isLive == FALSE) * (DBH > 0), na.rm = TRUE), countSnags = sum(TreeCount * (isLive == FALSE) * is.na(DBH))) # measured snags - print(trees2016 %>% filter(CompCode == "RT", isPlantation == FALSE) %>% select(StandID, Species, DBH, standAge2020), n = 35) + print(trees2016 %>% filter(CompCode == "retention", isPlantation == FALSE) %>%mutate(standAge2020=standAge2016+4) %>% select(StandID, Species, DBH, standAge2020), n = 35) # height tree counts by species group trees2016 %>% filter(isLiveUnbroken, is.na(TotalHt) == FALSE) %>% group_by(speciesGroup) %>% @@ -1914,31 +2001,49 @@ if (htDiaOptions$includeInvestigatory) geom_histogram(aes(y = 100 * Ht1 / TotalHt, x = 100 * ..count.. / sum(..count..)), binwidth = 1) + labs(x = "percentage of trees, %", y = "taper measurement's relative height, %") - ggplot(trees2016 %>% filter(CompCode == "OS", BHAge > 0) %>% group_by(StandID) %>% summarize(siteTrees = n())) + + ggplot(trees2016 %>% filter(CompCode == "siteTree", BHAge > 0) %>% group_by(StandID) %>% summarize(siteTrees = n())) + #assuming OS is referring to SiteTree geom_histogram(aes(x = siteTrees, y = 100 * ..count.. / sum(..count..)), binwidth = 1) + labs(x = "site trees", y = "percentage of stands") + scale_x_continuous(breaks = seq(1, 10)) + scale_y_continuous(breaks = seq(0, 100, by = 10)) # ranges of predictor variables - print(liveUnbrokenTrees2016 %>% group_by(speciesGroup) %>% - summarize(quantile = c(0, 0.5, 1), - dbh = quantile(DBH, quantile, na.rm = TRUE), - height = quantile(TotalHt, quantile, na.rm = TRUE), - tph = quantile(tph, quantile, na.rm = TRUE), - ba = quantile(standBasalAreaPerHectare, quantile, na.rm = TRUE), - bal = quantile(basalAreaLarger, quantile, na.rm = TRUE), - aa = quantile(standBasalAreaApprox, quantile, na.rm = TRUE), - aat = quantile(tallerApproxBasalArea, quantile, na.rm = TRUE), - elevation = quantile(elevation, quantile, na.rm = TRUE), - slope = quantile(slope, quantile, na.rm = TRUE), - aspect = quantile(aspect, quantile, na.rm = TRUE), - tsi = quantile(topographicShelterIndex, quantile, na.rm = TRUE), - topHt = quantile(topHeight, quantile, na.rm = TRUE), - relHt = quantile(relativeHeight, quantile, na.rm = TRUE), - .groups = "drop"), - n = 25) - + # print(liveUnbrokenTrees2016 %>% group_by(speciesGroup) %>% + # summarize(quantile = c(0, 0.5, 1), + # dbh = quantile(DBH, quantile, na.rm = TRUE), + # height = quantile(TotalHt, quantile, na.rm = TRUE), + # tph = quantile(tph, quantile, na.rm = TRUE), + # ba = quantile(standBasalAreaPerHectare, quantile, na.rm = TRUE), + # bal = quantile(basalAreaLarger, quantile, na.rm = TRUE), + # aa = quantile(standBasalAreaApprox, quantile, na.rm = TRUE), + # aat = quantile(tallerApproxBasalArea, quantile, na.rm = TRUE), + # elevation = quantile(elevation, quantile, na.rm = TRUE), + # slope = quantile(slope, quantile, na.rm = TRUE), + # aspect = quantile(aspect, quantile, na.rm = TRUE), + # tsi = quantile(topographicShelterIndex, quantile, na.rm = TRUE), + # topHt = quantile(topHeight, quantile, na.rm = TRUE), + # relHt = quantile(relativeHeight, quantile, na.rm = TRUE), + # .groups = "drop"), + # n = 25) + # ranges of predictor variables + liveUnbrokenTrees2016<-trees2016 #assigned liveUnbrokenTrees2016 to trees2016 data frame assuming that this includes trees filtered by, isliveUnbroken and is.na(totalHt)=FALSE) + print(liveUnbrokenTrees2016 %>% group_by(speciesGroup) %>% + summarize(quantile = c(0, 0.5, 1), + dbh = quantile(DBH, quantile, na.rm = TRUE), + height = quantile(TotalHt, quantile, na.rm = TRUE), + tph = quantile(tph, quantile, na.rm = TRUE), + ba = quantile(standBasalAreaPerHectare, quantile, na.rm = TRUE), + bal = quantile(basalAreaLarger, quantile, na.rm = TRUE), + aa = quantile(standBasalAreaApprox, quantile, na.rm = TRUE), + aat = quantile(tallerApproxBasalArea, quantile, na.rm = TRUE), + elevation = quantile(elevation, quantile, na.rm = TRUE), + slope = quantile(slope, quantile, na.rm = TRUE), + aspect = quantile(aspect, quantile, na.rm = TRUE), + tsi = quantile(topographicShelterIndex, quantile, na.rm = TRUE), + topHt = quantile(topHeight, quantile, na.rm = TRUE), + relHt = quantile(relativeHeight, quantile, na.rm = TRUE), + .groups = "drop"), + n = 25) ggplot(trees2016 %>% filter(isLiveUnbroken)) + # lower violin in pair is for plantations geom_violin(aes(x = relativeHeight, y = speciesGroup, color = speciesGroup), draw_quantiles = c(0.25, 0.5, 0.75), na.rm = TRUE) + coord_cartesian(xlim = c(0, 3)) + @@ -1959,82 +2064,80 @@ if (htDiaOptions$includeInvestigatory) geom_bar(aes(x = as.numeric(levels(heightClass))[heightClass], y = 100 * after_stat(count / tapply(count, PANEL, sum)[PANEL]), weight = n)) + # https://stackoverflow.com/questions/68227541/ggplot-geom-bar-plot-percentages-by-group-and-facet-wrap facet_wrap(vars(speciesGroup)) + labs(x = "unbroken height, m", y = "fraction of stems, %", title = "a) height classes") + - ggplot(trees2016classified) + + ggplot(trees2016classified) + geom_bar(aes(x = as.numeric(levels(dbhClass))[dbhClass], y = 100 * after_stat(count / tapply(count, PANEL, sum)[PANEL]), weight = n)) + facet_wrap(vars(speciesGroup)) + labs(x = "DBH, cm", y = "fraction of stems, %", title = "b) DBH classes") + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout() & + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout() & coord_cartesian(ylim = c(0, 10)) - # distribution of count and measure trees by stand - treesByStand2016 = trees2016 %>% group_by(StandID) %>% summarize(count = sum((PlotType == "CO") * TreeCount), - dbhMeasureOnly = sum(((is.na(DBH) == FALSE) & (is.na(TotalHt) & is.na(Ht2))) * TreeCount), - heightAndDbhMeasure = sum(((is.na(TotalHt) == FALSE) | (is.na(Ht2) == FALSE)) * TreeCount), .groups = "drop") - (standSamplingIntensity = treesByStand2016 %>% - reframe(quantiles = c(0.25, 0.75), - trees = quantile(count + dbhMeasureOnly + heightAndDbhMeasure, quantiles), - height = quantile(heightAndDbhMeasure, quantiles))) - ggplot() + - geom_histogram(aes(x = count), treesByStand2016, binwidth = 1) + - labs(x = "count trees", y = "stands") + - ggplot() + - geom_histogram(aes(x = dbhMeasureOnly), treesByStand2016, binwidth = 1) + - labs(x = "DBH measure trees", y = NULL) + - ggplot() + - geom_histogram(aes(x = heightAndDbhMeasure), treesByStand2016, binwidth = 1) + - labs(x = "height measure trees", y = NULL) + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout() & - coord_cartesian(xlim = c(0, 250), ylim = c(0, 35)) - # sizes of trees and taper limits treeStemLimits = get_species_limits(trees2016) ggplot(trees2016) + geom_histogram(aes(x = TotalHt, y = 100 * after_stat(count / tapply(count, PANEL, sum)[PANEL]), fill = speciesGroup), binwidth = 2, na.rm = TRUE) + facet_wrap(vars(speciesGroup)) + labs(x = "height, m", y = "percentage of trees") + - ggplot(trees2016) + + ggplot(trees2016) + geom_histogram(aes(x = DBH, y = 100 * after_stat(count / tapply(count, PANEL, sum)[PANEL]), fill = speciesGroup), binwidth = 2.5, na.rm = TRUE) + facet_wrap(vars(speciesGroup)) + labs(x = "DBH, cm", y = NULL) + - ggplot() + + ggplot() + geom_line(aes(x = DBH, y = heightDiameterRatioMin), treeStemLimits, color = "grey70", linetype = "longdash", na.rm = TRUE) + geom_point(aes(x = DBH, y = TotalHt / (0.01 * DBH), color = speciesGroup), trees2016, alpha = 0.1, na.rm = TRUE, shape = 16) + geom_line(aes(x = DBH, y = heightDiameterRatioMax), treeStemLimits, color = "grey70", linetype = "longdash", na.rm = TRUE) + facet_wrap(vars(speciesGroup)) + coord_cartesian(ylim = c(1, 400)) + labs(x = "DBH, cm", y = "height-diameter ratio") + - plot_layout(guides = "collect") & + plot_layout(guides = "collect") & guides(color = "none", fill = "none") & scale_color_manual(breaks = levels(trees2016$speciesGroup), limits = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) & scale_fill_manual(breaks = levels(trees2016$speciesGroup), limits = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) - + + # ## Figures A1-4: species level exploratory plots + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "DF"), speciesLabel = "Douglas-fir", maxTreesMeasured = 150, omitLegends = TRUE, omitXlabels = TRUE) / + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RA"), speciesLabel = "red alder", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, plotLetters = c("d)", "e)", "f)")) + + # plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + # #ggsave("trees/height-diameter/figures/Figure A1 PSME-ALRU2.png", height = 13, width = 20, units = "cm", dpi = 250) + # + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "WH"), speciesLabel = "western hemlock", maxTreesMeasured = 150, omitLegends = TRUE) / + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "BM"), speciesLabel = "bigleaf maple", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, plotLetters = c("d)", "e)", "f)"), ) + + # plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + # #ggsave("trees/height-diameter/figures/Figure A2 TSHE-ACMA3.png", height = 13, width = 20, units = "cm", dpi = 250) + # + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "OM"), speciesLabel = "Oregon myrtle", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, omitXlabels = TRUE) / + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RC"), speciesLabel = "western redcedar", maxTreesMeasured = 150, plotLetters = c("d)", "e)", "f)"), omitLegends = TRUE) + + # plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + # #ggsave("trees/height-diameter/figures/Figure A3 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) + # + # plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "other"), speciesLabel = "other species ", distributionLegendPositionY = 0.92) + + # plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + # #ggsave("trees/height-diameter/figures/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + ## Figures A1-4: species level exploratory plots plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "DF"), speciesLabel = "Douglas-fir", maxTreesMeasured = 150, omitLegends = TRUE, omitXlabels = TRUE) / - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RA"), speciesLabel = "red alder", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, plotLetters = c("d)", "e)", "f)")) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - #ggsave("trees/height-diameter/figures/Figure A1 PSME-ALRU2.png", height = 13, width = 20, units = "cm", dpi = 250) + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RA"), speciesLabel = "red alder", maxTreesMeasured = 150, distributionLegendPositionY = 0.92) + + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A1 PSME-ALRU2.png", height = 13, width = 20, units = "cm", dpi = 250) plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "WH"), speciesLabel = "western hemlock", maxTreesMeasured = 150, omitLegends = TRUE) / - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "BM"), speciesLabel = "bigleaf maple", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, plotLetters = c("d)", "e)", "f)"), ) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - #ggsave("trees/height-diameter/figures/Figure A2 TSHE-ACMA3.png", height = 13, width = 20, units = "cm", dpi = 250) - + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "BM"), speciesLabel = "bigleaf maple", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, ) + + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A2 TSHE-ACMA3.png", height = 13, width = 20, units = "cm", dpi = 250) + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "OM"), speciesLabel = "Oregon myrtle", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, omitXlabels = TRUE) / - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RC"), speciesLabel = "western redcedar", maxTreesMeasured = 150, plotLetters = c("d)", "e)", "f)"), omitLegends = TRUE) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - #ggsave("trees/height-diameter/figures/Figure A3 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RC"), speciesLabel = "western redcedar", maxTreesMeasured = 150, omitLegends = TRUE) + + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A3 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "other"), speciesLabel = "other species ", distributionLegendPositionY = 0.92) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - #ggsave("trees/height-diameter/figures/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) } ## stand-level summaries and clustering -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { treesByStand2016 = trees2016 %>% group_by(StandID) %>% summarize(speciesGroup = names(sort(-table(speciesGroup)))[1], # one liner for mode of character vector (https://stackoverflow.com/questions/2547402/how-to-find-the-statistical-mode/8189441#8189441) @@ -2056,20 +2159,20 @@ if (htDiaOptions$includeInvestigatory) geom_histogram(aes(x = measurePlots, fill = speciesGroup), binwidth = 1) + # 492 stands with 26 plots coord_cartesian(xlim = c(0, 45)) + labs(x = "measure plots", y = "number of stands", fill = "most\ncommon\nspecies") + - ggplot(treesByStand2016) + + ggplot(treesByStand2016) + geom_histogram(aes(x = trees, fill = speciesGroup), binwidth = 5) + coord_cartesian(xlim = c(0, 260), ylim = c(0, 170)) + labs(x = "trees counted", y = NULL, fill = "most\ncommon\nspecies") + - ggplot(treesByStand2016) + + ggplot(treesByStand2016) + geom_histogram(aes(x = dbh, fill = speciesGroup), binwidth = 5) + coord_cartesian(xlim = c(0, 260), ylim = c(0, 170)) + labs(x = "DBH measure trees", y = "number of stands", fill = "most\ncommon\nspecies") + - ggplot(treesByStand2016) + + ggplot(treesByStand2016) + geom_histogram(aes(x = height, fill = speciesGroup), binwidth = 5) + coord_cartesian(xlim = c(0, 260), ylim = c(0, 170)) + labs(x = "height measure trees", y = NULL, fill = "most\ncommon\nspecies") + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout(nrow = 2, ncol = 2, guides = "collect") & + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout(nrow = 2, ncol = 2, guides = "collect") & scale_fill_manual(breaks = levels(trees2016$speciesGroup), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) & theme(legend.spacing.y = unit(0.2, "line")) @@ -2138,32 +2241,32 @@ if (htDiaOptions$includeInvestigatory) geom_histogram(aes(x = psmeTph), fill = "forestgreen", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "Douglas-fir TPH", y = "stands") + - ggplot(speciesCountByStand2016) + + ggplot(speciesCountByStand2016) + geom_histogram(aes(x = alruTph), fill = "red2", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "red alder TPH", y = "stands") + - ggplot(speciesCountByStand2016) + + ggplot(speciesCountByStand2016) + geom_histogram(aes(x = tsheTph), fill = "blue2", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "western hemlock TPH", y = "stands") + - ggplot(speciesCountByStand2016) + + ggplot(speciesCountByStand2016) + geom_histogram(aes(x = acmaTph), fill = "green3", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "bigleaf maple TPH", y = "stands") + - ggplot(speciesCountByStand2016) + + ggplot(speciesCountByStand2016) + geom_histogram(aes(x = umcaTph), fill = "mediumorchid", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "Oregon myrtle TPH", y = "stands") + - ggplot(speciesCountByStand2016) + + ggplot(speciesCountByStand2016) + geom_histogram(aes(x = thplTph), fill = "firebrick", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "western redcedar TPH", y = "stands") + - ggplot(speciesCountByStand2016) + + ggplot(speciesCountByStand2016) + geom_histogram(aes(x = otherTph), fill = "grey65", binwidth = 50) + coord_cartesian(xlim = c(0, 2000), ylim = c(0, 700)) + labs(x = "other species TPH", y = "stands") + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout(nrow = 2, ncol = 4, guides = "collect") + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout(nrow = 2, ncol = 4, guides = "collect") # alternate TPH breakdown ggplot(speciesCountByStand2016) + geom_point(aes(x = totalTph - psmeTph, y = psmeTph, color = primarySpecies, shape = secondarySpecies), alpha = 0.5) + @@ -2172,7 +2275,7 @@ if (htDiaOptions$includeInvestigatory) scale_color_manual(breaks = c("PSME", "ALRU", "TSHE", "ACMA", "UMCA", "THPL", "other"), values = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65")) + scale_shape_manual(breaks = c("PSME", "ALRU", "TSHE", "ACMA", "UMCA", "THPL", "other"), values = c(15, 16, 17, 22, 21, 24, 25)) + theme(legend.spacing.y = unit(0.3, "line")) - + # basic clustering of stand types # k-means and mean shift perform poorly here, presumably due to being asked to partition continuous data. Data visualization # here could use either scaled (normalized) or unscaled distances, the former emphasizing dissimilarity in species besides @@ -2180,7 +2283,7 @@ if (htDiaOptions$includeInvestigatory) basalAreaDistances = dist(speciesCountByStand2016 %>% select(isPlantation, psmeBA, alruBA, tsheBA, acmaBA, umcaBA, thplBA, otherBA)) standHierarchyBA = hclust(basalAreaDistances, method = "ward.D") # produces the most even area distribution among hclust()'s methods # ggdendro::ggdendrogram(standHierarchyBA) - + speciesBasalAreaByCluster = speciesCountByStand2016 %>% mutate(clusterID = cutree(standHierarchyBA, k = 20)) %>% group_by(clusterID) %>% summarize(PSME = sum(standArea * psmeBA) / sum(standArea), # could also join clustersBA$centers @@ -2206,7 +2309,7 @@ if (htDiaOptions$includeInvestigatory) # clustering speciesBasalAreaOneRowPerClusterSlice = speciesBasalAreaByCluster %>% group_by(clusterID) %>% slice(1) - + ggplot() + geom_col(aes(x = area, y = clusterID, fill = isPlantation, group = fct_rev(isPlantation)), orientation = "y", speciesBasalAreaByCluster %>% mutate(naturalRegenArea = totalArea - plantationArea) %>% select(clusterID, naturalRegenArea, plantationArea) %>% @@ -2218,7 +2321,7 @@ if (htDiaOptions$includeInvestigatory) scale_fill_manual(breaks = c("natural regeneration", "plantation"), values = c("grey10", "grey35")) + scale_x_continuous(expand = c(0.012, 0)) + theme(legend.justification = c(1, 0), legend.position.inside = c(1, 0.02)) + - ggplot() + + ggplot() + geom_bar(aes(y = clusterID, fill = fct_rev(speciesGroup), weight = basalArea), speciesBasalAreaByCluster %>% select(-meanAge2016, -meanTopHeight, -starts_with("age"), -starts_with("topHeight")) %>% pivot_longer(cols = -c("clusterID", "meanTotalBasalArea", "plantationArea", "totalArea"), names_to = "speciesGroup", values_to = "basalArea") %>% mutate(speciesGroup = factor(speciesGroup, levels = c("PSME", "ALRU", "TSHE", "ACMA", "UMCA", "THPL", "other")))) + @@ -2229,8 +2332,8 @@ if (htDiaOptions$includeInvestigatory) scale_x_continuous(expand = c(0.008, 0)) + scale_y_discrete(labels = NULL) + theme(legend.key.height = unit(1, "line"), legend.key.width = unit(1, "line")) + - plot_annotation(theme = theme(plot.margin = margin())) + - plot_layout(nrow = 1, ncol = 2, widths = c(0.4, 0.6)) + plot_annotation(theme = theme(plot.margin = margin())) + + plot_layout(nrow = 1, ncol = 2, widths = c(0.4, 0.6)) #ggsave("trees/height-diameter/figures/Figure S90 Elliott stand clusters.png", height = 10.5, width = 22, units = "cm", dpi = 250) # tree counts @@ -2241,8 +2344,7 @@ if (htDiaOptions$includeInvestigatory) ## Douglas-fir site index regression: not enough data for other species -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { # site species number of stands # PSME 412 # hardwood 26 @@ -2268,7 +2370,7 @@ if (htDiaOptions$includeInvestigatory) geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelLinear), color = planted), alpha = 0.3) + labs(x = "measured 50-year site index, feet", y = "linear model prediction, feet", color = NULL) + theme(legend.position = "none") + - ggplot(psmeStands2022) + geom_abline(slope = 1, intercept = 0, color = "grey70", linetype = "longdash") + + ggplot(psmeStands2022) + geom_abline(slope = 1, intercept = 0, color = "grey70", linetype = "longdash") + geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelNonlinear, psmeStands2022), color = planted), alpha = 0.3) + labs(x = "measured 50-year site index, feet", y = "nonlinear model prediction, feet", color = "stand age") + scale_color_discrete(breaks = c(FALSE, TRUE), labels = c("≥100 years", "<100 years")) + @@ -2278,25 +2380,25 @@ if (htDiaOptions$includeInvestigatory) geom_point(aes(x = Cruised_Si, y = -residuals(psmeSiteIndexModelLinear), color = planted), alpha = 0.3, shape = 16) + labs(x = "measured 50-year site index, feet", y = "linear model error, feet", color = NULL) + theme(legend.position = "none") + - ggplot(psmeStands2022) + + ggplot(psmeStands2022) + geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelNonlinear, psmeStands2022) - Cruised_Si, color = planted), alpha = 0.3, shape = 16) + labs(x = "measured 50-year site index, feet", y = "nonlinear model error, feet", color = "stand age") + scale_color_discrete(breaks = c(FALSE, TRUE), labels = c("≥100 years", "<100 years")) + theme(legend.justification = c(1, 1), legend.position.inside = c(0.98, 0.98)) ggplot(psmeStands2022) + geom_point(aes(x = Elev_Mean, y = Cruised_Si), alpha = 0.3, shape = 16) + - ggplot(psmeStands2022) + geom_point(aes(x = SlopeMeanPercent, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = AspectSin, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = AspectCos, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = TPA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + - ggplot(psmeStands2022) + geom_point(aes(x = BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = QMD_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = BA_DF / BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = PrecipNorm, y = Cruised_Si), alpha = 0.3, shape = 16) + - ggplot(psmeStands2022) + geom_point(aes(x = AWS100, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = QMD_DF, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = QMD_WH, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) - + ggplot(psmeStands2022) + geom_point(aes(x = SlopeMeanPercent, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = AspectSin, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = AspectCos, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = TPA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + + ggplot(psmeStands2022) + geom_point(aes(x = BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = QMD_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = BA_DF / BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = PrecipNorm, y = Cruised_Si), alpha = 0.3, shape = 16) + + ggplot(psmeStands2022) + geom_point(aes(x = AWS100, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = QMD_DF, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + + ggplot(psmeStands2022) + geom_point(aes(x = QMD_WH, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + ## aggregate tree distribution plots liveUnbrokenTrees2016 = trees2016 %>% filter(isLiveUnbroken) @@ -2307,7 +2409,7 @@ if (htDiaOptions$includeInvestigatory) scale_alpha_manual(breaks = c(FALSE, TRUE), labels = c("natural regeneration", "plantation"), values = c(1, 0.7)) + scale_fill_manual(breaks = c("DF", "RA", "WH", "BM", "OM", "RC", "other"), values = c("green3", "red2", "blue2", "cyan2", "darkorchid3", "firebrick", "grey35")) + theme(legend.position = "none") + - ggplot(liveUnbrokenTrees2016) + + ggplot(liveUnbrokenTrees2016) + geom_histogram(aes(x = 100 * ..count../sum(..count..), y = TotalHt, fill = speciesGroup, alpha = isPlantation), binwidth = 1, na.rm = TRUE) + coord_cartesian(xlim = c(0, 4.4)) + labs(x = "percentage of live stems measured", y = "height, m", alpha = NULL, fill = NULL) + @@ -2316,10 +2418,9 @@ if (htDiaOptions$includeInvestigatory) theme(legend.justification = c(1, 1), legend.position.inside = c(1, 1), legend.spacing.y = unit(0.3, "line")) } - + ## site index plots -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { ggplot(stands2022 %>% filter(Cruised_Si > 0)) + geom_point(aes(x = Age_2020, y = Cruised_Si, color = siteSpecies), alpha = 0.6, shape = 16) + labs(x = "stand age in 2020, years", y = "50-year site index measured in 2015-2016, feet", color = NULL) + @@ -2356,8 +2457,7 @@ if (htDiaOptions$includeInvestigatory) ## stand tree pooling -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { # stand merge by plantation age # for now, proxy HX as Pacific dogwood (Cornus nuttalli) treesOfAge = trees2016 %>% filter(standAge2016 == 30, isLive, is.na(DBH) == FALSE) %>% @@ -2373,8 +2473,7 @@ if (htDiaOptions$includeInvestigatory) ## general variable importance -if (htDiaOptions$includeInvestigatory) -{ +if (htDiaOptions$includeInvestigatory) { library(VSURF) heightMeasureTrees = trees2016 %>% filter(isLiveUnbroken, is.na(TotalHt) == FALSE, is.na(elevation) == FALSE) heightVsurf = VSURF(TotalHt ~ ., heightMeasureTrees %>% select(TotalHt, Species, DBH, isPlantation, topHeight, qmd, relativeDiameter, standBasalAreaPerHectare, basalAreaLarger, standAge2016, elevation, slope, aspect, topographicShelterIndex), ncores = 8, parallel = TRUE, RFimplem = "ranger") @@ -2392,3 +2491,4 @@ if (htDiaOptions$includeInvestigatory) guides(fill = "none") + labs(x = "normalized variable importance", y = NULL) } + From 93435ec92dc7e1161265f82ba070f51fb5d5b895 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Fri, 16 May 2025 00:24:45 -0700 Subject: [PATCH 02/13] update sample factor formula --- trees/height-diameter/setup.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/trees/height-diameter/setup.R b/trees/height-diameter/setup.R index a772038..1491540 100644 --- a/trees/height-diameter/setup.R +++ b/trees/height-diameter/setup.R @@ -1676,7 +1676,7 @@ trees2016 = left_join(read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State Univer isConifer = Species %in% c("PSME", "TSHE", "THPL"), isLive = (CompCode %in% c("deadStanding", "snag")) == FALSE, isLiveUnbroken = isLive & (CompCode != "brokenTop"), - SampleFactor=0.229568, #added sample factor + SampleFactor = if_else(SamplingMethod == "BAF",2.47105 * 0.092903 * (baExpansionFactor / (0.005454 * DBH^2)),10000 / 300 * TreeCount), #for fixed radius plot of 0.03 ha, the sample factor is calculated as 10000 / 300 * treeCount, where 300 square meters corresponds to 0.0.ha plotRadius = if_else(SamplingMethod == "BAF", 100 / 2.54 * 0.3048 / (12 * sqrt(SampleFactor / 10890)), 0.3048 * sqrt(43560 / (pi * SampleFactor))), # m SampleFactor = 2.47105 * if_else(SamplingMethod == "BAF", 0.092903, 1) * SampleFactor, # convert BAF from ft²/ac to m²/ha and TPA to TPH, BAF conversion is BAF ft²/ac * 2.47105 ac/ha * 0.092903 m²/ft² = 0.229568 m²/ha / ft²/ac TotalHt = na_if(0.3048 * TotalHt, 0), From e62b0196d8e5bc3a3785ccf7cde82e3e1e32f13a Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Sun, 18 May 2025 22:25:58 -0700 Subject: [PATCH 03/13] update the relative paths --- trees/height-diameter/THPL.R | 16 ++++++++-------- trees/height-diameter/setup.R | 18 +++++++++--------- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/trees/height-diameter/THPL.R b/trees/height-diameter/THPL.R index 7dc63e2..08fec39 100644 --- a/trees/height-diameter/THPL.R +++ b/trees/height-diameter/THPL.R @@ -155,7 +155,7 @@ if (thplOptions$fitHeight) { #if the value in the column fitHeight of thplOption # thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL TotalHt.Rdata", thplHeightFromDiameter, thplHeightFromDiameterNlrob, thplHeightFromDiameterGslNlsDefault) + save(file = "data/THPL TotalHt.Rdata", thplHeightFromDiameter, thplHeightFromDiameterNlrob, thplHeightFromDiameterGslNlsDefault) } if (htDiaOptions$includeInvestigatory) { @@ -215,7 +215,7 @@ if (thplOptions$fitHeightGnls) thplHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = thplHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped thplHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = thplHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL TotalHt gnls.Rdata", thplHeightFromDiameterGnls) + save(file = "data/THPL TotalHt gnls.Rdata", thplHeightFromDiameterGnls) } if (htDiaOptions$includeInvestigatory) { @@ -316,7 +316,7 @@ if (thplOptions$fitHeightMixed){ #fitting height diameter using mixed effect mod thplHeightFromDiameterMixed$gamm = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) thplHeightFromDiameterMixed$gammBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL TotalHt mixed.Rdata", thplHeightFromDiameterMixed) + save(file = "data/THPL TotalHt mixed.Rdata", thplHeightFromDiameterMixed) } @@ -432,7 +432,7 @@ if (thplOptions$fitDbh) { # thplDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # thplDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and aspect on AIC - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL DBH.Rdata", thplDiameterFromHeight, thplDiameterFromHeightNlrob, thplDiameterFromHeightGslNlsDefault) + save(file = "data/THPL DBH.Rdata", thplDiameterFromHeight, thplDiameterFromHeightNlrob, thplDiameterFromHeightGslNlsDefault) } if (htDiaOptions$includeInvestigatory) { print(thplDiameterFromHeightResults %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic), n = 25) @@ -577,7 +577,7 @@ if (thplOptions$fitDbhMixed) { thplDiameterFromHeightMixed$gammAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) thplDiameterFromHeightMixed$gammRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = thpl2016, mixed = TRUE) - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL DBH mixed.Rdata", thplDiameterFromHeightMixed) + save(file = "data/THPL DBH mixed.Rdata", thplDiameterFromHeightMixed) } @@ -623,7 +623,7 @@ if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & th mutate(species = "THPL") check_plot_results(thplResults) - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL results.Rdata", thplCoefficients, thplResults) + save(file = "data/THPL results.Rdata", thplCoefficients, thplResults) } else if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) { if (exists("thplHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/THPL TotalHt.Rdata") } @@ -642,7 +642,7 @@ if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & th mutate(species = "THPL") check_plot_results(thplResults) - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL results.Rdata", thplCoefficients, thplResults) + save(file = "data/THPL results.Rdata", thplCoefficients, thplResults) } @@ -670,7 +670,7 @@ if (thplOptions$fitHeight & thplOptions$fitDbh) thplDiameterFromHeightPreferred$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) - save(file = "C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/THPL preferred models.Rdata", thplHeightFromDiameterPreferred, thplDiameterFromHeightPreferred) + save(file = "data/THPL preferred models.Rdata", thplHeightFromDiameterPreferred, thplDiameterFromHeightPreferred) } diff --git a/trees/height-diameter/setup.R b/trees/height-diameter/setup.R index 1491540..2172741 100644 --- a/trees/height-diameter/setup.R +++ b/trees/height-diameter/setup.R @@ -1635,7 +1635,7 @@ plot_qq = function(diameterRegression1, diameterRegression2, diameterRegression3 ######### --------- FUNCTIONS END -----------##### -stands2022 = read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desktop\Winter 2025\FOR 599\Elliott_stands_2015-16.csv)")%>% +stands2022 = read.csv(r"(Elliott_stands_2015-16.csv)")%>% mutate(standAge2016=standAge2015+1, isPlantation = standAge2016 < 70) #%>% @@ -1650,14 +1650,14 @@ stands2022 = read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desk #isPlantation = standAge2016 < 70) head(stands2022) -plots2016 = read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desktop\Winter 2025\FOR 599\Elliott_timber_cruise_2015-16.csv)") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 +plots2016 = read.csv(r"(Elliott_timber_cruise_2015-16.csv)") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 head(plots2016) #trees2016 = left_join(left_join(read.csv("Elliott_timber_cruise_2015-16.csv", sheet = "Elliott_timber_cruise_2015-16"), #stands2022 %>% select(standID, standAge2016, areaHa, isPlantation), # by = c("standID")), #plots2016 %>% select(standID, plotID, elevation, slope, aspect, topographicShelterIndex, x, y) %>% rename(plotID = PltInteger), #by = c("plotID")) -trees2016 = left_join(read.csv(r"(C:\Users\HAMALA\OneDrive - Oregon State University\Desktop\Winter 2025\FOR 599\Elliott_timber_cruise_2015-16.csv)"), +trees2016 = left_join(read.csv(r"(Elliott_timber_cruise_2015-16.csv)"), stands2022 %>% select(standID, standAge2016, areaHa, isPlantation), by = "standID") %>% # removed the second part of the join because it was not relevant rename(Species=species,TotalHt=totalHt,TreeCount=treeCount,PlotID=plotID,StandID=standID,SamplingMethod=samplingMethod,CompCode=condition,CrownRatio=crownRatio,Ht1=taperHt,Dia1=taperDiameter,standArea=areaHa)%>% # renamed columns to match further analysis, this code was added to match variable names. @@ -1907,7 +1907,7 @@ if (htDiaOptions$includeInvestigatory) { # select(-standArea.x, -standArea.y, -standAge2016.x, -standAge2016.y, -isPlantation.x, -isPlantation.y) %>% # rename(standID2016 = StandID) %>% # relocate(standID2016, standAge2016, standArea, isPlantation)), - # "C:/Users/hamala/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/2015-16 cruise.xlsx/2015-16 cruise.xlsx") + # "2015-16 cruise.xlsx") # } write_xlsx(list(stands = left_join(stands2022 %>% rename (standArea=areaHa)%>% @@ -1931,7 +1931,7 @@ if (htDiaOptions$includeInvestigatory) { select(-standArea.x, -standArea.y, -standAge2016.x, -standAge2016.y, -isPlantation.x, -isPlantation.y) %>% rename(standID2016 = StandID) %>% relocate(standID2016, standAge2016, standArea, isPlantation)), - "C:/Users/hamala/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/2015-16 cruise.xlsx") + "2015-16 cruise.xlsx") } ## data tabulation and basic plotting @@ -2118,21 +2118,21 @@ if (htDiaOptions$includeInvestigatory) { plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "DF"), speciesLabel = "Douglas-fir", maxTreesMeasured = 150, omitLegends = TRUE, omitXlabels = TRUE) / plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RA"), speciesLabel = "red alder", maxTreesMeasured = 150, distributionLegendPositionY = 0.92) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A1 PSME-ALRU2.png", height = 13, width = 20, units = "cm", dpi = 250) + ggsave("figures/Figure A1 PSME-ALRU2.png", height = 13, width = 20, units = "cm", dpi = 250) plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "WH"), speciesLabel = "western hemlock", maxTreesMeasured = 150, omitLegends = TRUE) / plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "BM"), speciesLabel = "bigleaf maple", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, ) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A2 TSHE-ACMA3.png", height = 13, width = 20, units = "cm", dpi = 250) + ggsave("figures/Figure A2 TSHE-ACMA3.png", height = 13, width = 20, units = "cm", dpi = 250) plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "OM"), speciesLabel = "Oregon myrtle", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, omitXlabels = TRUE) / plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RC"), speciesLabel = "western redcedar", maxTreesMeasured = 150, omitLegends = TRUE) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A3 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) + ggsave("figures/Figure A3 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "other"), speciesLabel = "other species ", distributionLegendPositionY = 0.92) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("C:/Users/HAMALA/OneDrive - Oregon State University/Desktop/Winter 2025/FOR 599/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + ggsave("figures/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) } From 06a2d730be3ab3dfa1dd7637af1dcb8fb5537a2c Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Thu, 22 May 2025 17:34:50 -0700 Subject: [PATCH 04/13] change to metric unit for public dataset --- trees/height-diameter/setup.R | 292 ++++++++++++++++------------------ 1 file changed, 140 insertions(+), 152 deletions(-) diff --git a/trees/height-diameter/setup.R b/trees/height-diameter/setup.R index 2172741..64d4849 100644 --- a/trees/height-diameter/setup.R +++ b/trees/height-diameter/setup.R @@ -24,10 +24,6 @@ library(tidyr) library(WeightedROC) library(writexl) - -####### ----- FUNCTIONS ------ ###### - - #theme set() is a function from ggplot, it is used to customize plot aesthetics #theme_bw() sets the background to white with black grid lines #and the theme() functions define the various elements within the theme. @@ -42,7 +38,7 @@ theme_set(theme_bw() + theme(axis.line = element_line(linewidth = 0.3), #makes t htDiaOptions = tibble(folds = 10, repetitions = 10, - includeInvestigatory = FALSE, # default to excluding plotting and other add ons in species scripts #it is like telling R that I do not want the code for plots/investigatory statistics to be run (coded somewhere below, if I set this as FALSE) + includeInvestigatory = TRUE, # default to excluding plotting and other add ons in species scripts #it is like telling R that I do not want the code for plots/investigatory statistics to be run (coded somewhere below, if I set this as FALSE) retainModelThreshold = 10) # cross validation retains model objects if folds * repetitions is less than or equal to this threshold, e.g. 25 = retaining models up to and including 5x5 cross validation but sufficient DDR for loading all results may be an issue (5x5 easily exceeds 90 GB) plotLetters = c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L") #plotLetters = c("(a)", "(b)", "(c)", "(d)", "(e)", "(f)", "(g)", "(h)", "(i)", "(j)", "(k)", "(l)") @@ -1605,7 +1601,23 @@ plot_qq = function(diameterRegression1, diameterRegression2, diameterRegression3 #standArea = 0.404686 * GrossAc, # ac to ha #isPlantation = standAge2016 < 70) + +stands2022 = read.csv(r"(Elliott_stands_2015-16.csv)")%>% + mutate(standAge2016=standAge2015+1, + isPlantation = standAge2016 < 70) +#%>% +#mutate(Cruised_Si = na_if(Cruised_Si, 0), +#ODSL_Site_ = na_if(ODSL_Site_, 0), +#siteSpecies = if_else(startsWith(ODSL_VEG_L, "1W") | startsWith(ODSL_VEG_L, "WX"), "hemlock", +#if_else(startsWith(ODSL_VEG_L, "1H") | startsWith(ODSL_VEG_L, "HX"), "hardwood", +#if_else(startsWith(ODSL_VEG_L, "OT"), "other", +#"Douglas-fir"))), +#standAge2016 = pmax(if_else((Age_2020 - 4) > (Age_2015 + 1), Age_2015 + 1, Age_2020 - 4), 0), +#standArea = 0.404686 * GrossAc, # ac to ha +#isPlantation = standAge2016 < 70) + #plots2016 = read_xlsx("GIS/Trees/2015-16 cruise/CruisePlots_All_20151211.xlsx") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 +plots2016 = read.csv(r"(Elliott_timber_cruise_2015-16.csv)") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 #trees2016 = left_join(left_join(read_xlsx("trees/Elliott final cruise records 2015-16.xlsx", sheet = "CRUISERECS"), #stands2022 %>% select(StandID, standAge2016, standArea, isPlantation), @@ -1633,30 +1645,6 @@ plot_qq = function(diameterRegression1, diameterRegression2, diameterRegression3 #treeBasalAreaPerHectare = SampleFactor * TreeCount * if_else(SamplingMethod == "BAF", 1, basalArea)) %>% # m²/ha, measure plots have TreeCount = 1 for each tree, count plots have TreeCount = 0-41 depending on the number of trees present #group_by(StandID) %>% -######### --------- FUNCTIONS END -----------##### - -stands2022 = read.csv(r"(Elliott_stands_2015-16.csv)")%>% - mutate(standAge2016=standAge2015+1, - isPlantation = standAge2016 < 70) -#%>% -#mutate(Cruised_Si = na_if(Cruised_Si, 0), -#ODSL_Site_ = na_if(ODSL_Site_, 0), -#siteSpecies = if_else(startsWith(ODSL_VEG_L, "1W") | startsWith(ODSL_VEG_L, "WX"), "hemlock", -#if_else(startsWith(ODSL_VEG_L, "1H") | startsWith(ODSL_VEG_L, "HX"), "hardwood", -#if_else(startsWith(ODSL_VEG_L, "OT"), "other", -#"Douglas-fir"))), -#standAge2016 = pmax(if_else((Age_2020 - 4) > (Age_2015 + 1), Age_2015 + 1, Age_2020 - 4), 0), -#standArea = 0.404686 * GrossAc, # ac to ha -#isPlantation = standAge2016 < 70) -head(stands2022) - -plots2016 = read.csv(r"(Elliott_timber_cruise_2015-16.csv)") # both 20151211 and 20160111 missing coordinates for 171 plots in stands 1661 and 2470 -head(plots2016) -#trees2016 = left_join(left_join(read.csv("Elliott_timber_cruise_2015-16.csv", sheet = "Elliott_timber_cruise_2015-16"), -#stands2022 %>% select(standID, standAge2016, areaHa, isPlantation), -# by = c("standID")), -#plots2016 %>% select(standID, plotID, elevation, slope, aspect, topographicShelterIndex, x, y) %>% rename(plotID = PltInteger), -#by = c("plotID")) trees2016 = left_join(read.csv(r"(Elliott_timber_cruise_2015-16.csv)"), stands2022 %>% select(standID, standAge2016, areaHa, isPlantation), by = "standID") %>% # removed the second part of the join because it was not relevant @@ -1668,18 +1656,17 @@ trees2016 = left_join(read.csv(r"(Elliott_timber_cruise_2015-16.csv)"), plotType == "measure" ~ "IP", TRUE ~ NA_character_), BHAge = na_if(breastHeightAge, 0), # years - DBH = na_if(2.54 * DBH, 0), # inches to cm - Dia1 = na_if(2.54 * Dia1, 0), + DBH = na_if(DBH, 0), # dbh in cm + Dia1 = na_if(Dia1, 0), CrownRatio = na_if(CrownRatio, 0), - Ht1 = na_if(0.3048 * Ht1, 0), # feet to m - Ht2 = na_if(0.3048 * htToBrokenTop, 0), + Ht1 = na_if(Ht1, 0), # feet to m + Ht2 = na_if(htToBrokenTop, 0), isConifer = Species %in% c("PSME", "TSHE", "THPL"), isLive = (CompCode %in% c("deadStanding", "snag")) == FALSE, isLiveUnbroken = isLive & (CompCode != "brokenTop"), - SampleFactor = if_else(SamplingMethod == "BAF",2.47105 * 0.092903 * (baExpansionFactor / (0.005454 * DBH^2)),10000 / 300 * TreeCount), #for fixed radius plot of 0.03 ha, the sample factor is calculated as 10000 / 300 * treeCount, where 300 square meters corresponds to 0.0.ha - plotRadius = if_else(SamplingMethod == "BAF", 100 / 2.54 * 0.3048 / (12 * sqrt(SampleFactor / 10890)), 0.3048 * sqrt(43560 / (pi * SampleFactor))), # m - SampleFactor = 2.47105 * if_else(SamplingMethod == "BAF", 0.092903, 1) * SampleFactor, # convert BAF from ft²/ac to m²/ha and TPA to TPH, BAF conversion is BAF ft²/ac * 2.47105 ac/ha * 0.092903 m²/ft² = 0.229568 m²/ha / ft²/ac - TotalHt = na_if(0.3048 * TotalHt, 0), + SampleFactor = if_else(SamplingMethod == "BAF",baExpansionFactor / (pi * (DBH / 200)^2),10000 / 300), #for fixed radius plot of 0.03 ha, the sample factor is calculated as 10000 / 300 * treeCount, where 300 square meters corresponds to 0.03ha + plotRadius = if_else(SamplingMethod == "BAF",sqrt(baExpansionFactor / (pi * SampleFactor)) * 2,sqrt((10000 / SampleFactor) / pi)), + TotalHt = na_if(TotalHt, 0), TreeCount = if_else((PlotType == "IP") & (SamplingMethod == "BAF") & (TreeCount > 1), 1, TreeCount), # fix tree duplication per notes above basalArea = 0.25 * pi * (0.01*DBH)^2, # m² breastHeight = 1.37, # m, used for offset in lm() height regressions @@ -2334,7 +2321,7 @@ if (htDiaOptions$includeInvestigatory) { theme(legend.key.height = unit(1, "line"), legend.key.width = unit(1, "line")) + plot_annotation(theme = theme(plot.margin = margin())) + plot_layout(nrow = 1, ncol = 2, widths = c(0.4, 0.6)) - #ggsave("trees/height-diameter/figures/Figure S90 Elliott stand clusters.png", height = 10.5, width = 22, units = "cm", dpi = 250) + ggsave("figures/Figure S90 Elliott stand clusters.png", height = 10.5, width = 22, units = "cm", dpi = 250) # tree counts trees2016 %>% group_by(StandID) %>% summarize(standArea = standArea[1], tph = tph[1]) %>% @@ -2344,116 +2331,116 @@ if (htDiaOptions$includeInvestigatory) { ## Douglas-fir site index regression: not enough data for other species -if (htDiaOptions$includeInvestigatory) { - # site species number of stands - # PSME 412 - # hardwood 26 - # hemlock 6 - # other 5 - psmeStands2022 = stands2022 %>% filter(is.na(Cruised_Si) == FALSE, siteSpecies == "Douglas-fir") %>% - mutate(Elev_MeanSquared = Elev_Mean^2, SlopeMeanPercent = 100 * tan(pi/180 * SlopeMean), SlopeMeanSquared = SlopeMean^2, SlopeMeanPercentSquared = SlopeMeanPercent^2, AWS100squared = AWS100^2, planted = Age_2020 < 100) - - psmeSiteIndexPredictorSubsets = regsubsets(x = as.matrix(psmeStands2022 %>% select(Elev_Mean, Elev_MeanSquared, SlopeMeanPercent, SlopeMeanPercentSquared, AspectMean, AspectSin, AspectCos, - PrecipNorm, AWS025, AWS050, AWS100, AWS100squared, AWS150, planted, X, Y, - Age_2015, TPA_Total, BA_Total, QMD_Total, BFperAcre_, BA_DF, QMD_DF, LeafRetnDF, BA_WH, QMD_WH, Shape_Area)), - y = psmeStands2022$Cruised_Si) - plot(psmeSiteIndexPredictorSubsets) - - #psmeSiteIndexModelLinear = lm(Cruised_Si ~ Elev_Mean + Elev_MeanSquared + SlopeMeanPercent + SlopeMeanPercentSquared + AspectSin + AspectCos + PrecipNorm + AWS100 + TPA_Total + BA_Total + QMD_Total + QMD_DF + LeafRetnDF + planted, psmeStands2022) - #psmeSiteIndexModelLinear = lm(Cruised_Si ~ Elev_MeanSquared + SlopeMeanPercent + SlopeMeanPercentSquared + AspectSin + AspectCos + AWS100 + planted, psmeStands2022) - psmeSiteIndexModelLinear = lm(Cruised_Si ~ Elev_MeanSquared + SlopeMeanPercentSquared + QMD_DF + planted, psmeStands2022) - summary(psmeSiteIndexModelLinear) - psmeSiteIndexModelNonlinear = gsl_nls(Cruised_Si ~ b0 + b1*Elev_Mean^b2 + b3*SlopeMeanPercent^b4 + b5*planted, psmeStands2022, start = list(b0 = 120, b1 = -1E-6, b2 = 2, b3 = -2E-3, b4 = 5, b5 = 20), control = gsl_nls_control(maxiter = 250)) - c(linear = AIC(psmeSiteIndexModelLinear), nonlinear = AIC(psmeSiteIndexModelNonlinear)) - - ggplot(psmeStands2022) + geom_abline(slope = 1, intercept = 0, color = "grey70", linetype = "longdash") + - geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelLinear), color = planted), alpha = 0.3) + - labs(x = "measured 50-year site index, feet", y = "linear model prediction, feet", color = NULL) + - theme(legend.position = "none") + - ggplot(psmeStands2022) + geom_abline(slope = 1, intercept = 0, color = "grey70", linetype = "longdash") + - geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelNonlinear, psmeStands2022), color = planted), alpha = 0.3) + - labs(x = "measured 50-year site index, feet", y = "nonlinear model prediction, feet", color = "stand age") + - scale_color_discrete(breaks = c(FALSE, TRUE), labels = c("≥100 years", "<100 years")) + - theme(legend.justification = c(1, 0), legend.position.inside = c(0.98, 0.02)) - - ggplot(psmeStands2022) + - geom_point(aes(x = Cruised_Si, y = -residuals(psmeSiteIndexModelLinear), color = planted), alpha = 0.3, shape = 16) + - labs(x = "measured 50-year site index, feet", y = "linear model error, feet", color = NULL) + - theme(legend.position = "none") + - ggplot(psmeStands2022) + - geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelNonlinear, psmeStands2022) - Cruised_Si, color = planted), alpha = 0.3, shape = 16) + - labs(x = "measured 50-year site index, feet", y = "nonlinear model error, feet", color = "stand age") + - scale_color_discrete(breaks = c(FALSE, TRUE), labels = c("≥100 years", "<100 years")) + - theme(legend.justification = c(1, 1), legend.position.inside = c(0.98, 0.98)) - - ggplot(psmeStands2022) + geom_point(aes(x = Elev_Mean, y = Cruised_Si), alpha = 0.3, shape = 16) + - ggplot(psmeStands2022) + geom_point(aes(x = SlopeMeanPercent, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = AspectSin, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = AspectCos, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = TPA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + - ggplot(psmeStands2022) + geom_point(aes(x = BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = QMD_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = BA_DF / BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = PrecipNorm, y = Cruised_Si), alpha = 0.3, shape = 16) + - ggplot(psmeStands2022) + geom_point(aes(x = AWS100, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = QMD_DF, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + - ggplot(psmeStands2022) + geom_point(aes(x = QMD_WH, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) - - - ## aggregate tree distribution plots - liveUnbrokenTrees2016 = trees2016 %>% filter(isLiveUnbroken) - ggplot(liveUnbrokenTrees2016) + - geom_histogram(aes(x = DBH, y = 100 * ..count../sum(..count..), fill = speciesGroup, alpha = isPlantation), binwidth = 2.5, na.rm = TRUE) + - coord_cartesian(ylim = c(0, 4.4)) + - labs(x = "DBH, cm", y = "percentage of live, unbroken stems measured", alpha = NULL, fill = NULL) + - scale_alpha_manual(breaks = c(FALSE, TRUE), labels = c("natural regeneration", "plantation"), values = c(1, 0.7)) + - scale_fill_manual(breaks = c("DF", "RA", "WH", "BM", "OM", "RC", "other"), values = c("green3", "red2", "blue2", "cyan2", "darkorchid3", "firebrick", "grey35")) + - theme(legend.position = "none") + - ggplot(liveUnbrokenTrees2016) + - geom_histogram(aes(x = 100 * ..count../sum(..count..), y = TotalHt, fill = speciesGroup, alpha = isPlantation), binwidth = 1, na.rm = TRUE) + - coord_cartesian(xlim = c(0, 4.4)) + - labs(x = "percentage of live stems measured", y = "height, m", alpha = NULL, fill = NULL) + - scale_alpha_manual(breaks = c(FALSE, TRUE), labels = c("natural regeneration", "plantation"), values = c(1, 0.7)) + - scale_fill_manual(breaks = c("DF", "RA", "WH", "BM", "OM", "RC", "other"), labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other"), values = c("green3", "red2", "blue2", "cyan2", "darkorchid3", "firebrick", "grey35")) + - theme(legend.justification = c(1, 1), legend.position.inside = c(1, 1), legend.spacing.y = unit(0.3, "line")) -} - - -## site index plots -if (htDiaOptions$includeInvestigatory) { - ggplot(stands2022 %>% filter(Cruised_Si > 0)) + - geom_point(aes(x = Age_2020, y = Cruised_Si, color = siteSpecies), alpha = 0.6, shape = 16) + - labs(x = "stand age in 2020, years", y = "50-year site index measured in 2015-2016, feet", color = NULL) + - guides(color = guide_legend(override.aes = list(alpha = 0.8))) + - scale_color_manual(breaks = c("Douglas-fir", "hemlock", "hardwood", "other"), values = c("green4", "blue2", "gold1", "purple1")) + - theme(legend.justification = c(1, 0), legend.position.inside = c(0.98, 0.02)) - - ggplot() + - geom_hline(yintercept = 75, color = "grey70", linetype = "longdash") + - geom_hline(yintercept = 95, color = "grey70", linetype = "longdash") + - geom_hline(yintercept = 115, color = "grey70", linetype = "longdash") + - geom_hline(yintercept = 135, color = "grey70", linetype = "longdash") + - geom_histogram(aes(y = Cruised_Si, weight = GrossAc), stands2022 %>% filter(Age_2020 < 100, Cruised_Si > 0, siteSpecies == "Douglas-fir"), binwidth = 1, color = "white", fill = "green4") + - annotate("text", x = 1150, y = 145, label = "I", color = "grey70", size = 3) + - annotate("text", x = 1150, y = 125, label = "II", color = "grey70", size = 3) + - annotate("text", x = 1150, y = 105, label = "III", color = "grey70", size = 3) + - annotate("text", x = 1150, y = 85, label = "IV", color = "grey70", size = 3) + - annotate("text", x = 1150, y = 65, label = "V", color = "grey70", size = 3) + - labs(x = "acres of Douglas-fir majority stands cruised winter 2015-2016", y = "Douglas-fir 50-year site index, feet", color = NULL) + - scale_x_continuous(breaks = seq(0, 2000, by = 250)) + - scale_y_continuous(breaks = seq(0, 200, by = 10)) - - ggplot() + - geom_histogram(aes(x = 100 * ..count../sum(..count..), y = siteClass, weight = GrossAc), - stands2022 %>% filter(Age_2020 < 100, Cruised_Si > 0, siteSpecies == "Douglas-fir") %>% mutate(siteClass = factor(if_else(Cruised_Si >= 135, 1, if_else(Cruised_Si >= 115, 2, if_else(Cruised_Si >= 95, 3, if_else(Cruised_Si >= 75, 4, 5)))), levels = seq(5, 1, by = -1), labels = c("V", "IV", "III", "II", "I"))), - fill = "green4", stat = "count") + - labs(x = "percentage of Douglas-fir majority stand area cruised in 2015-2016", y = "Douglas-fir 50-year site class", color = NULL) + - scale_x_continuous(breaks = seq(0, 100, by = 10)) - - ggplot(stands2022 %>% filter(siteSpecies == "Douglas-fir")) + - geom_histogram(aes(x = Age_2020, y = ..density..), binwidth = 5, fill = "green4") + - labs(x = "stand age in 2020, years", y = "probability", color = NULL) -} +# if (htDiaOptions$includeInvestigatory) { +# # site species number of stands +# # PSME 412 +# # hardwood 26 +# # hemlock 6 +# # other 5 +# psmeStands2022 = stands2022 %>% filter(is.na(Cruised_Si) == FALSE, siteSpecies == "Douglas-fir") %>% +# mutate(Elev_MeanSquared = Elev_Mean^2, SlopeMeanPercent = 100 * tan(pi/180 * SlopeMean), SlopeMeanSquared = SlopeMean^2, SlopeMeanPercentSquared = SlopeMeanPercent^2, AWS100squared = AWS100^2, planted = Age_2020 < 100) +# +# psmeSiteIndexPredictorSubsets = regsubsets(x = as.matrix(psmeStands2022 %>% select(Elev_Mean, Elev_MeanSquared, SlopeMeanPercent, SlopeMeanPercentSquared, AspectMean, AspectSin, AspectCos, +# PrecipNorm, AWS025, AWS050, AWS100, AWS100squared, AWS150, planted, X, Y, +# Age_2015, TPA_Total, BA_Total, QMD_Total, BFperAcre_, BA_DF, QMD_DF, LeafRetnDF, BA_WH, QMD_WH, Shape_Area)), +# y = psmeStands2022$Cruised_Si) +# plot(psmeSiteIndexPredictorSubsets) +# +# #psmeSiteIndexModelLinear = lm(Cruised_Si ~ Elev_Mean + Elev_MeanSquared + SlopeMeanPercent + SlopeMeanPercentSquared + AspectSin + AspectCos + PrecipNorm + AWS100 + TPA_Total + BA_Total + QMD_Total + QMD_DF + LeafRetnDF + planted, psmeStands2022) +# #psmeSiteIndexModelLinear = lm(Cruised_Si ~ Elev_MeanSquared + SlopeMeanPercent + SlopeMeanPercentSquared + AspectSin + AspectCos + AWS100 + planted, psmeStands2022) +# psmeSiteIndexModelLinear = lm(Cruised_Si ~ Elev_MeanSquared + SlopeMeanPercentSquared + QMD_DF + planted, psmeStands2022) +# summary(psmeSiteIndexModelLinear) +# psmeSiteIndexModelNonlinear = gsl_nls(Cruised_Si ~ b0 + b1*Elev_Mean^b2 + b3*SlopeMeanPercent^b4 + b5*planted, psmeStands2022, start = list(b0 = 120, b1 = -1E-6, b2 = 2, b3 = -2E-3, b4 = 5, b5 = 20), control = gsl_nls_control(maxiter = 250)) +# c(linear = AIC(psmeSiteIndexModelLinear), nonlinear = AIC(psmeSiteIndexModelNonlinear)) +# +# ggplot(psmeStands2022) + geom_abline(slope = 1, intercept = 0, color = "grey70", linetype = "longdash") + +# geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelLinear), color = planted), alpha = 0.3) + +# labs(x = "measured 50-year site index, feet", y = "linear model prediction, feet", color = NULL) + +# theme(legend.position = "none") + +# ggplot(psmeStands2022) + geom_abline(slope = 1, intercept = 0, color = "grey70", linetype = "longdash") + +# geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelNonlinear, psmeStands2022), color = planted), alpha = 0.3) + +# labs(x = "measured 50-year site index, feet", y = "nonlinear model prediction, feet", color = "stand age") + +# scale_color_discrete(breaks = c(FALSE, TRUE), labels = c("≥100 years", "<100 years")) + +# theme(legend.justification = c(1, 0), legend.position.inside = c(0.98, 0.02)) +# +# ggplot(psmeStands2022) + +# geom_point(aes(x = Cruised_Si, y = -residuals(psmeSiteIndexModelLinear), color = planted), alpha = 0.3, shape = 16) + +# labs(x = "measured 50-year site index, feet", y = "linear model error, feet", color = NULL) + +# theme(legend.position = "none") + +# ggplot(psmeStands2022) + +# geom_point(aes(x = Cruised_Si, y = predict(psmeSiteIndexModelNonlinear, psmeStands2022) - Cruised_Si, color = planted), alpha = 0.3, shape = 16) + +# labs(x = "measured 50-year site index, feet", y = "nonlinear model error, feet", color = "stand age") + +# scale_color_discrete(breaks = c(FALSE, TRUE), labels = c("≥100 years", "<100 years")) + +# theme(legend.justification = c(1, 1), legend.position.inside = c(0.98, 0.98)) +# +# ggplot(psmeStands2022) + geom_point(aes(x = Elev_Mean, y = Cruised_Si), alpha = 0.3, shape = 16) + +# ggplot(psmeStands2022) + geom_point(aes(x = SlopeMeanPercent, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = AspectSin, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = AspectCos, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = TPA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + +# ggplot(psmeStands2022) + geom_point(aes(x = BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = QMD_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = BA_DF / BA_Total, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = PrecipNorm, y = Cruised_Si), alpha = 0.3, shape = 16) + +# ggplot(psmeStands2022) + geom_point(aes(x = AWS100, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = QMD_DF, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) + +# ggplot(psmeStands2022) + geom_point(aes(x = QMD_WH, y = Cruised_Si), alpha = 0.3, shape = 16) + labs(y = NULL) +# +# +# ## aggregate tree distribution plots +# liveUnbrokenTrees2016 = trees2016 %>% filter(isLiveUnbroken) +# ggplot(liveUnbrokenTrees2016) + +# geom_histogram(aes(x = DBH, y = 100 * ..count../sum(..count..), fill = speciesGroup, alpha = isPlantation), binwidth = 2.5, na.rm = TRUE) + +# coord_cartesian(ylim = c(0, 4.4)) + +# labs(x = "DBH, cm", y = "percentage of live, unbroken stems measured", alpha = NULL, fill = NULL) + +# scale_alpha_manual(breaks = c(FALSE, TRUE), labels = c("natural regeneration", "plantation"), values = c(1, 0.7)) + +# scale_fill_manual(breaks = c("DF", "RA", "WH", "BM", "OM", "RC", "other"), values = c("green3", "red2", "blue2", "cyan2", "darkorchid3", "firebrick", "grey35")) + +# theme(legend.position = "none") + +# ggplot(liveUnbrokenTrees2016) + +# geom_histogram(aes(x = 100 * ..count../sum(..count..), y = TotalHt, fill = speciesGroup, alpha = isPlantation), binwidth = 1, na.rm = TRUE) + +# coord_cartesian(xlim = c(0, 4.4)) + +# labs(x = "percentage of live stems measured", y = "height, m", alpha = NULL, fill = NULL) + +# scale_alpha_manual(breaks = c(FALSE, TRUE), labels = c("natural regeneration", "plantation"), values = c(1, 0.7)) + +# scale_fill_manual(breaks = c("DF", "RA", "WH", "BM", "OM", "RC", "other"), labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other"), values = c("green3", "red2", "blue2", "cyan2", "darkorchid3", "firebrick", "grey35")) + +# theme(legend.justification = c(1, 1), legend.position.inside = c(1, 1), legend.spacing.y = unit(0.3, "line")) +# } +# +# +# ## site index plots +# if (htDiaOptions$includeInvestigatory) { +# ggplot(stands2022 %>% filter(Cruised_Si > 0)) + +# geom_point(aes(x = Age_2020, y = Cruised_Si, color = siteSpecies), alpha = 0.6, shape = 16) + +# labs(x = "stand age in 2020, years", y = "50-year site index measured in 2015-2016, feet", color = NULL) + +# guides(color = guide_legend(override.aes = list(alpha = 0.8))) + +# scale_color_manual(breaks = c("Douglas-fir", "hemlock", "hardwood", "other"), values = c("green4", "blue2", "gold1", "purple1")) + +# theme(legend.justification = c(1, 0), legend.position.inside = c(0.98, 0.02)) +# +# ggplot() + +# geom_hline(yintercept = 75, color = "grey70", linetype = "longdash") + +# geom_hline(yintercept = 95, color = "grey70", linetype = "longdash") + +# geom_hline(yintercept = 115, color = "grey70", linetype = "longdash") + +# geom_hline(yintercept = 135, color = "grey70", linetype = "longdash") + +# geom_histogram(aes(y = Cruised_Si, weight = GrossAc), stands2022 %>% filter(Age_2020 < 100, Cruised_Si > 0, siteSpecies == "Douglas-fir"), binwidth = 1, color = "white", fill = "green4") + +# annotate("text", x = 1150, y = 145, label = "I", color = "grey70", size = 3) + +# annotate("text", x = 1150, y = 125, label = "II", color = "grey70", size = 3) + +# annotate("text", x = 1150, y = 105, label = "III", color = "grey70", size = 3) + +# annotate("text", x = 1150, y = 85, label = "IV", color = "grey70", size = 3) + +# annotate("text", x = 1150, y = 65, label = "V", color = "grey70", size = 3) + +# labs(x = "acres of Douglas-fir majority stands cruised winter 2015-2016", y = "Douglas-fir 50-year site index, feet", color = NULL) + +# scale_x_continuous(breaks = seq(0, 2000, by = 250)) + +# scale_y_continuous(breaks = seq(0, 200, by = 10)) +# +# ggplot() + +# geom_histogram(aes(x = 100 * ..count../sum(..count..), y = siteClass, weight = GrossAc), +# stands2022 %>% filter(Age_2020 < 100, Cruised_Si > 0, siteSpecies == "Douglas-fir") %>% mutate(siteClass = factor(if_else(Cruised_Si >= 135, 1, if_else(Cruised_Si >= 115, 2, if_else(Cruised_Si >= 95, 3, if_else(Cruised_Si >= 75, 4, 5)))), levels = seq(5, 1, by = -1), labels = c("V", "IV", "III", "II", "I"))), +# fill = "green4", stat = "count") + +# labs(x = "percentage of Douglas-fir majority stand area cruised in 2015-2016", y = "Douglas-fir 50-year site class", color = NULL) + +# scale_x_continuous(breaks = seq(0, 100, by = 10)) +# +# ggplot(stands2022 %>% filter(siteSpecies == "Douglas-fir")) + +# geom_histogram(aes(x = Age_2020, y = ..density..), binwidth = 5, fill = "green4") + +# labs(x = "stand age in 2020, years", y = "probability", color = NULL) +# } ## stand tree pooling @@ -2465,10 +2452,11 @@ if (htDiaOptions$includeInvestigatory) { expansionFactor = meanTreesPerBafPlot / meanTreesPerBafMeasurePlot * measureTreeTphContribution / measurePlotsInStand, species = case_match(Species, "DF" ~ "PSME", "RA" ~ "ALRU", "WH" ~ "TSHE", "BM" ~ "ACMA", "OM" ~ "UMCA", "RC" ~ "THPL", "CH" ~ "CHCH", "HX" ~ "CONU", "TO" ~ "LIDE"), condition = as.integer(isLiveUnbroken == FALSE)) %>% - rename(stand = StandID, plot = PlotID, tree = TreeID, age = standAge2016, dbh = DBH, height = imputedHeight) %>% - select(stand, plot, tree, species, year, age, dbh, height, expansionFactor, condition) - #treesOfAge %>% group_by(species) %>% summarize(n = n()) - #treesOfAge %>% group_by(stand) %>% summarize(uniqueTrees = n(), tph = sum(expansionFactor)) + # rename(stand = StandID, plot = PlotID, tree = TreeID, age = standAge2016, dbh = DBH, height = imputedHeight) %>% + # select(stand, plot, tree, species, year, age, dbh, height, expansionFactor, condition) + select(StandID, PlotID, treeID, species, year, standAge2016, DBH, imputedHeight, expansionFactor, condition) + treesOfAge %>% group_by(species) %>% summarize(n = n()) + treesOfAge %>% group_by(StandID) %>% summarize(uniqueTrees = n(), tph = sum(expansionFactor)) } From af2b11cd08454f9a59292d46a415e107697432f0 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Sat, 24 May 2025 08:22:42 -0700 Subject: [PATCH 05/13] update rhpu for public dataset --- trees/height-diameter/RHPU.R | 795 +++++++++++++++++++++++++++++++++++ 1 file changed, 795 insertions(+) create mode 100644 trees/height-diameter/RHPU.R diff --git a/trees/height-diameter/RHPU.R b/trees/height-diameter/RHPU.R new file mode 100644 index 0000000..2403c77 --- /dev/null +++ b/trees/height-diameter/RHPU.R @@ -0,0 +1,795 @@ +# load libraries, functions, and trees2016 from Elliott Stand Data Feb2022.R + + +## cascara buckthorn height-diameter regression form sweep + +#rhpu HeightFromDiameter$gamPhysio = gam(TotalHt ~ s(DBH, elevation, slope, sin(3.14159/180 * aspect), cos(3.14159/180 * aspect), topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 85, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, select = TRUE, weights = dbhWeight) + +# bs= "ts" -> 367, gamma = 2 -> 367, k = 169 min vs 367 default, method = "REML" -> 367 + +#rhpu HeightFromDiameter$sharmaPartonBalPhysio = gsl_nls(TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^(a2 + a2p * isPlantation) * (1 + a3 * elevation + a4 * sin(3.14159/180 * aspect) + a5 * cos(3.14159/180 * aspect) + a6 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^(b2 + b2p * isPlantation)*DBH))^(b3 + b3p * isPlantation), rhpu2016, start = list(a1 = 39.8, a1p = -12.3, a2 = 0.52, a2p = 0.0027, a3 = 0.00001, a4 = 0.0131, a5 = 0.0046, a6 = 0.0060, b1 = -0.0098, b1p = -0.0143, b2 = 0.125, b2p = -0.186, b3 = 1.12, b3p = 0.0086), weights = rhpuHeightFromDiameterWeights) + +rhpu2016 = trees2016 %>% + filter(Species == "RHPU", isLiveUnbroken, is.na(TotalHt) == FALSE) %>% # live cascara buckthorns measured for height + mutate(dbhWeight = pmin(TreeCount/(0.14*DBH^1.20), 5*TreeCount), + heightWeight = pmin(TreeCount/(2.29*(TotalHt - 1.37)^1.45), 5*TreeCount)) + +# no trees without physiographic variables +rhpu2016gamConstraint = c(DBH = -1.2264/0.5099, TotalHt = 1.37, standBasalAreaPerHectare = median(rhpu2016$standBasalAreaPerHectare), basalAreaLarger = median(rhpu2016$basalAreaLarger), standBasalAreaApprox = median(rhpu2016$standBasalAreaApprox), tallerApproxBasalArea = median(rhpu2016$tallerApproxBasalArea), elevation = median(rhpu2016$elevation), slope = median(rhpu2016$slope), aspect = median(rhpu2016$aspect), topographicShelterIndex = median(rhpu2016$topographicShelterIndex), relativeHeight = median(rhpu2016$relativeHeight), relativeDiameter = median(rhpu2016$relativeDiameter)) # point constraint for mgcv::s() + +rhpu2016defaultWeight = rhpu2016 %>% mutate(dbhWeight = pmin(TreeCount/DBH, 5*TreeCount), + heightWeight = pmin(TreeCount/TotalHt, 5*TreeCount)) +rhpu2016defaultWeightPhysio = rhpu2016defaultWeight %>% filter(is.na(elevation) == FALSE) + +# rhpuOptions = tibble(fitHeight = TRUE, +# fitHeightNlrob = FALSE, +# fitHeightGnls = FALSE, +# fitHeightMixed = FALSE, +# fitDbh = TRUE, +# fitDbhNlrob = FALSE, +# fitDbhMixed = FALSE) + +#make a tibble to store the parameters and later call them into the code +rhpuOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response + fitHeightNlrob = TRUE, #robust non-linear least square, height as response + fitHeightGnls = FALSE, #generalized least square, height as response + fitHeightMixed = FALSE, #non-linear mixed effects, height as response + fitDbh = TRUE, #non-linear least square, dbh as response + fitDbhNlrob = FALSE, #robust non-linear least square, dbh as response + fitDbhMixed = FALSE, #non-linear mixed effects, dbh as response + includeInvestigatory = TRUE #added investigatory plots, and figures of the results +) + +if (rhpuOptions$fitHeight) { #if the value in the column fitHeight of rhpuOptions table is TRUE execute the expression within the curly braces. + rhpuHeightFromDiameter = list(linear = fit_lm("linear", TotalHt ~ 0 + DBH, rhpu2016)) # isPlantation*DBH not significant (p = 0.044) #creates output from the model fitting and validation 10*10=100 rows of all combination of folds and repetition and stores it as a list and adds all the following models in a similar fashion to the existing list (notice the $ sign in the code from the second line withing the curly braces) + rhpuHeightFromDiameter$parabolic = fit_lm("parabolic", TotalHt ~ 0 + DBH + I(DBH^2), rhpu2016) # isPlantation*DBH not quite significant (p = 0.106), isPlantation*DBH^2 not significant + + rhpuHeightFromDiameter$chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131)) # a1p, b1p, b2p not significant + rhpuHeightFromDiameter$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) # a3, a3p, b1p, b2p not significant + rhpuHeightFromDiameter$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) # a2, a3, a4, a5, a6, a7, a8p, b2p not significant + #rhpuHeightFromDiameter$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -16, a2 = 0, a2p = 0.4, a8 = 0.3, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) # a2, a10, a10p not significant + #rhpuHeightFromDiameter$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.3, b1 = -0.012, b2 = 1.1), significant = FALSE) # a2, a10, a10p not significant + rhpuHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() + rhpuHeightFromDiameter$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) # a4, a5, a6, a7, a8p, b2p not significant + #rhpuHeightFromDiameter$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 72, a10 = -3.2, b1 = -0.012, b2 = 1.09)) # a10p not significant + #rhpuHeightFromDiameter$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) # a10, a10p not significant + rhpuHeightFromDiameter$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, rhpu2016, start = list(a1 = 0.560, b1 = 0.069)) # a1p, b1p not significant + rhpuHeightFromDiameter$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) # b2p not significant + rhpuHeightFromDiameter$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), rhpu2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) # a1p, b1p, b2p not significant + rhpuHeightFromDiameter$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) # b1p not significant + rhpuHeightFromDiameter$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), rhpu2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) # a2p, a3p not significant + rhpuHeightFromDiameter$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, rhpu2016, start = list(a1 = 0.542, b1 = 0.939)) # a1p, b1p not significant + rhpuHeightFromDiameter$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #rhpuHeightFromDiameter$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) # dp not significant, susceptible to NaN-inf + #rhpuHeightFromDiameter$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)) # a1p, b3p, b4p not significant + rhpuHeightFromDiameter$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)) # a1p, b1p, b2p, b3p, b4p not significant + #rhpuHeightFromDiameter$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) # b1, b1p, a4, a5, a6, a7, b3p, b4p not significant + #rhpuHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant + #rhpuHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant + #rhpuHeightFromDiameter$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) # a4, a5, a5, a6, a7, b1p, b3p, b4p not significant + #rhpuHeightFromDiameter$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 21, a10 = 0, b1 = 0.25, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = 0, b4 = 1.12), significant = FALSE) # a10, a10p not significant + #rhpuHeightFromDiameter$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 36, a8 = 0.18, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = -0.03, b4 = 1.09), significant = FALSE) # a1p, a10, a10p, b2p not significant + #rhpuHeightFromDiameter$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) # b1, b1p, b2p, b3p not significant + #rhpuHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant + rhpuHeightFromDiameter$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) # a1p, b1p, b2p not significant + rhpuHeightFromDiameter$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) # b2p not significant + #rhpuHeightFromDiameter$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) # a1p, a2, a3, b1p, b2p not significant + rhpuHeightFromDiameter$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) # a1p, a2, a3, a3p, b1p, b2p not significant + + if (rhpuOptions$fitHeightNlrob) + { + rhpuHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 5.2, b1 = 0.015, b2 = 1.131))) + rhpuHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + rhpuHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + rhpuHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) + rhpuHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) + rhpuHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor + rhpuHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + rhpuHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) + rhpuHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) + rhpuHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, rhpu2016, start = list(a1 = 0.560, b1 = 0.069)) + rhpuHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + rhpuHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), rhpu2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + rhpuHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + rhpuHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), rhpu2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + rhpuHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, rhpu2016, start = list(a1 = 0.542, b1 = 0.939)) + rhpuHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + rhpuHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor + rhpuHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor + rhpuHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor + rhpuHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor + rhpuHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor + rhpuHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor + rhpuHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor + rhpuHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) + rhpuHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) + rhpuHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant + rhpuHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor + rhpuHeightFromDiameterNlrob$sibbesen = fit_nlrob("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + rhpuHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor + rhpuHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + rhpuHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + lapply(rhpuHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) + } else { + rhpuHeightFromDiameterNlrob = list() + } + #fitting models with defaultweight 'rhpu2016defaultWeight' which were fitted earlier without any weights. + #commented out models without any note at the end did not converge, for others the note is given mentioning the reason of error. + rhpuHeightFromDiameterGslNlsDefault = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) + #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016defaultWeight, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a3 = -0.03, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) + #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -14, a2 = -0.07, a2p = 0.48, a8 = 0.27, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) + #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.11), significant = FALSE) + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 74, a10 = -3.2, b1 = -0.011, b2 = 1.09)) + #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) #produced NA or infinity + rhpuHeightFromDiameterGslNlsDefault$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, rhpu2016defaultWeight, start = list(a1 = 0.560, b1 = 0.069)) + rhpuHeightFromDiameterGslNlsDefault$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + rhpuHeightFromDiameterGslNlsDefault$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), rhpu2016defaultWeight, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + rhpuHeightFromDiameterGslNlsDefault$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + rhpuHeightFromDiameterGslNlsDefault$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), rhpu2016defaultWeight, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + rhpuHeightFromDiameterGslNlsDefault$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, rhpu2016defaultWeight, start = list(a1 = 0.542, b1 = 0.939)) + rhpuHeightFromDiameterGslNlsDefault$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016defaultWeight, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #rhpuHeightFromDiameterGslNlsDefault$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016defaultWeight, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) #produced NA or infinity + #rhpuHeightFromDiameterGslNlsDefault$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09))#produced NA or infinity + rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 38, b1 = 0.12, b2 = -0.013, b3 = -0.1, b4 = 1.02)) + rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) + #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 23, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.01, b2p = -0.010, b3 = -0.012, b4 = 1.14), significant = FALSE)#produced NA or infinity + #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE)#produced NA or infinity + #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09))#produced NA or infinity + #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 19, a10 = -0.3, b1 = 0.29, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.03, b4 = 1.13), significant = FALSE)#produced NA or infinity + rhpuHeightFromDiameterGslNlsDefault$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 36, a8 = 0.18, a10 = 0, b1 = 0.2, b2 = -0.01, b3 = 0.03, b4 = 1.09), significant = FALSE) + #rhpuHeightFromDiameterGslNlsDefault$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016defaultWeight, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) + rhpuHeightFromDiameterGslNlsDefault$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 53.2, a1p = -8.857, a2 = -0.002, a2p = 0.10, b1 = -0.016, b2 = -0.025, b3 = -0.078, b4 = 1.126)) + #rhpuHeightFromDiameterGslNlsDefault$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016defaultWeight, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + rhpuHeightFromDiameterGslNlsDefault$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) + #rhpuHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + rhpuHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + # + # rhpuHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + # rhpuHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + # rhpuHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # k reduces from 85 to 18 without aspect + # rhpuHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + + save(file = "data/rhpu TotalHt.Rdata", rhpuHeightFromDiameter, rhpuHeightFromDiameterNlrob, rhpuHeightFromDiameterGslNlsDefault) +} +if (htDiaOptions$includeInvestigatory) +{ + print(rhpuHeightFromDiameterResults %>% select(-responseVariable, -species, -fixedWeight, -n, -power, -significant, -contains("NaturalRegen"), -contains("Plantation")), n = 30) + ggplot() + + geom_point(aes(x = rhpu2016$DBH, y = rhpu2016$TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$sharmaZhang), color = "Sharma-Zhang", group = rhpu2016$isPlantation), alpha = 0.5) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$sharmaParton), color = "Sharma-Parton", group = rhpu2016$isPlantation), alpha = 0.5) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$chapmanRichards), color = "Chapman-Richards", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$curtis), color = "Curtis", group = rhpu2016$isPlantation)) + + geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$gam), color = "GAM", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$korf), color = "Korf", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$linear), color = "linear", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$michaelisMenten), color = "Michaelis-Menten", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$parabolic), color = "parabolic", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$power), color = "power", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$prodan), color = "Prodan", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$ratkowsky), color = "Ratkowsky", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$richardsW), color = "unified Richards", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$sibbesen), color = "Sibbesen", group = rhpu2016$isPlantation)) + + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$weibull), color = "Weibull", group = rhpu2016$isPlantation)) + + annotate("text", x = 0, y = 65, label = "cascara buckthorn, height from diameter", hjust = 0, size = 3.5) + + coord_cartesian(ylim = c(0, 65)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + theme(legend.justification = c(1, 0), legend.position = c(1, 0.03)) + + # dbhClassSize = 50 + # errorByDbhClass = tibble(dbhClass = dbhClassSize*floor(rhpu2016$DBH/dbhClassSize) + 0.5*dbhClassSize, fittedValue = predict(rhpuHeightFromDiameter$gam, rhpu2016), height = rhpu2016$TotalHt, residual = fittedValue - height) %>% + # #mutate(residual = residual - if_else(dbhClass == 50, -0.477/376, 0.107/95)) %>% + # group_by(dbhClass) %>% + # summarize(n = n(), + # totalHeight = sum(height), + # totalFitted = sum(fittedValue), + # meanBiasPerTree = sum(residual) / n, + # meanBiasPerTreePct = 100 * sum(residual/height) / n, + # minError = min(residual), + # meanError = mean(residual), + # maxError = max(residual), + # minPct = 100 * min(residual/height), + # meanPct = 100 * mean(residual/height), + # maxPct = 100 * max(residual/height), + # .groups = "drop") %>% + # filter(n >= 10) + # errorByDbhClass +} + + +## cascara buckthorn height-diameter GNLS regressions +if (rhpuOptions$fitHeightGnls) +{ + rhpuHeightFromDiameterGnls = list(chapmanRichards = fit_gnls("Chapman-Richards GNLS", TotalHt ~ 1.37 + a1*(1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), control = gnlsControl(nlsTol = 0.001))) # step halving at nlsTol = 1 with corSymm + #rhpuHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, rhpu2016, start = rhpuHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + rhpuHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + rhpuHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #rhpuHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = rhpuHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation + rhpuHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + rhpuHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = rhpuHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped + rhpuHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = rhpuHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm + + save(file = "data/rhpu TotalHt gnls.Rdata", rhpuHeightFromDiameterGnls) +} +if (htDiaOptions$includeInvestigatory) +{ + rhpuHeightFromDiameterResultsGnls %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic) %>% arrange(method) + + #bind_cols(parameter = c("a1", "a2", "a3", "b1", "b2"), bal = confint2(rhpuHeightFromDiameter$weibullBAL, level = 0.99), balN = confint2(rhpuHeightFromDiameter$weibullBalNatural, level = 0.99), balP = confint2(rhpuHeightFromDiameter$weibullBalPlantation, level = 0.99)) %>% + # mutate(bal005 = bal[, 1], bal995 = bal[, 2], balN005 = balN[, 1], balN995 = balN[, 2], balP005 = balP[, 1], balP995 = balP[, 2]) %>% + # select(-bal, -balN, -balP) + ggplot() + + geom_point(aes(x = rhpu2016natural$DBH, y = rhpu2016natural$TotalHt), alpha = 0.15, color = "navyblue", na.rm = TRUE, shape = 16) + + geom_smooth(aes(x = rhpu2016natural$DBH, y = rhpu2016natural$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "natural regeneration DBH, cm", y = "cascara buckthorn naturally regenerated height, m") + + ggplot() + + geom_point(aes(x = rhpu2016plantation$DBH, y = rhpu2016plantation$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + + geom_smooth(aes(x = rhpu2016plantation$DBH, y = rhpu2016plantation$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "plantation DBH, cm", y = "cascara buckthorn plantation height, m") + + ggplot() + + geom_point(aes(x = rhpu2016$DBH, y = rhpu2016$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + + geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$weibullBal), color = "Weibull BA+L"), alpha = 0.5) + # Temesgen et al. 2007, Eq. 5 + geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$power), color = "power")) + + geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$weibull), color = "Weibull")) + + annotate("text", x = 0, y = 85, label = "a) cascara buckthorn, height from diameter", hjust = 0, size = 3.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + scale_color_manual(breaks = c("base", "ElliottWeibull", "ElliottBAL", "ElliottBALn", "ElliottBALp", "TemesgenWeibull"), labels = c(bquote("1.37 + b"[0]*"DBH"^{b[1]}), "Weibull", "Weibull with BA+L", "Weibull with BA+L, natural regeneration", "Weibull with BA+L, plantation", "Weibull, Temesgen et al. 2007"), values = c("#ac92eb", "#4dc1e8", "#a0d568", "#ffce54", "#ed5564", "grey65")) + + scale_y_continuous(breaks = seq(0, 100, by = 20)) + + theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) +} + + +if (rhpuOptions$fitHeightMixed){ #fitting height diameter using mixed effect models + rhpuHeightFromDiameterMixed = list(chapmanRichards = fit_nlme("Chapman-Richards", TotalHt ~ 1.37 + (a1 + a1r)*(1 - exp(b1*DBH))^b2, rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 48.2, b1 = -0.015, b2 = 1.131)), control = nlmeControl(maxIter = 250))) + rhpuHeightFromDiameterMixed$chapmanRichardsBal = fit_nlme("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)), control = nlmeControl(maxIter = 500)) + rhpuHeightFromDiameterMixed$chapmanRichardsBalPhysio = fit_nlme("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, + fixedFormula = a1 + a1p + a2 + a2p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12)), control = nlmeControl(maxIter = 250), significant = FALSE) + rhpuHeightFromDiameterMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, + fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15))) + # rhpuHeightFromDiameterMixed$curtis = fit_nlme("Curtis", TotalHt ~ 1.37 + (a1 + a1r) * DBH / (1 + DBH)^b1, rhpu2016, + # fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 0.560, b1 = 0.069)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # max iterations in job + rhpuHeightFromDiameterMixed$hossfeld = fit_nlme("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, + fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)), control = nlmeControl(maxIter = 250)) + rhpuHeightFromDiameterMixed$korf = fit_nlme("Korf", TotalHt ~ 1.37 + (a1 + a1r)*exp(b1*DBH^b2), rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1825, b1 = -8.726, b2 = -0.175)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations + rhpuHeightFromDiameterMixed$michaelisMenten = fit_nlme("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)), control = nlmeControl(maxIter = 250)) # job >100 iterations + rhpuHeightFromDiameterMixed$prodan = fit_nlme("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3 + a3r), rhpu2016, + fixedFormula = a1 + a1p + a2 + a3 ~ 1, randomFormula = a3r ~ 1, + start = list(fixed = c(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649))) + rhpuHeightFromDiameterMixed$power = fit_nlme("power", TotalHt ~ 1.37 + (a1 + a1r)*DBH^b1, rhpu2016, + fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 0.542, b1 = 0.939)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) # job >500 iterations without relaxed tolerances + #rhpuHeightFromDiameterMixed$ratkowsky = fit_nlme("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, + # fixedFormula = a1 + a1p + b1 + b1p + b2 + b2p ~ 1, randomFormula = a1r ~ 1, + #start = list(fixed = c(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151))) + #rhpuHeightFromDiameterMixed$richardsW = fit_nlme("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation + Har) * (1 + ((1.37/(Ha + Hap*isPlantation + Har))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016, + #fixedFormula = Ha + Hap + d + kU + kUp ~ 1, randomFormula = Har ~ 1, + #start = list(fixed = c(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008))) + rhpuHeightFromDiameterMixed$sharmaParton = fit_nlme("Sharma-Parton", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, + fixedFormula = a1 + b1 + b1p + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + rhpuHeightFromDiameterMixed$sharmaPartonBal = fit_nlme("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, + fixedFormula = a1 + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve, step halving + rhpuHeightFromDiameterMixed$sharmaPartonBalPhysio = fit_nlme("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, + fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + rhpuHeightFromDiameterMixed$sharmaPartonPhysio = fit_nlme("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, + fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 1E-3)) # singular precision matrix, step halving + rhpuHeightFromDiameterMixed$sharmaZhang = fit_nlme("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, + fixedFormula = a1 + a1p + b1 + b2 + b3 + b4 + b4p ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + rhpuHeightFromDiameterMixed$sharmaZhangBal = fit_nlme("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + #rhpuHeightFromDiameterMixed$sibbesen = fit_nlme("Sibbesen", TotalHt ~ 1.37 + a1*DBH^((b1 + b1r)*DBH^b2), rhpu2016, + # fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = b1r ~ 1, + # start = list(fixed = c(a1 = 0.302, b1 = 1.495, b2 = -0.078))) # a1r: step halving, singular precision + rhpuHeightFromDiameterMixed$weibull = fit_nlme("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, + fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141))) + rhpuHeightFromDiameterMixed$weibullBal = fit_nlme("Weibull BA+L", TotalHt ~ 1.37 + (a1 + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, + fixedFormula = a1 + a2 + a2p + a3 + a3p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131))) + + rhpuHeightFromDiameterMixed$gamm = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8) + s(StandID, bs = "re"), data = rhpu2016, mixed = TRUE) + rhpuHeightFromDiameterMixed$gammBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13) + s(StandID, bs = "re"), data = rhpu2016, mixed = TRUE) + + save(file = "data/rhpu TotalHt mixed.Rdata", rhpuHeightFromDiameterMixed) +} + + +## Cascara buckthorn diameter-height regressions +if (rhpuOptions$fitDbh) { + rhpuDiameterFromHeight = list(linear = fit_lm("linear", DBH ~ 0 + I(TotalHt - 1.37), rhpu2016)) # isPlantation*(TotalHt - 1.37) not significant + rhpuDiameterFromHeight$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), rhpu2016) # (TotalHt - 1.37)^2 not significant + + #rhpuDiameterFromHeight$chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 500, xtol = 1E-5)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: singular gradient with nls(), no convergence from nls_multstart(), NaN-inf with nlrob() + #rhpuDiameterFromHeight$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # NaN-inf with nls() and nlrob + # rhpuDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() + # rhpuDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 + # rhpuDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() + #rhpuDiameterFromHeight$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) # a1p and b2p not significant, poor convergence with b1p, step factor with nlrob() + rhpuDiameterFromHeight$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # a1p, b1p not significant, step factor with nlrob() + rhpuDiameterFromHeight$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) # no physiographic effects significant, a1-b1 parameter evaporation: step factor with nlrob() + rhpuDiameterFromHeight$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) # step factor with nlrob() + rhpuDiameterFromHeight$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), rhpu2016, start = list(a1 = 519, a2 = 237, b1 = 1.00)) # a1p, a2p, b1p not significant, singular gradient with nlrob() + #rhpuDiameterFromHeight$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), rhpu2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) + rhpuDiameterFromHeight$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.93, b1 = 1.08)) # no significant plantation effects + rhpuDiameterFromHeight$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) # no significant plantation effects + rhpuDiameterFromHeight$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) # no significant physiographic effects + rhpuDiameterFromHeight$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) # a1p and b1p not significant + rhpuDiameterFromHeight$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) # a1p, b1p, b2p not significant + #rhpuDiameterFromHeight$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) # a2, a2p, a3, a3p, b1p, b2p not significant + rhpuDiameterFromHeight$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.9, a2 = -0.005, a4 = -0.001, b1 = 0.93, b2 = 0.006), significant = FALSE) # a2, a3 not significant, no AIC discrimination + rhpuDiameterFromHeight$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = -1, b1 = 0.9, b2 = 0), significant = FALSE) # a2, a3, a4, a9, b2 not significant, drop ABA on AIC + #rhpuDiameterFromHeight$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.7, a3 = 0, a9 = 0, b1 = 0.95, b2 = 0.005), significant = FALSE) # a9, a9p, b2 not significant + rhpuDiameterFromHeight$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) # a1p, a5, a6, a7, a8, b1p, b2p not significant + rhpuDiameterFromHeight$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) # a9, a9p, b1p, b2, b2p not significant + rhpuDiameterFromHeight$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 3.2, a4 = 0, a9 = -1, b1 = 0.9, b2 = 0.01), significant = FALSE) # a4, a9 not significant + #rhpuDiameterFromHeight$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), rhpu2016, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) # singular gradient with nlrob() and gsl_nls() + #rhpuDiameterFromHeight$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, rhpu2016, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) # a1-b2 evaporation, b1, b3 not significant, NaN-inf with nls() from nls_multstart() point, NaN-inf, singular gradient, or code syntax error with nlrob() + rhpuDiameterFromHeight$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) # no significant plantation effects + rhpuDiameterFromHeight$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029), significant = FALSE) # no significant plantation effects + rhpuDiameterFromHeight$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) # a2, a3, a8 not significant, drop ABA on AIC + rhpuDiameterFromHeight$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.017, a9 = 1.0, b1 = 0.7, b2 = 0), significant = FALSE) # a2, a3, a8, a9, b2 not significant, no a2-a3 AIC discrimination + rhpuDiameterFromHeight$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.5, a2 = 0, a9 = 0, a9p = 0, b1 = 0.6, b2 = 0.12), significant = FALSE) # a2, a9, a9p, b2 not significant + rhpuDiameterFromHeight$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) # a1p, no physiographic effects significant + rhpuDiameterFromHeight$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + rhpuDiameterFromHeight$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.6, a8 = -0.01, a9 = 0.7, b1 = 0.7, b2 = 0.1), significant = FALSE) # a9 not significant + #rhpuDiameterFromHeight$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, rhpu2016, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: NaN-inf with nlrob() + lapply(rhpuDiameterFromHeight$chapmanReplaceAbat$fit, confint2, level = 0.99) + lapply(rhpuDiameterFromHeight$chapmanReplaceAbat$fit, get_model_coefficients) + + if (rhpuOptions$fitDbhNlrob) + { + rhpuDiameterFromHeightNlrob = list(naslund = fit_nlrob("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), rhpu2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) + #rhpuDiameterFromHeightNlrob$power = fit_nlrob("power", DBH ~ a1*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.93, b1 = 1.08)) + #rhpuDiameterFromHeightNlrob$powerAbat = fit_nlrob("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + #rhpuDiameterFromHeightNlrob$powerPhysio = fit_nlrob("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + #rhpuDiameterFromHeightNlrob$powerRelHt = fit_nlrob("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + rhpuDiameterFromHeightNlrob$ruark = fit_nlrob("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) + rhpuDiameterFromHeightNlrob$ruarkAbat = fit_nlrob("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # occasional job step factor + rhpuDiameterFromHeightNlrob$ruarkAbatPhysio = fit_nlrob("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.9, a2 = 0, a4 = -0.001, b1 = 0.93, b2 = 0.006), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # step factor + rhpuDiameterFromHeightNlrob$ruarkAbatPhysioRelHt = fit_nlrob("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = 2.3, b1 = 0.9, b2 = 0), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + rhpuDiameterFromHeightNlrob$ruarkAbatRelHt = fit_nlrob("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.4, a3 = 0, a9 = 3, b1 = 0.8, b2 = 0.01), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor + rhpuDiameterFromHeightNlrob$ruarkPhysio = fit_nlrob("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + rhpuDiameterFromHeightNlrob$ruarkRelHt = fit_nlrob("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) + rhpuDiameterFromHeightNlrob$ruarkRelHtPhysio = fit_nlrob("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, start = list(a1 = 3.2, a4 = -0.001, a9 = 1, b1 = 0.8, b2 = 0), significant = FALSE) # a4, a9, b2 not significant + rhpuDiameterFromHeightNlrob$sibbesenReplace = fit_nlrob("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) + rhpuDiameterFromHeightNlrob$sibbesenReplaceAbat = fit_nlrob("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.1, a2 = -0.004, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4)) # job step factor + rhpuDiameterFromHeightNlrob$sibbesenReplaceAbatPhysio = fit_nlrob("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) + rhpuDiameterFromHeightNlrob$sibbesenReplaceAbatPhysioRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.01, a9 = 0.5, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor + rhpuDiameterFromHeightNlrob$sibbesenReplaceAbatRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.1, a2 = 0, a9 = 0, a9p = 0.7, b1 = 0.6, b2 = 0.12), significant = FALSE) + rhpuDiameterFromHeightNlrob$sibbesenReplacePhysio = fit_nlrob("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + rhpuDiameterFromHeightNlrob$sibbesenReplaceRelHt = fit_nlrob("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + rhpuDiameterFromHeightNlrob$weibull = fit_nlrob("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, rhpu2016, start = list(a1 = -250, b1 = 0.043, b2 = 0.58), control = nls.control(maxiter = 500)) + confint_nlrob(rhpuDiameterFromHeight$sibbesenReplacePhysio, level = 0.99, weights = pmin(rhpu2016$TotalHt^if_else(rhpu2016$isPlantation, -1.7, -1.6), 0.5)) + } else { + rhpuDiameterFromHeightNlrob = list() + } + rhpuDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) + rhpuDiameterFromHeightGslNlsDefault$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016defaultWeight, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) + #rhpuDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) + rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) + rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), rhpu2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) + rhpuDiameterFromHeightGslNlsDefault$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) + rhpuDiameterFromHeightGslNlsDefault$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.93, b1 = 1.08)) + #rhpuDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + #rhpuDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, rhpu2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + rhpuDiameterFromHeightGslNlsDefault$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) + rhpuDiameterFromHeightGslNlsDefault$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a2 = -0.01, a4 = -0.0006, b1 = 1.2, b2 = -0.009), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a3 = -0.003, a4 = -0.0006, a9 = 0.4, b1 = 1.27, b2 = -0.01), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 1.3, a3 = -0.003, a9 = 0.25, b1 = 1.3, b2 = -0.008), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant + #rhpuDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), rhpu2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) + rhpuDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, rhpu2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) + rhpuDiameterFromHeightGslNlsDefault$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeight, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) + rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeight, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)) + rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeightPhysio, start = list(a1 = 1.5, a2 = -0.009, a8 = -0.005, b1 = 1.2, b2 = -0.04), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeightPhysio, start = list(a1 = 1.41, a2 = -0.009, a8 = -0.005, a9 = 0, b1 = 1.4, b2 = -0.05), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeight, start = list(a1 = 1.5, a2 = -0.008, a9 = 0, a9p = 0, b1 = 1.4, b2 = 0), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeight, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + #rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant + #rhpuDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, rhpu2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) + + # # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined + # rhpuDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # newton() step failure with scat() + # rhpuDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop ABA and elevation on AIC + # rhpuDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop elevation and topographic shelter on AIC + # rhpuDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + # rhpuDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop elevation and aspect on AIC + + save(file = "data/rhpu DBH.Rdata", rhpuDiameterFromHeight, rhpuDiameterFromHeightNlrob, rhpuDiameterFromHeightGslNlsDefault) +} +if (htDiaOptions$includeInvestigatory) { + print(rhpuDiameterFromHeightResults %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic), n = 25) + + ggplot(rhpu2016) + + geom_point(aes(x = DBH, y = TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$sharmaParton), y = TotalHt, color = "modified Sharma-Parton", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$chapmanReplace), y = TotalHt, color = "Chapman-Richards replace", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$chapmanReplaceAbat), y = TotalHt, color = "Chapman-Richards replace approximate BA+L", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$chapmanReplaceBal), y = TotalHt, color = "Chapman-Richards replace BA+L", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$chapmanRichards), y = TotalHt, color = "Chapman-Richards", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$michaelisMentenReplace), y = TotalHt, color = "Michaelis-Menten replace", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$naslund), y = TotalHt, color = "Näslund", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$power), y = TotalHt, color = "power", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$ruark), y = TotalHt, color = "Ruark", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$schnute), y = TotalHt, color = "Schnute inverse", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$sibbesenReplace), y = TotalHt, color = "Sibbesen replace", group = isPlantation)) + + #geom_line(aes(x = predict(rhpuDiameterFromHeight$weibull), y = TotalHt, color = "Weibull", group = isPlantation)) + + #geom_line(aes(x = 5*standBasalAreaPerHectare^0.5 * exp(0.0005*tph^0.5*(TotalHt - 1.37))^1, y = TotalHt, color = "Sharma-Zhang"), alpha = 0.5) + + #geom_line(aes(x = -100 * log(1 - pmin(0.015*(TotalHt - 1.37)^1.0, 0.999)), y = TotalHt, color = "Chapman-Richards inversion"), na.rm = TRUE) + + #geom_line(aes(x = 0.5*(TotalHt - 1.37)^1*exp(0.02*(tph/topHeight)^0.26*(TotalHt - 1.37))^0.9, y = TotalHt, color = "modified Sharma-Parton", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 15 * (exp(0.1*(TotalHt - 1.37)) - 1)^0.45, y = TotalHt, color = "Chapman-Richards replace", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 15 * (exp(0.1*(TotalHt - 1.37)) - 1)^0.35, y = TotalHt, color = "Chapman-Richards replace", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = (1.75 + 0.000001 * tallerApproxBasalArea + -0.000001 * standBasalAreaApprox) * exp(1.46*(TotalHt - 1.37)^0.280), y = TotalHt, color = "Chapman-Richards replace ABA+T", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 0.03*topHeight*exp(1.6*(TotalHt - 1.37)^0.26), y = TotalHt, color = "Chapman-Richards replace top height", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = -1/0.0003*log(1 - (1 - exp(-0.1))*(TotalHt^1.5 - 1.37^1.5)/(75^1.5 - 1.37^1.5)), y = TotalHt, color = "Schnute inverse"), alpha = 0.5) + + geom_line(aes(x = 30*topHeight^0.5*(exp(0.01 * (tph/standBasalAreaPerHectare)^0.25*(TotalHt - 1.37)) - 1)^0.5, y = TotalHt, color = "modified Sharma-Parton"), alpha = 0.5) + + annotate("text", x = 0, y = 62, label = "cascara buckthorn, diameter from height", hjust = 0, size = 3.5) + + #coord_cartesian(xlim = c(0, 250), ylim = c(0, 90)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + #scale_color_manual(breaks = c(FALSE, TRUE, "Chapman-Richards"), values = c("grey25", "transparent", "red")) + + #scale_color_manual(breaks = c(FALSE, TRUE, "Chapman-Richards"), values = c("transparent", "grey25", "red")) + + scale_y_continuous(breaks = seq(0, 100, by = 20)) + + theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) +} + +if (rhpuOptions$fitDbhMixed) { + rhpuDiameterFromHeightMixed = list(chapmanReplace = fit_nlme("Chapman-Richards replace", DBH ~ (a1 + a1r)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 200, b1 = 0.01, b2 = 0.95)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001))) # singularity in backsolve, max iterations + rhpuDiameterFromHeightMixed$chapmanReplaceAbat = fit_nlme("Chapman-Richards replace ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # singularity in backsolve + #rhpuDiameterFromHeightMixed$chapmanReplaceBal = fit_nlme("Chapman-Richards replace BA+L", DBH ~ (a1 + a1r + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, + # fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 300, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving + #rhpuDiameterFromHeightMixed$chapmanReplaceBalRelHt = fit_nlme("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a1r + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, + # fixedFormula = a1 + a2 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 250, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # singularity in backsolve + #rhpuDiameterFromHeightMixed$chapmanReplaceRelHt = fit_nlme("Chapman-Richards replace RelHt", DBH ~ (a1 + a1r + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # step halving + rhpuDiameterFromHeightMixed$chapmanRichards = fit_nlme("Chapman-Richards inverse", DBH ~ (a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations + rhpuDiameterFromHeightMixed$chapmanRichardsAbat = fit_nlme("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations, step halving + #rhpuDiameterFromHeightMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards inverse physio", DBH ~ (a1 + a1r + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, + # fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations, step halving + rhpuDiameterFromHeightMixed$chapmanRichardsRelHt = fit_nlme("Chapman-Richards inverse RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, + fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving, singularity in backsolve + rhpuDiameterFromHeightMixed$michaelisMentenReplace = fit_nlme("Michaelis-Menten replace", DBH ~ (a1 + a1r) * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), rhpu2016, + fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 519, a2 = 237, b1 = 1.00)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations, step halving + rhpuDiameterFromHeightMixed$naslund = fit_nlme("Näslund inverse", DBH ~ (a1 + a1r + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + a1p + a2 + a2p ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) + rhpuDiameterFromHeightMixed$power = fit_nlme("power", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1, rhpu2016, + fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1.93, b1 = 1.08)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # job max iterations + #rhpuDiameterFromHeightMixed$powerAbat = fit_nlme("power ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, rhpu2016, + # fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 1.94, a2 = -0.00051, b1 = 1.09))) + #rhpuDiameterFromHeightMixed$powerPhysio = fit_nlme("power physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, rhpu2016, + # fixedFormula = a1 + a8 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 2.26, a8 = -0.0060, b1 = 1.08)), significant = FALSE) + #rhpuDiameterFromHeightMixed$powerRelHt = fit_nlme("power RelHt", DBH ~ (a1 + a1r + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, rhpu2016, + # fixedFormula = a1 + a9 + a9p + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13))) + rhpuDiameterFromHeightMixed$ruark = fit_nlme("Ruark", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.8, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations + rhpuDiameterFromHeightMixed$ruarkAbat = fit_nlme("Ruark ABA+T", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + a3 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # job max iterations + rhpuDiameterFromHeightMixed$ruarkAbatPhysio = fit_nlme("Ruark ABA+T physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + a2 + a4 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.9, a2 = -0.005, a4 = -0.001, b1 = 0.93, b2 = 0.006)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # job max iterations + #rhpuDiameterFromHeightMixed$ruarkAbatPhysioRelHt = fit_nlme("Ruark ABA+T RelHt physio", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + # fixedFormula = a1 + a3 + a4 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = -1, b1 = 0.9, b2 = 0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations + rhpuDiameterFromHeightMixed$ruarkAbatRelHt = fit_nlme("Ruark ABA+T RelHt", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + a3 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.7, a3 = 0, a9 = 0, b1 = 0.95, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + rhpuDiameterFromHeightMixed$ruarkPhysio = fit_nlme("Ruark physio", DBH ~ (a1 + a1r + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + a4 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + #rhpuDiameterFromHeightMixed$ruarkRelHt = fit_nlme("Ruark RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + rhpuDiameterFromHeightMixed$ruarkRelHtPhysio = fit_nlme("Ruark RelHt physio", DBH ~ (a1 + a1r + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016, + fixedFormula = a1 + a4 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.2, a4 = 0, a9 = -1, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations, false convergence + #rhpuDiameterFromHeightMixed$schnute = fit_nlme("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/((Ha + Har)^b1 - 1.3^b1)), rhpu2016, + # fixedFormula = a1 + a2 + b1 + Ha ~ 1, randomFormula = Har ~ 1, + # start = list(fixed = c(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30)), control = nlmeControl(maxIter = 100, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # step halving + #rhpuDiameterFromHeightMixed$sharmaParton = fit_nlme("modified Sharma-Parton", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, rhpu2016, + # fixedFormula = a1 + b1 + b2 + b4 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1)), control = nlmeControl(maxIter = 250, tolerance = 0.1, pnlsTol = 1, msTol = 0.01)) # singularity in backsolve + rhpuDiameterFromHeightMixed$sibbesenReplace = fit_nlme("Sibbesen replace", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.4, b1 = 0.8, b2 = 0.12)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations + rhpuDiameterFromHeightMixed$sibbesenReplaceAbat = fit_nlme("Sibbesen replace ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) + rhpuDiameterFromHeightMixed$sibbesenReplaceAbatPhysio = fit_nlme("Sibbesen replace ABA+T physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + a2 + a8 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + #rhpuDiameterFromHeightMixed$sibbesenReplaceAbatPhysioRelHt = fit_nlme("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + # fixedFormula = a1 + a2 + a8 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 3.3, a2 = 0, a8 = -0.017, a9 = 1.0, b1 = 0.7, b2 = 0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations + rhpuDiameterFromHeightMixed$sibbesenReplaceAbatRelHt = fit_nlme("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + a2 + a9 + a9p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.5, a2 = 0, a9 = 0, a9p = 0, b1 = 0.6, b2 = 0.12)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5), significant = FALSE) # singular precision matrix + rhpuDiameterFromHeightMixed$sibbesenReplacePhysio = fit_nlme("Sibbesen replace physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + a8 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1)), control = nlmeControl(maxIter = 500), significant = FALSE) + rhpuDiameterFromHeightMixed$sibbesenReplaceRelHt = fit_nlme("Sibbesen replace RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + rhpuDiameterFromHeightMixed$sibbesenReplaceRelHtPhysio = fit_nlme("Sibbesen replace RelHt physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016, + fixedFormula = a1 + a8 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.0, a8 = -0.01, a9 = 0, b1 = 0.73, b2 = 0.07)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + rhpuDiameterFromHeightMixed$weibull = fit_nlme("Weibull inverse", DBH ~ ((a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, rhpu2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -300, b1 = 0.04, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + + rhpuDiameterFromHeightMixed$gamm = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = rhpu2016, mixed = TRUE) + rhpuDiameterFromHeightMixed$gammAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16) + s(StandID, bs = "re"), data = rhpu2016, mixed = TRUE) + rhpuDiameterFromHeightMixed$gammRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = rhpu2016, mixed = TRUE) + + save(file = "data/rhpu DBH mixed.Rdata", rhpuDiameterFromHeightMixed) +} + + +# ## collect model results and parameters +# if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rhpuOptions$fitDbhMixed) { +# if (exists("rhpuHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt.Rdata") } +# #if (exists("rhpuHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt gnls.Rdata") } +# if (exists("rhpuHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt mixed.Rdata") } +# if (exists("rhpuDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/rhpu DBH.Rdata") } +# if (exists("rhpuDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/rhpu DBH mixed.Rdata") } + +## collect model results and parameters +if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rhpuOptions$fitDbhMixed) { + if (exists("rhpuHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt.Rdata") } + #if (exists("rhpuHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt gnls.Rdata") } + if (exists("rhpuHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt mixed.Rdata") } + if (exists("rhpuDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/rhpu DBH.Rdata") } + if (exists("rhpuDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/rhpu DBH mixed.Rdata") } + rhpuCoefficients = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_coefficients)), + #bind_rows(lapply(rhpuHeightFromDiameterGnls, get_model_coefficients)), + bind_rows(lapply(rhpuHeightFromDiameterGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(rhpuHeightFromDiameterMixed, get_list_coefficients, fitSet = "mixed")), + bind_rows(lapply(rhpuHeightFromDiameterNlrob, get_list_coefficients, fitSet = "nlrob"))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(rhpuDiameterFromHeight, get_list_coefficients)), + bind_rows(lapply(rhpuDiameterFromHeightGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(rhpuDiameterFromHeightMixed, get_list_coefficients, fitSet = "mixed")), + bind_rows(lapply(rhpuDiameterFromHeightNlrob, get_list_coefficients, fitSet = "nlrob"))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "rhpu") + rhpuResults = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_stats)), + #bind_rows(lapply(rhpuHeightFromDiameterGnls, get_stats)), + bind_rows(lapply(rhpuHeightFromDiameterGslNlsDefault, get_list_stats, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(rhpuHeightFromDiameterMixed, get_list_stats, fitSet = "mixed")), + bind_rows(lapply(rhpuHeightFromDiameterNlrob, get_list_stats, fitSet = "nlrob"))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(rhpuDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitSet = "primary", fittingMethod = "gsl_nls"), + bind_rows(lapply(rhpuDiameterFromHeightGslNlsDefault, get_list_stats, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(rhpuDiameterFromHeightMixed, get_list_stats, fitSet = "mixed")), + bind_rows(lapply(rhpuDiameterFromHeightNlrob, get_list_stats, fitSet = "nlrob"))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "rhpu") + + check_plot_results(rhpuResults) + save(file = "data/rhpu results.Rdata", rhpuCoefficients, rhpuResults) +} else if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rhpuOptions$fitDbhMixed) +{ + if (exists("rhpuHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt.Rdata") } + if (exists("rhpuDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/rhpu DBH.Rdata") } + + rhpuCoefficients = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_coefficients))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(rhpuDiameterFromHeight, get_list_coefficients))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "rhpu") + rhpuResults = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_stats))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(rhpuDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitting = "gsl_nls", fitSet = "primary")) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "rhpu") + + check_plot_results(rhpuResults) + save(file = "data/rhpu results.Rdata", rhpuCoefficients, rhpuResults) +} + + +## preferred forms identified (results.R, Figure 8) +if (rhpuOptions$fitHeight & rhpuOptions$fitDbh) +{ + rhpuHeightFromDiameterPreferred = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), folds = 1, repetitions = 1)) + rhpuHeightFromDiameterPreferred$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + #rhpuHeightFromDiameterPreferred$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176), folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176), folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), rhpu2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649), folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09), folds = 1, repetitions = 1) + #rhpuHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) + AIC(rhpuHeightFromDiameterPreferred$hossfeld, rhpuHeightFromDiameterPreferred$michaelisMenten, rhpuHeightFromDiameterPreferred$prodan, rhpuHeightFromDiameterPreferred$ratkowsky) + + rhpuDiameterFromHeightPreferred = list(gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1)) + #rhpuDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) + rhpuDiameterFromHeightPreferred$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), rhpu2016, folds = 1, repetitions = 1) + rhpuDiameterFromHeightPreferred$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, rhpu2016, start = list(a1 = 1.93, b1 = 1.08), folds = 1, repetitions = 1) + #rhpuDiameterFromHeightPreferred$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + #rhpuDiameterFromHeightPreferred$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + #rhpuDiameterFromHeightPreferred$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + rhpuDiameterFromHeightPreferred$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + + save(file = "data/rhpu preferred models.Rdata", rhpuHeightFromDiameterPreferred, rhpuDiameterFromHeightPreferred) +} + + +## basal area from height +if (htDiaOptions$includeInvestigatory) +{ + rhpuBasalAreaFromHeightKorf = gsl_nls(basalArea ~ a1*(exp(b1*(imputedHeight - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 90, b1 = 0.000003, b2 = 2.18), weights = heightWeight^2) # a1p, b1p, b2p not significant + rhpuBasalAreaFromHeightPower = gsl_nls(basalArea ~ a1*(imputedHeight - 1.37)^(b1 + b1p * isPlantation), rhpu2016, start = list(a1 = 3/7 * 0.25 * pi * 0.01^2, b1 = 2.14, b1p = 0.34), weights = heightWeight^2) # a1p not significant + #confint2(rhpuBasalAreaFromHeightPower, level = 0.99) + + tribble(~method, ~aic, ~biasCm2, ~maeM2, ~nse, + "Korf", AIC(rhpuBasalAreaFromHeightKorf), 100^2 * mean(residuals(rhpuBasalAreaFromHeightKorf)), mean(abs(residuals(rhpuBasalAreaFromHeightKorf))), 1 - sum(residuals(rhpuBasalAreaFromHeightKorf)^2) / sum((rhpu2016$basalArea - mean(rhpu2016$basalArea)^2)), + "power", AIC(rhpuBasalAreaFromHeightPower), 100^2 * mean(residuals(rhpuBasalAreaFromHeightPower)), mean(abs(residuals(rhpuBasalAreaFromHeightPower))), 1 - sum(residuals(rhpuBasalAreaFromHeightPower)^2) / sum((rhpu2016$basalArea - mean(rhpu2016$basalArea)^2))) %>% + mutate(deltaAIC = aic - min(aic)) %>% + arrange(desc(deltaAIC)) + + ggplot(rhpu2016) + + geom_point(aes(x = imputedHeight, y = 0.25*pi*(0.01*DBH)^2), alpha = 0.1, color = "grey25", shape = 16) + + geom_line(aes(x = imputedHeight, y = predict(rhpuBasalAreaFromHeightKorf), color = "Korf", group = isPlantation)) + + geom_line(aes(x = imputedHeight, y = predict(rhpuBasalAreaFromHeightPower), color = "power", group = isPlantation)) + + #geom_path(aes(x = imputedHeight, y = 10*(1 - exp(-0.1*(imputedHeight - 1.37)))^1.2, color = "Chapman-Richards")) + + labs(x = "cascara buckthorn height, m", y = "basal area, m²", color = NULL) + + theme(legend.justification = c(0, 1), legend.position = c(0.03, 0.99)) +} + + +## exploratory plots +if (htDiaOptions$includeInvestigatory) +{ + library(GGally) + ggpairs(rhpu2016 %>% mutate(regeneration = if_else(isPlantation, "plantation", "natural regen")) %>% select(TotalHt, DBH, standBasalAreaPerHectare, basalAreaLarger, relativeHeight, regeneration), + aes(alpha = 0.1, color = regeneration, shape = "16"), + columnLabels = c("DBH, cm", "height, m", "BA, m² ha⁻¹", "BAL, m² ha⁻¹", "relative height, %", "stand type"), + upper = list(continuous = wrap("cor", size = 3)), + lower = list(combo = wrap("facethist", bins = 30))) + + scale_color_discrete(type = c("forestgreen", "darkviolet")) + + #scale_color_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + # https://github.com/ggobi/ggally/issues/445 + scale_fill_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + + theme(strip.background = element_blank()) + ggpairs(rhpu2016 %>% mutate(regeneration = if_else(isPlantation, "plantation", "natural regen")) %>% select(TotalHt, DBH, slope, elevation, topographicShelterIndex, regeneration), + aes(alpha = 0.1, color = if_else(rhpu2016$isPlantation, "plantation", "natural regen"), shape = "16"), + columnLabels = c("DBH, cm", "height, m", "slope, °", "elevation, m", "TSI, °", "stand type"), + upper = list(continuous = wrap("cor", size = 3)), + lower = list(combo = wrap("facethist", bins = 30))) + + scale_color_discrete(type = c("forestgreen", "darkviolet")) + + scale_fill_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + + theme(strip.background = element_blank()) + scatterPlotMatrix::scatterPlotMatrix(rhpu2016 %>% select(TotalHt, DBH, standBasalAreaPerHectare, basalAreaLarger)) +} + + +## GAM smooth effects +if (htDiaOptions$includeInvestigatory) +{ + #rhpuInteraction = lm(TotalHt ~ DBH*standBasalAreaPerHectare + DBH:basalAreaLarger + standBasalAreaPerHectare:basalAreaLarger, rhpu2016) + #summary(rhpuInteraction) + #ggplot() + + # geom_point(aes(x = DBH, y = basalAreaLarger, color = rhpuInteraction$residuals), rhpu2016, shape = 16) + + # labs(x = "DBH, cm", y = bquote("BAL, m"^2*" ha"^-1), color = "height\nresidual, m") + + # scale_color_scico(palette = "bam", limits = c(-20, 20)) + rhpuHeightGam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint) + + #s(standBasalAreaPerHectare, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + #s(basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + s(topographicShelterIndex, bs = "ts", k = 5, pc = gamConstraint) + + s(relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint), + data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + #rhpuHeightGam = fit_gam("REML GAM", TotalHt ~ s(DBH, standBasalAreaPerHectare, bs = "ts", by = as.factor(isPlantation), k = 11, pc = gamConstraint) + + # #s(basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + # #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # s(topographicShelterIndex, bs = "ts", k = 5, pc = gamConstraint), + # #s(relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint), # not significant + # data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + k.check(rhpuHeightGam) + summary(rhpuHeightGam) + par(mfrow = c(2, 3), mar = c(2.2, 2.2, 0.5, 0) + 0.1, mgp = c(1.5, 0.4, 0)) + plot.gam(rhpuHeightGam, scale = 0, scheme = 2) + + rhpuDbhGam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), + #s(standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(tallerApproxBasalArea, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(topographicShelterIndex, bs = "ts", k = 3, pc = gamConstraint), # not significant + #s(relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint), # not significant + data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1) + k.check(rhpuDbhGam) + summary(rhpuDbhGam) + par(mfrow = c(1, 4), mar = c(2.2, 2.2, 0.5, 0) + 0.1, mgp = c(1.5, 0.4, 0)) + plot.gam(rhpuDbhGam, scale = 0) +} + + +## random forest regression +if (htDiaOptions$includeInvestigatory) +{ + library(caret) + library(ranger) + #rhpuForest = ranger(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger, rhpu2016, classification = TRUE, num.threads = 12) + repeatedCrossValidation = trainControl(method = "repeatedcv", number = htDiaOptions$folds, repeats = htDiaOptions$repetitions, verboseIter = FALSE) + rhpuHeightForest = train(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger + elevation + slope + aspect + topographicShelterIndex + relativeDiameter, data = rhpu2016, method = "ranger", trControl = repeatedCrossValidation, + importance = "impurity_corrected", + tuneGrid = expand.grid(mtry = c(6, 8), + splitrule = "variance", + min.node.size = c(1, 2))) + rhpuHeightForest + varImp(rhpuHeightForest) + + rhpuDbhForest = train(DBH ~ TotalHt + standBasalAreaApprox + tallerApproxBasalArea + elevation + slope + aspect + topographicShelterIndex + relativeHeight, data = rhpu2016, method = "ranger", trControl = repeatedCrossValidation, + importance = "impurity_corrected", + tuneGrid = expand.grid(mtry = c(7, 8), + splitrule = "variance", + min.node.size = c(2, 3, 4))) + rhpuDbhForest + varImp(rhpuDbhForest) +} + From f9bf5d488e04503f57d5d3be3bc89ecb8f464f11 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Sat, 24 May 2025 08:30:27 -0700 Subject: [PATCH 06/13] uncomment and run the code again after update to metric system --- trees/height-diameter/THPL.R | 78 ++++++++++++++++++------------------ 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/trees/height-diameter/THPL.R b/trees/height-diameter/THPL.R index 08fec39..fd98e6f 100644 --- a/trees/height-diameter/THPL.R +++ b/trees/height-diameter/THPL.R @@ -31,7 +31,7 @@ thpl2016defaultWeightPhysio = thpl2016defaultWeight %>% filter(is.na(elevation) #make a tibble to store the parameters and later call them into the code thplOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response - fitHeightNlrob = FALSE, #robust non-linear least square, height as response + fitHeightNlrob = TRUE, #robust non-linear least square, height as response fitHeightGnls = FALSE, #generalized least square, height as response fitHeightMixed = FALSE, #non-linear mixed effects, height as response fitDbh = TRUE, #non-linear least square, dbh as response @@ -64,7 +64,7 @@ if (thplOptions$fitHeight) { #if the value in the column fitHeight of thplOption thplHeightFromDiameter$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)) # a1p, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)) # a1p, b1p, b2p, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) # b1, b1p, a4, a5, a6, a7, b3p, b4p not significant - thplHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant + #thplHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant #thplHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant thplHeightFromDiameter$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) # a4, a5, a5, a6, a7, b1p, b3p, b4p not significant thplHeightFromDiameter$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 21, a10 = 0, b1 = 0.25, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = 0, b4 = 1.12), significant = FALSE) # a10, a10p not significant @@ -80,35 +80,35 @@ if (thplOptions$fitHeight) { #if the value in the column fitHeight of thplOption { thplHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) thplHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) - #thplHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + thplHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor #thplHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, thpl2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) #thplHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) # thplHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), thpl2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor thplHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) - thplHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) - thplHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) - #thplHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016, start = list(a1 = 0.560, b1 = 0.069)) - #thplHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) - # thplHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), thpl2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + #thplHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) + #thplHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, thpl2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) + thplHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, thpl2016, start = list(a1 = 0.560, b1 = 0.069)) + thplHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + thplHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), thpl2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) thplHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), thpl2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) - #thplHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) - #thplHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, thpl2016, start = list(a1 = 0.542, b1 = 0.939)) - #thplHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) - #thplHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor - thplHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor - thplHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor - thplHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor - thplHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor - thplHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor - thplHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor - thplHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) + thplHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + thplHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, thpl2016, start = list(a1 = 0.542, b1 = 0.939)) + thplHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + thplHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), thpl2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor + #thplHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor + #thplHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor + #thplHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor + #thplHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor + #thplHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor + #thplHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor + #thplHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) #thplHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) #thplHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant - #thplHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor + thplHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor thplHeightFromDiameterNlrob$sibbesen = fit_nlrob("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), thpl2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) - #thplHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor + thplHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor #thplHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) - #thplHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + thplHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) lapply(thplHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) } else { thplHeightFromDiameterNlrob = list() @@ -145,15 +145,15 @@ if (thplOptions$fitHeight) { #if the value in the column fitHeight of thplOption thplHeightFromDiameterGslNlsDefault$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) thplHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) thplHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) - # - # thplHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types - # thplHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model - # thplHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # k reduces from 85 to 18 without aspect - # thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + + thplHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + thplHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20), data = thpl2016, constraint = thpl2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + thplHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18), data = thpl2016, constraint = thpl2016gamConstraint) # k reduces from 85 to 18 without aspect + thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation)), data = thpl2016, constraint = thpl2016gamConstraint) save(file = "data/THPL TotalHt.Rdata", thplHeightFromDiameter, thplHeightFromDiameterNlrob, thplHeightFromDiameterGslNlsDefault) } @@ -423,14 +423,14 @@ if (thplOptions$fitDbh) { #thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant #thplDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) - # # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined - # thplDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with scat() - # thplDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop ABA and elevation on AIC - # thplDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and topographic shelter on AIC - # thplDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) - # thplDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and aspect on AIC + # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined + thplDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with scat() + thplDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop ABA and elevation on AIC + thplDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and topographic shelter on AIC + thplDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # drop elevation and aspect on AIC save(file = "data/THPL DBH.Rdata", thplDiameterFromHeight, thplDiameterFromHeightNlrob, thplDiameterFromHeightGslNlsDefault) } From 21aea201738f7925a97b680cbfa86121353973e1 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 11 Jun 2025 13:47:57 -0700 Subject: [PATCH 07/13] edit rhpu for public dataset --- trees/height-diameter/RHPU.R | 194 +++++++++++++++++++---------------- 1 file changed, 106 insertions(+), 88 deletions(-) diff --git a/trees/height-diameter/RHPU.R b/trees/height-diameter/RHPU.R index 2403c77..8c22cf2 100644 --- a/trees/height-diameter/RHPU.R +++ b/trees/height-diameter/RHPU.R @@ -10,7 +10,7 @@ #rhpu HeightFromDiameter$sharmaPartonBalPhysio = gsl_nls(TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^(a2 + a2p * isPlantation) * (1 + a3 * elevation + a4 * sin(3.14159/180 * aspect) + a5 * cos(3.14159/180 * aspect) + a6 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^(b2 + b2p * isPlantation)*DBH))^(b3 + b3p * isPlantation), rhpu2016, start = list(a1 = 39.8, a1p = -12.3, a2 = 0.52, a2p = 0.0027, a3 = 0.00001, a4 = 0.0131, a5 = 0.0046, a6 = 0.0060, b1 = -0.0098, b1p = -0.0143, b2 = 0.125, b2p = -0.186, b3 = 1.12, b3p = 0.0086), weights = rhpuHeightFromDiameterWeights) rhpu2016 = trees2016 %>% - filter(Species == "RHPU", isLiveUnbroken, is.na(TotalHt) == FALSE) %>% # live cascara buckthorns measured for height + filter(Species == "RHPU", isLiveUnbroken, is.na(TotalHt) == FALSE,is.na(elevation)==FALSE) %>% # live cascara buckthorns measured for height mutate(dbhWeight = pmin(TreeCount/(0.14*DBH^1.20), 5*TreeCount), heightWeight = pmin(TreeCount/(2.29*(TotalHt - 1.37)^1.45), 5*TreeCount)) @@ -31,8 +31,8 @@ rhpu2016defaultWeightPhysio = rhpu2016defaultWeight %>% filter(is.na(elevation) #make a tibble to store the parameters and later call them into the code rhpuOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response - fitHeightNlrob = TRUE, #robust non-linear least square, height as response - fitHeightGnls = FALSE, #generalized least square, height as response + fitHeightNlrob = FALSE, #robust non-linear least square, height as response + fitHeightGnls = TRUE, #generalized least square, height as response fitHeightMixed = FALSE, #non-linear mixed effects, height as response fitDbh = TRUE, #non-linear least square, dbh as response fitDbhNlrob = FALSE, #robust non-linear least square, dbh as response @@ -48,10 +48,10 @@ if (rhpuOptions$fitHeight) { #if the value in the column fitHeight of rhpuOption rhpuHeightFromDiameter$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) # a3, a3p, b1p, b2p not significant rhpuHeightFromDiameter$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) # a2, a3, a4, a5, a6, a7, a8p, b2p not significant #rhpuHeightFromDiameter$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -16, a2 = 0, a2p = 0.4, a8 = 0.3, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) # a2, a10, a10p not significant - #rhpuHeightFromDiameter$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.3, b1 = -0.012, b2 = 1.1), significant = FALSE) # a2, a10, a10p not significant - rhpuHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() + rhpuHeightFromDiameter$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.3, b1 = -0.012, b2 = 1.1), significant = FALSE) # a2, a10, a10p not significant + #rhpuHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() rhpuHeightFromDiameter$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) # a4, a5, a6, a7, a8p, b2p not significant - #rhpuHeightFromDiameter$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 72, a10 = -3.2, b1 = -0.012, b2 = 1.09)) # a10p not significant + rhpuHeightFromDiameter$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 72, a10 = -3.2, b1 = -0.012, b2 = 1.09)) # a10p not significant #rhpuHeightFromDiameter$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) # a10, a10p not significant rhpuHeightFromDiameter$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, rhpu2016, start = list(a1 = 0.560, b1 = 0.069)) # a1p, b1p not significant rhpuHeightFromDiameter$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) # b2p not significant @@ -65,49 +65,49 @@ if (rhpuOptions$fitHeight) { #if the value in the column fitHeight of rhpuOption rhpuHeightFromDiameter$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)) # a1p, b1p, b2p, b3p, b4p not significant #rhpuHeightFromDiameter$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) # b1, b1p, a4, a5, a6, a7, b3p, b4p not significant #rhpuHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant - #rhpuHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant + rhpuHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant #rhpuHeightFromDiameter$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) # a4, a5, a5, a6, a7, b1p, b3p, b4p not significant #rhpuHeightFromDiameter$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 21, a10 = 0, b1 = 0.25, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = 0, b4 = 1.12), significant = FALSE) # a10, a10p not significant #rhpuHeightFromDiameter$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 36, a8 = 0.18, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = -0.03, b4 = 1.09), significant = FALSE) # a1p, a10, a10p, b2p not significant #rhpuHeightFromDiameter$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) # b1, b1p, b2p, b3p not significant - #rhpuHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant + rhpuHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant rhpuHeightFromDiameter$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) # a1p, b1p, b2p not significant rhpuHeightFromDiameter$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) # b2p not significant - #rhpuHeightFromDiameter$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) # a1p, a2, a3, b1p, b2p not significant + rhpuHeightFromDiameter$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) # a1p, a2, a3, b1p, b2p not significant rhpuHeightFromDiameter$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) # a1p, a2, a3, a3p, b1p, b2p not significant if (rhpuOptions$fitHeightNlrob) { - rhpuHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 5.2, b1 = 0.015, b2 = 1.131))) - rhpuHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) - rhpuHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor - rhpuHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) - rhpuHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) + rhpuHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 5.2, b1 = -0.015, b2 = 1.131))) + #rhpuHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + #rhpuHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + #rhpuHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) + #rhpuHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) rhpuHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor - rhpuHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + #rhpuHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) rhpuHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) - rhpuHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) + #rhpuHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) rhpuHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, rhpu2016, start = list(a1 = 0.560, b1 = 0.069)) rhpuHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) rhpuHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), rhpu2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) - rhpuHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + #rhpuHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) rhpuHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), rhpu2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) rhpuHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, rhpu2016, start = list(a1 = 0.542, b1 = 0.939)) rhpuHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) - rhpuHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor - rhpuHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor + #rhpuHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor + #rhpuHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor rhpuHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor - rhpuHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor - rhpuHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor - rhpuHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor - rhpuHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor - rhpuHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) - rhpuHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) - rhpuHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant - rhpuHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor + #rhpuHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor + #rhpuHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor + #rhpuHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor + #rhpuHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor + #rhpuHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) + #rhpuHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) + #rhpuHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant + #rhpuHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor rhpuHeightFromDiameterNlrob$sibbesen = fit_nlrob("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) - rhpuHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor - rhpuHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + rhpuHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)* (1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor + #rhpuHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) rhpuHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), rhpu2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) lapply(rhpuHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) } else { @@ -118,12 +118,12 @@ if (rhpuOptions$fitHeight) { #if the value in the column fitHeight of rhpuOption rhpuHeightFromDiameterGslNlsDefault = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) - #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016defaultWeight, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a3 = -0.03, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), rhpu2016defaultWeight, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a3 = -0.03, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, rhpu2016, start = list(a1 = 58, a1p = -14, a2 = -0.07, a2p = 0.48, a8 = 0.27, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) - #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.11), significant = FALSE) + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.11), significant = FALSE) rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) - #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 74, a10 = -3.2, b1 = -0.011, b2 = 1.09)) - #rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) #produced NA or infinity + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, rhpu2016defaultWeight, start = list(a1 = 74, a10 = -3.2, b1 = -0.011, b2 = 1.09)) + rhpuHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, rhpu2016defaultWeightPhysio, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) #produced NA or infinity rhpuHeightFromDiameterGslNlsDefault$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, rhpu2016defaultWeight, start = list(a1 = 0.560, b1 = 0.069)) rhpuHeightFromDiameterGslNlsDefault$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) rhpuHeightFromDiameterGslNlsDefault$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), rhpu2016defaultWeight, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) @@ -134,33 +134,33 @@ if (rhpuOptions$fitHeight) { #if the value in the column fitHeight of rhpuOption #rhpuHeightFromDiameterGslNlsDefault$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), rhpu2016defaultWeight, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) #produced NA or infinity #rhpuHeightFromDiameterGslNlsDefault$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09))#produced NA or infinity rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 38, b1 = 0.12, b2 = -0.013, b3 = -0.1, b4 = 1.02)) - rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) - #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 23, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.01, b2p = -0.010, b3 = -0.012, b4 = 1.14), significant = FALSE)#produced NA or infinity - #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE)#produced NA or infinity + #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) + rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 23, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.01, b2p = -0.010, b3 = -0.012, b4 = 1.14), significant = FALSE)#produced NA or infinity + rhpuHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE)#produced NA or infinity #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09))#produced NA or infinity #rhpuHeightFromDiameterGslNlsDefault$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 19, a10 = -0.3, b1 = 0.29, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.03, b4 = 1.13), significant = FALSE)#produced NA or infinity rhpuHeightFromDiameterGslNlsDefault$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016defaultWeightPhysio, start = list(a1 = 36, a8 = 0.18, a10 = 0, b1 = 0.2, b2 = -0.01, b3 = 0.03, b4 = 1.09), significant = FALSE) #rhpuHeightFromDiameterGslNlsDefault$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016defaultWeight, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) rhpuHeightFromDiameterGslNlsDefault$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016defaultWeight, start = list(a1 = 53.2, a1p = -8.857, a2 = -0.002, a2p = 0.10, b1 = -0.016, b2 = -0.025, b3 = -0.078, b4 = 1.126)) - #rhpuHeightFromDiameterGslNlsDefault$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016defaultWeight, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + rhpuHeightFromDiameterGslNlsDefault$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), rhpu2016defaultWeight, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) rhpuHeightFromDiameterGslNlsDefault$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) - #rhpuHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + rhpuHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) rhpuHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), rhpu2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) - # - # rhpuHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types - # rhpuHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model - # rhpuHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # k reduces from 85 to 18 without aspect - # rhpuHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - + + rhpuHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + rhpuHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + rhpuHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # k reduces from 85 to 18 without aspect + rhpuHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + save(file = "data/rhpu TotalHt.Rdata", rhpuHeightFromDiameter, rhpuHeightFromDiameterNlrob, rhpuHeightFromDiameterGslNlsDefault) } if (htDiaOptions$includeInvestigatory) { - print(rhpuHeightFromDiameterResults %>% select(-responseVariable, -species, -fixedWeight, -n, -power, -significant, -contains("NaturalRegen"), -contains("Plantation")), n = 30) + #print(rhpuHeightFromDiameterResults %>% select(-responseVariable, -species, -fixedWeight, -n, -power, -significant, -contains("NaturalRegen"), -contains("Plantation")), n = 30) ggplot() + geom_point(aes(x = rhpu2016$DBH, y = rhpu2016$TotalHt), alpha = 0.10, color = "grey25", shape = 16) + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$sharmaZhang), color = "Sharma-Zhang", group = rhpu2016$isPlantation), alpha = 0.5) + @@ -209,12 +209,12 @@ if (rhpuOptions$fitHeightGnls) { rhpuHeightFromDiameterGnls = list(chapmanRichards = fit_gnls("Chapman-Richards GNLS", TotalHt ~ 1.37 + a1*(1 - exp(b1*DBH))^b2, rhpu2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), control = gnlsControl(nlsTol = 0.001))) # step halving at nlsTol = 1 with corSymm #rhpuHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, rhpu2016, start = rhpuHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm - rhpuHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm - rhpuHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #rhpuHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + #rhpuHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation #rhpuHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), rhpu2016, start = rhpuHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation - rhpuHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation - rhpuHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = rhpuHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped - rhpuHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = rhpuHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm + #rhpuHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, rhpu2016, start = rhpuHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #rhpuHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), rhpu2016, start = rhpuHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped + #rhpuHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), rhpu2016, start = rhpuHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm save(file = "data/rhpu TotalHt gnls.Rdata", rhpuHeightFromDiameterGnls) } @@ -326,12 +326,12 @@ if (rhpuOptions$fitDbh) { rhpuDiameterFromHeight = list(linear = fit_lm("linear", DBH ~ 0 + I(TotalHt - 1.37), rhpu2016)) # isPlantation*(TotalHt - 1.37) not significant rhpuDiameterFromHeight$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), rhpu2016) # (TotalHt - 1.37)^2 not significant - #rhpuDiameterFromHeight$chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 500, xtol = 1E-5)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: singular gradient with nls(), no convergence from nls_multstart(), NaN-inf with nlrob() + rhpuDiameterFromHeight$chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 500, xtol = 1E-5)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: singular gradient with nls(), no convergence from nls_multstart(), NaN-inf with nlrob() #rhpuDiameterFromHeight$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # NaN-inf with nls() and nlrob - # rhpuDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() - # rhpuDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 - # rhpuDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() - #rhpuDiameterFromHeight$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) # a1p and b2p not significant, poor convergence with b1p, step factor with nlrob() + rhpuDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() + rhpuDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 + rhpuDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() + rhpuDiameterFromHeight$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) # a1p and b2p not significant, poor convergence with b1p, step factor with nlrob() rhpuDiameterFromHeight$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # a1p, b1p not significant, step factor with nlrob() rhpuDiameterFromHeight$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) # no physiographic effects significant, a1-b1 parameter evaporation: step factor with nlrob() rhpuDiameterFromHeight$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) # step factor with nlrob() @@ -392,27 +392,27 @@ if (rhpuOptions$fitDbh) { } rhpuDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) rhpuDiameterFromHeightGslNlsDefault$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, rhpu2016defaultWeight, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) - #rhpuDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) - #rhpuDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) + rhpuDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), rhpu2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) + rhpuDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) - #rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) + rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) rhpuDiameterFromHeightGslNlsDefault$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), rhpu2016defaultWeight, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) - #rhpuDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), rhpu2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) + rhpuDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), rhpu2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) rhpuDiameterFromHeightGslNlsDefault$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) rhpuDiameterFromHeightGslNlsDefault$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.93, b1 = 1.08)) - #rhpuDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) - #rhpuDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, rhpu2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) - #rhpuDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + rhpuDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + rhpuDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, rhpu2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, rhpu2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) rhpuDiameterFromHeightGslNlsDefault$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) rhpuDiameterFromHeightGslNlsDefault$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) rhpuDiameterFromHeightGslNlsDefault$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a2 = -0.01, a4 = -0.0006, b1 = 1.2, b2 = -0.009), significant = FALSE) rhpuDiameterFromHeightGslNlsDefault$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a3 = -0.003, a4 = -0.0006, a9 = 0.4, b1 = 1.27, b2 = -0.01), significant = FALSE) rhpuDiameterFromHeightGslNlsDefault$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 1.3, a3 = -0.003, a9 = 0.25, b1 = 1.3, b2 = -0.008), significant = FALSE) - #rhpuDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + rhpuDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) rhpuDiameterFromHeightGslNlsDefault$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeight, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) - #rhpuDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant + rhpuDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), rhpu2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant #rhpuDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), rhpu2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) - rhpuDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, rhpu2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) + #rhpuDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, rhpu2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) rhpuDiameterFromHeightGslNlsDefault$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeight, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeight, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)) rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeightPhysio, start = list(a1 = 1.5, a2 = -0.009, a8 = -0.005, b1 = 1.2, b2 = -0.04), significant = FALSE) @@ -423,14 +423,14 @@ if (rhpuOptions$fitDbh) { #rhpuDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), rhpu2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant #rhpuDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, rhpu2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) - # # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined - # rhpuDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # newton() step failure with scat() - # rhpuDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop ABA and elevation on AIC - # rhpuDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop elevation and topographic shelter on AIC - # rhpuDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) - # rhpuDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop elevation and aspect on AIC + # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined + rhpuDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # newton() step failure with scat() + rhpuDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop ABA and elevation on AIC + rhpuDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop elevation and topographic shelter on AIC + rhpuDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) + rhpuDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint) # drop elevation and aspect on AIC save(file = "data/rhpu DBH.Rdata", rhpuDiameterFromHeight, rhpuDiameterFromHeightNlrob, rhpuDiameterFromHeightGslNlsDefault) } @@ -591,11 +591,11 @@ if (rhpuOptions$fitDbhMixed) { ## collect model results and parameters if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rhpuOptions$fitDbhMixed) { - if (exists("rhpuHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt.Rdata") } + if (exists("rhpuHeightFromDiameter") == FALSE) { load("data/rhpu TotalHt.Rdata") } #if (exists("rhpuHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt gnls.Rdata") } - if (exists("rhpuHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt mixed.Rdata") } - if (exists("rhpuDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/rhpu DBH.Rdata") } - if (exists("rhpuDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/rhpu DBH mixed.Rdata") } + if (exists("rhpuHeightFromDiameterMixed") == FALSE) { load("data/rhpu TotalHt mixed.Rdata") } + if (exists("rhpuDiameterFromHeight") == FALSE) { load("data/rhpu DBH.Rdata") } + if (exists("rhpuDiameterFromHeightMixed") == FALSE) { load("data/rhpu DBH mixed.Rdata") } rhpuCoefficients = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_coefficients)), #bind_rows(lapply(rhpuHeightFromDiameterGnls, get_model_coefficients)), bind_rows(lapply(rhpuHeightFromDiameterGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), @@ -626,8 +626,27 @@ if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rh save(file = "data/rhpu results.Rdata", rhpuCoefficients, rhpuResults) } else if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rhpuOptions$fitDbhMixed) { - if (exists("rhpuHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/rhpu TotalHt.Rdata") } - if (exists("rhpuDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/rhpu DBH.Rdata") } + if (exists("rhpuHeightFromDiameter") == FALSE) { load("data/rhpu TotalHt.Rdata") } + if (exists("rhpuDiameterFromHeight") == FALSE) { load("data/rhpu DBH.Rdata") } + + rhpuCoefficients = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_coefficients))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(rhpuDiameterFromHeight, get_list_coefficients))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "rhpu") + rhpuResults = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_stats))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(rhpuDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitting = "gsl_nls", fitSet = "primary")) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "rhpu") + + check_plot_results(rhpuResults) + save(file = "data/rhpu results.Rdata", rhpuCoefficients, rhpuResults) +}else(rhpuOptions$fitHeight &rhpuOptions$fitDbh) #added for height and diameter fit only. +{ + if (exists("rhpuHeightFromDiameter") == FALSE) { load("data/rhpu TotalHt.Rdata") } + if (exists("rhpuDiameterFromHeight") == FALSE) { load("data/rhpu DBH.Rdata") } rhpuCoefficients = bind_rows(bind_rows(bind_rows(lapply(rhpuHeightFromDiameter, get_list_coefficients))) %>% mutate(responseVariable = "height"), @@ -645,7 +664,6 @@ if (rhpuOptions$fitHeight & rhpuOptions$fitHeightMixed & rhpuOptions$fitDbh & rh save(file = "data/rhpu results.Rdata", rhpuCoefficients, rhpuResults) } - ## preferred forms identified (results.R, Figure 8) if (rhpuOptions$fitHeight & rhpuOptions$fitDbh) { @@ -655,10 +673,10 @@ if (rhpuOptions$fitHeight & rhpuOptions$fitDbh) rhpuHeightFromDiameterPreferred$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176), folds = 1, repetitions = 1) rhpuHeightFromDiameterPreferred$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), rhpu2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176), folds = 1, repetitions = 1) rhpuHeightFromDiameterPreferred$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), rhpu2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649), folds = 1, repetitions = 1) - rhpuHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) - rhpuHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) - rhpuHeightFromDiameterPreferred$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09), folds = 1, repetitions = 1) - #rhpuHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) + #rhpuHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) + #rhpuHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, rhpu2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) + #rhpuHeightFromDiameterPreferred$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, rhpu2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09), folds = 1, repetitions = 1) + rhpuHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), rhpu2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) AIC(rhpuHeightFromDiameterPreferred$hossfeld, rhpuHeightFromDiameterPreferred$michaelisMenten, rhpuHeightFromDiameterPreferred$prodan, rhpuHeightFromDiameterPreferred$ratkowsky) rhpuDiameterFromHeightPreferred = list(gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = rhpu2016, constraint = rhpu2016gamConstraint, folds = 1, repetitions = 1)) From 6e84b2a4321f343f9e2179604891fd1605da814b Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 11 Jun 2025 13:48:53 -0700 Subject: [PATCH 08/13] edit setup for public dataset --- trees/height-diameter/setup.R | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/trees/height-diameter/setup.R b/trees/height-diameter/setup.R index 64d4849..b66b20b 100644 --- a/trees/height-diameter/setup.R +++ b/trees/height-diameter/setup.R @@ -38,7 +38,7 @@ theme_set(theme_bw() + theme(axis.line = element_line(linewidth = 0.3), #makes t htDiaOptions = tibble(folds = 10, repetitions = 10, - includeInvestigatory = TRUE, # default to excluding plotting and other add ons in species scripts #it is like telling R that I do not want the code for plots/investigatory statistics to be run (coded somewhere below, if I set this as FALSE) + includeInvestigatory = FALSE, # default to excluding plotting and other add ons in species scripts #it is like telling R that I do not want the code for plots/investigatory statistics to be run (coded somewhere below, if I set this as FALSE) retainModelThreshold = 10) # cross validation retains model objects if folds * repetitions is less than or equal to this threshold, e.g. 25 = retaining models up to and including 5x5 cross validation but sufficient DDR for loading all results may be an issue (5x5 easily exceeds 90 GB) plotLetters = c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L") #plotLetters = c("(a)", "(b)", "(c)", "(d)", "(e)", "(f)", "(g)", "(h)", "(i)", "(j)", "(k)", "(l)") @@ -169,8 +169,9 @@ fit_gam = function(name, formula, data, constraint = c(), family = gaussian(), f progressBar = progressor(steps = folds * repetitions) #design of progress bar # work around https://github.com/HenrikBengtsson/globals/issues/87 to enable GAM fitting using future_map() #to make the constrains passable, it won't be possible - localFormula = local({ gamConstraint = constraint #creating a local formula, that is basically the same as above. - formula(paste(deparse(formula), collapse = " ")) }) # to understand the syntax, see ?deparse() and ?paste() in r documentation #collapse=" " defines the separator/concatenator, in this case, the strings will be concatenated using the " " or space + localFormula = local({ gamConstraint = constraint #creating a local formula, that is basically the same as above. + formula(paste(deparse(formula), collapse = " ")) }) # to understand the syntax, see ?deparse() and ?paste() in r documentation #collapse=" " defines the separator/concatenator, in this case, the strings will be concatenated using the " " or space + #localFormula = eval(parse(text = gsub("gamConstraint", deparse(substitute(constraint)), deparse(formula)))) if (responseVariable == "TotalHt()") #lets continue the conditional statements after the local formula. { if (bam) @@ -1650,7 +1651,7 @@ trees2016 = left_join(read.csv(r"(Elliott_timber_cruise_2015-16.csv)"), by = "standID") %>% # removed the second part of the join because it was not relevant rename(Species=species,TotalHt=totalHt,TreeCount=treeCount,PlotID=plotID,StandID=standID,SamplingMethod=samplingMethod,CompCode=condition,CrownRatio=crownRatio,Ht1=taperHt,Dia1=taperDiameter,standArea=areaHa)%>% # renamed columns to match further analysis, this code was added to match variable names. mutate(SamplingMethod = ifelse(SamplingMethod == "VRP", "BAF", SamplingMethod))%>% - mutate(speciesGroup = factor(if_else(Species %in% c("PSME", "ALRU2", "TSHE","ACMA3", "UMCA", "THPL"), Species, "other"), levels=c("PSME", "ALRU2", "TSHE","ACMA3", "UMCA", "THPL", "other"),labels = c("DF", "RA", "WH", "BM", "OM", "RC", "other")), + mutate(speciesGroup = factor(if_else(Species %in% c("PSME", "ALRU2", "TSHE","ACMA3", "UMCA", "THPL","PISI","RHPU","ARME"), Species, "other"), levels=c("PSME", "ALRU2", "TSHE","ACMA3", "UMCA", "THPL", "PISI","RHPU","ARME","other"),labels = c("DF", "RA", "WH", "BM", "OM", "RC","SS","CB","PM","other")), #mutate(speciesGroup = factor(if_else(Species %in% c("DF", "RA", "WH", "BM", "OM", "RC"), Species, "other"), levels = c("DF", "RA", "WH", "BM", "OM", "RC", "other")), PlotType=case_when(plotType=="count"~"CO", #convert plot type "count" and "measure" to "CO" and "IP" respectively plotType == "measure" ~ "IP", @@ -1661,10 +1662,10 @@ trees2016 = left_join(read.csv(r"(Elliott_timber_cruise_2015-16.csv)"), CrownRatio = na_if(CrownRatio, 0), Ht1 = na_if(Ht1, 0), # feet to m Ht2 = na_if(htToBrokenTop, 0), - isConifer = Species %in% c("PSME", "TSHE", "THPL"), + isConifer = Species %in% c("PSME", "TSHE", "THPL","PISI"), isLive = (CompCode %in% c("deadStanding", "snag")) == FALSE, isLiveUnbroken = isLive & (CompCode != "brokenTop"), - SampleFactor = if_else(SamplingMethod == "BAF",baExpansionFactor / (pi * (DBH / 200)^2),10000 / 300), #for fixed radius plot of 0.03 ha, the sample factor is calculated as 10000 / 300 * treeCount, where 300 square meters corresponds to 0.03ha + SampleFactor = case_when(SamplingMethod == "BAF" & plotType == "count" ~ baExpansionFactor,SamplingMethod == "BAF" & plotType == "measure" ~ baExpansionFactor / (pi * (DBH / 200)^2),SamplingMethod == "FRP" ~ 10000 / 300), # fixed plot of 300 m² = 0.03 ha #for fixed radius plot of 0.03 ha, the sample factor is calculated as 10000 / 300 * treeCount, where 300 square meters corresponds to 0.03ha plotRadius = if_else(SamplingMethod == "BAF",sqrt(baExpansionFactor / (pi * SampleFactor)) * 2,sqrt((10000 / SampleFactor) / pi)), TotalHt = na_if(TotalHt, 0), TreeCount = if_else((PlotType == "IP") & (SamplingMethod == "BAF") & (TreeCount > 1), 1, TreeCount), # fix tree duplication per notes above @@ -1715,14 +1716,15 @@ head(trees2016) heightClassBreaks = trees2016 %>% filter(isLiveUnbroken, is.na(TotalHt) == FALSE) %>% group_by(speciesGroup) %>% group_modify(~{ - quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10))) # constrain maximum number of classes based on data availability: setting the max to n / (meanClassN*k) classes averages meanClassN samples per class in validation folds => primarily affects low n species: Oregon myrtle, western redcedar, and other + #quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10)-3)) # constrain maximum number of classes based on data availability: setting the max to n / (meanClassN*k) classes averages meanClassN samples per class in validation folds => primarily affects low n species: Oregon myrtle, western redcedar, and other + quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10))) return(tibble(heightBreaks = unique(ceiling(c(0, quantile(.$TotalHt, probs = quantileBreaks, na.rm = TRUE)))))) }) %>% unstack(heightBreaks ~ speciesGroup) # list of height class breaks, named by species -dbhClassBreaks = trees2016 %>% filter(isLiveUnbroken, DBH > 2.54 * 3.5) %>% +dbhClassBreaks = trees2016 %>% filter(isLiveUnbroken, DBH >3.5) %>% group_by(speciesGroup) %>% group_modify(~{ - quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10) - 3)) + quantileBreaks = seq(0, 1, length.out = min(50, sum(.$TreeCount) / (5 * 10))) #returns quantile breaks whichever is minimum, 20 or sum(.$TreeCount) / (5 * 10) - 3) return(tibble(dbhBreaks = unique(c(2.5 * c(0, 1.5, 2.5, 3.5), 2.5 * ceiling(quantile(.$DBH, probs = quantileBreaks, na.rm = TRUE) / 2.5) + 0.5 * 2.5)))) }) %>% unstack(dbhBreaks ~ speciesGroup) # list of DBH class breaks, named by species @@ -2015,7 +2017,7 @@ if (htDiaOptions$includeInvestigatory) { # ranges of predictor variables liveUnbrokenTrees2016<-trees2016 #assigned liveUnbrokenTrees2016 to trees2016 data frame assuming that this includes trees filtered by, isliveUnbroken and is.na(totalHt)=FALSE) print(liveUnbrokenTrees2016 %>% group_by(speciesGroup) %>% - summarize(quantile = c(0, 0.5, 1), + reframe(quantile = c(0, 0.5, 1), dbh = quantile(DBH, quantile, na.rm = TRUE), height = quantile(TotalHt, quantile, na.rm = TRUE), tph = quantile(tph, quantile, na.rm = TRUE), @@ -2120,6 +2122,16 @@ if (htDiaOptions$includeInvestigatory) { plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "other"), speciesLabel = "other species ", distributionLegendPositionY = 0.92) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) ggsave("figures/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "CB"), speciesLabel = "Cascara buckthorn", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, omitXlabels = TRUE) / + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "PM"), speciesLabel = "Pacific madrone", maxTreesMeasured = 150, omitLegends = TRUE) + + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + ggsave("figures/Figure A5 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) + + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "SS"), speciesLabel = "sitka spruce ", distributionLegendPositionY = 0.92) + + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) + ggsave("figures/Figure A6 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + } @@ -2466,7 +2478,7 @@ if (htDiaOptions$includeInvestigatory) { heightMeasureTrees = trees2016 %>% filter(isLiveUnbroken, is.na(TotalHt) == FALSE, is.na(elevation) == FALSE) heightVsurf = VSURF(TotalHt ~ ., heightMeasureTrees %>% select(TotalHt, Species, DBH, isPlantation, topHeight, qmd, relativeDiameter, standBasalAreaPerHectare, basalAreaLarger, standAge2016, elevation, slope, aspect, topographicShelterIndex), ncores = 8, parallel = TRUE, RFimplem = "ranger") dbhVsurf = VSURF(DBH ~ ., heightMeasureTrees %>% select(DBH, Species, TotalHt, isPlantation, relativeHeight, topHeight, standBasalAreaApprox, tallerApproxBasalArea, standAge2016, elevation, slope, aspect, topographicShelterIndex), ncores = 8, parallel = TRUE, RFimplem = "ranger") # flaky, may not return anything - + predictorImportance = bind_rows(tibble(responseVariable = "height", predictor = as.character(attr(heightVsurf$terms, "predvars"))[heightVsurf$imp.mean.dec.ind + 2], importance = heightVsurf$imp.mean.dec) %>% # offset as.character() by two since first element is "list" and second is TotalHt mutate(predictor = if_else(predictor == "standBasalAreaPerHectare", "standBasalArea", predictor)), tibble(responseVariable = "DBH", predictor = as.character(attr(dbhVsurf$terms, "predvars"))[dbhVsurf$imp.mean.dec.ind + 2], importance = dbhVsurf$imp.mean.dec) %>% From a922c194b5b56dfda941fca3fdfdaca4376914c2 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 11 Jun 2025 13:49:27 -0700 Subject: [PATCH 09/13] updata results for public dataset --- trees/height-diameter/results.R | 95 +++++++++++++++++++++------------ 1 file changed, 62 insertions(+), 33 deletions(-) diff --git a/trees/height-diameter/results.R b/trees/height-diameter/results.R index 3e80510..d841afa 100644 --- a/trees/height-diameter/results.R +++ b/trees/height-diameter/results.R @@ -7,21 +7,39 @@ figureDpi = 500 speciesGroupColors = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1", "firebrick", "grey65") #rm(psmeResults, alruResults, tsheResults, acmaResults, umcaResults, thplResults, otherResults, psmeCoefficients, alruCoefficients, tsheCoefficients, acmaCoefficients, umcaCoefficients, thplCoefficients, otherCoefficients) -if (exists("psmeResults") == FALSE) { load("trees/height-diameter/data/PSME results.Rdata") } -if (exists("alruResults") == FALSE) { load("trees/height-diameter/data/ALRU2 results.Rdata") } -if (exists("tsheResults") == FALSE) { load("trees/height-diameter/data/TSHE results.Rdata") } -if (exists("acmaResults") == FALSE) { load("trees/height-diameter/data/ACMA3 results.Rdata") } -if (exists("thplResults") == FALSE) { load("trees/height-diameter/data/THPL results.Rdata") } -if (exists("umcaResults") == FALSE) { load("trees/height-diameter/data/UMCA results.Rdata") } -if (exists("otherResults") == FALSE) { load("trees/height-diameter/data/other results.Rdata") } - - +# if (exists("psmeResults") == FALSE) { load("trees/height-diameter/data/PSME results.Rdata") } +# if (exists("alruResults") == FALSE) { load("trees/height-diameter/data/ALRU2 results.Rdata") } +# if (exists("tsheResults") == FALSE) { load("trees/height-diameter/data/TSHE results.Rdata") } +# if (exists("acmaResults") == FALSE) { load("trees/height-diameter/data/ACMA3 results.Rdata") } +# if (exists("thplResults") == FALSE) { load("trees/height-diameter/data/THPL results.Rdata") } +# if (exists("umcaResults") == FALSE) { load("trees/height-diameter/data/UMCA results.Rdata") } +# if (exists("otherResults") == FALSE) { load("trees/height-diameter/data/other results.Rdata") } +if (exists("PSME Results") == FALSE) { load("data/PSME results.Rdata") } +if (exists("rhpuResults") == FALSE) { load("data/arme results.Rdata") } +if (exists("rhpuResults") == FALSE) { load("data/pisi results.Rdata") } +if (exists("rhpuResults") == FALSE) { load("data/arme results.Rdata") } ## assemble results tibbles from individual species data -heightDiameterResults = bind_rows(psmeResults, alruResults, tsheResults, acmaResults, - umcaResults, thplResults, otherResults) %>% - mutate(baseName = if_else(word(name) %in% c("REML", "modified", "unified"), paste(word(name, 1), word(name, 2)), word(name)), - species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species"), levels = c("PSME", "ALRU2", "TSHE", "ACMA3", "UMCA", "THPL", "other")), - speciesFraction = recode(species, "Douglas-fir" = 0.750, "red alder" = 0.101, "western hemlock" = 0.056, "bigleaf maple" = 0.029, "Oregon myrtle" = 0.025, "western redcedar" = 0.013, "other species" = 0.017), +# heightDiameterResults = bind_rows(psmeResults, alruResults, tsheResults, acmaResults, +# umcaResults, thplResults, otherResults) %>% +# mutate(baseName = if_else(word(name) %in% c("REML", "modified", "unified"), paste(word(name, 1), word(name, 2)), word(name)), +# species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species"), levels = c("PSME", "ALRU2", "TSHE", "ACMA3", "UMCA", "THPL", "other")), +# speciesFraction = recode(species, "Douglas-fir" = 0.750, "red alder" = 0.101, "western hemlock" = 0.056, "bigleaf maple" = 0.029, "Oregon myrtle" = 0.025, "western redcedar" = 0.013, "other species" = 0.017), +# isBaseForm = (str_detect(name, "Sharma-") == FALSE) & (str_detect(name, "ABA\\+T") == FALSE) & (str_detect(name, "BA\\+L") == FALSE) & (str_detect(name, "physio") == FALSE) & (str_detect(name, "RelDbh") == FALSE) & (str_detect(name, "RelHt") == FALSE), +# hasPhysio = str_detect(name, "physio"), +# hasStand = str_detect(name, "ABA\\+T") | str_detect(name, "BA\\+L"), +# hasRelative = str_detect(name, "RelDbh") | str_detect(name, "RelHt"), +# significant = as.logical(significant), # since R lacks NA_logical_ significant can end up being either of type double (0/1/NA_real_) or logical (TRUE/FALSE), standardize back to logical (TRUE/FALSE/NA) +# weighting = if_else(fitting %in% c("gnls", "nlrob"), "reweighted", "fixed weights"), +# sizeShapeAlpha = as.factor(if_else(significant == TRUE, weighting, "not significant"))) %>% +# group_by(fitSet, fixedWeight, responseVariable, species) %>% +# mutate(nFits = n(), +# deltaAicN = aic/nValidation - min(aic/nValidation, na.rm = TRUE)) %>% # ΔAIC within response variable and species, needed for AUCs and figures +# ungroup() + +heightDiameterResults = bind_rows(rhpuResults,armeResults,pisiResults,psmeResults) %>% + mutate(baseName = if_else(word(name) %in% c("REML", "modified", "unified"), paste(word(name, 1), word(name, 2)), word(name)), #simply paste the names of the model from the tibble as required + species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar","cascara buckthorn","sitka spruce","pacific madrone", "other species"), levels = c("PSME", "alru2", "tshe", "acma3", "umca", "thpl", "rhpu","pisi","arme", "other")), + speciesFraction = recode(species, "Douglas-fir" = 0.750, "red alder" = 0.101, "western hemlock" = 0.056, "bigleaf maple" = 0.029, "Oregon myrtle" = 0.025, "western redcedar" = 0.013, "cascara buckthorn"= 0.007, "sitka spruce"=0.006, "pacific madrone" = 0.004,"other species" = 0.009), isBaseForm = (str_detect(name, "Sharma-") == FALSE) & (str_detect(name, "ABA\\+T") == FALSE) & (str_detect(name, "BA\\+L") == FALSE) & (str_detect(name, "physio") == FALSE) & (str_detect(name, "RelDbh") == FALSE) & (str_detect(name, "RelHt") == FALSE), hasPhysio = str_detect(name, "physio"), hasStand = str_detect(name, "ABA\\+T") | str_detect(name, "BA\\+L"), @@ -33,17 +51,27 @@ heightDiameterResults = bind_rows(psmeResults, alruResults, tsheResults, acmaRes mutate(nFits = n(), deltaAicN = aic/nValidation - min(aic/nValidation, na.rm = TRUE)) %>% # ΔAIC within response variable and species, needed for AUCs and figures ungroup() + # report duplicate naming and fit failures heightDiameterResults %>% group_by(fitSet, responseVariable, species, name) %>% summarize(n = n(), .groups = "drop") %>% filter(n != htDiaOptions$folds * htDiaOptions$repetitions) -heightDiameterCoefficients = left_join(bind_rows(psmeCoefficients, alruCoefficients, tsheCoefficients, acmaCoefficients, # ~28 s - umcaCoefficients, thplCoefficients, otherCoefficients) %>% - mutate(species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species"), levels = c("PSME", "ALRU2", "TSHE", "ACMA3", "UMCA", "THPL", "other"))), +# heightDiameterCoefficients = left_join(bind_rows(psmeCoefficients, alruCoefficients, tsheCoefficients, acmaCoefficients, # ~28 s +# umcaCoefficients, thplCoefficients, otherCoefficients) %>% +# mutate(species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species"), levels = c("PSME", "ALRU2", "TSHE", "ACMA3", "UMCA", "THPL", "other"))), +# heightDiameterResults %>% select(-fitting, -fixedWeight, -significant), # no need to join duplicate columns +# by = join_by(fitSet, responseVariable, species, name, repetition, fold)) %>% +# mutate(isConverged = as.logical(isConverged)) %>% +# select(-weighting, -sizeShapeAlpha, -nFits, -nTaperImplausible, -speciesFraction) %>% +# relocate(responseVariable, species, fitSet, fixedWeight, name, significant, isBaseForm, hasRelative, hasStand, hasPhysio, fitting, repetition, fold, nObservations, nValidation, fitTimeInS, isConverged, effectiveDegreesOfFreedom, nNonPhysical, mab, mapb, mae, mape, rmse, rmspe, aic, deltaAicN, nse, meanAbsolutePlantationEffect, meanAbsolutePercentPlantationEffect, a0, a1, a1p, a2, a2p, a3, a3p, a4, a5, a6, a7, a8, a9, a9p, a10, a10p, b1, b1p, b2, b2p, b3, b3p, b4, b4p) + +heightDiameterCoefficients = left_join(bind_rows(rhpuCoefficients,pisiCoefficients,armeCoefficients,psmeCoefficients # ~28 s + ) %>% + mutate(species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar","cascara buckthorn","sitka spruce","pacific madrone", "other species"), levels = c("psme", "alru2", "tshe", "acma3", "umca", "thpl","rhpu","pisi","arme", "other"))), heightDiameterResults %>% select(-fitting, -fixedWeight, -significant), # no need to join duplicate columns by = join_by(fitSet, responseVariable, species, name, repetition, fold)) %>% mutate(isConverged = as.logical(isConverged)) %>% select(-weighting, -sizeShapeAlpha, -nFits, -nTaperImplausible, -speciesFraction) %>% - relocate(responseVariable, species, fitSet, fixedWeight, name, significant, isBaseForm, hasRelative, hasStand, hasPhysio, fitting, repetition, fold, nObservations, nValidation, fitTimeInS, isConverged, effectiveDegreesOfFreedom, nNonPhysical, mab, mapb, mae, mape, rmse, rmspe, aic, deltaAicN, nse, meanAbsolutePlantationEffect, meanAbsolutePercentPlantationEffect, a0, a1, a1p, a2, a2p, a3, a3p, a4, a5, a6, a7, a8, a9, a9p, a10, a10p, b1, b1p, b2, b2p, b3, b3p, b4, b4p) + relocate(responseVariable, species, fitSet, fixedWeight, name, significant, isBaseForm, hasRelative, hasStand, hasPhysio, fitting, repetition, fold, nObservations, nValidation, fitTimeInS, isConverged, effectiveDegreesOfFreedom, nNonPhysical, mab, mapb, mae, mape, rmse, rmspe, aic, deltaAicN, nse, meanAbsolutePlantationEffect, meanAbsolutePercentPlantationEffect, a0, a1, a1p, a2, a2p, a3, a3p, a4, a8, a9, a9p, a10, b1, b1p, b2, b2p, b3, b4) #write_xlsx(heightDiameterCoefficients %>% # filter(fitSet == "primary", is.na(fixedWeight)) %>% # select(-baseName, -fitSet, -fixedWeight, -aict, -bic, -bict, -bias, -ends_with("NaturalRegen"), -ends_with("Plantation"), -adaptiveWeightFraction) %>% # drop diagnostic columns @@ -57,8 +85,8 @@ primaryResults = heightDiameterResults %>% filter(fitSet == "primary", is.na(fixedWeight), fitting != "gnls", # exclude fits from gnls() (responseVariable != "height") | (str_detect(name, "RelHt") == FALSE), # exclude height control forms using relative height (responseVariable != "DBH") | (str_detect(name, "BA\\+L") == FALSE)) # exclude diameter control forms using basal area -#print(primaryResults %>% group_by(fitSet, responseVariable) %>% reframe(n = n(), names = unique(name)), n = 60) -#primaryResults %>% group_by(fitSet, species) %>% summarize(deltaAicN = sum(is.na(deltaAicN)), mab = sum(is.na(mab)), mae = sum(is.na(mae)), nse = sum(is.na(nse)), rmse = sum(is.na(rmse))) +print(primaryResults %>% group_by(fitSet, responseVariable) %>% reframe(n = n(), names = unique(name)), n = 60) +primaryResults %>% group_by(fitSet, species) %>% summarize(deltaAicN = sum(is.na(deltaAicN)), mab = sum(is.na(mab)), mae = sum(is.na(mae)), nse = sum(is.na(nse)), rmse = sum(is.na(rmse))) # rank model forms by estimated prediction ability (using AUC) for form selection # runtime, seconds @@ -69,14 +97,15 @@ primaryResults = heightDiameterResults %>% # 7 20.6 # 8 20.9 # 16 20.4 + + with_progress({ crossValidatedModelCount = primaryResults %>% group_by(responseVariable, species) %>% summarize(n = n_distinct(name), .groups = "drop") progressBar = progressor(steps = sum(crossValidatedModelCount$n)) - heightDiameterModelAucs = primaryResults %>% group_by(responseVariable, species, name) %>% group_split() %>% - future_map_dfr(function(fitResults) + future_map_dfr(function(fitResults) #future_map_dfr applies a function to multiple data frames created from above group_by function. { if ((nrow(fitResults) == 1) | all(is.na(fitResults$nse))) { @@ -123,10 +152,10 @@ with_progress({ aucMab = NA_real_ if ((nrow(availableMabData) > 1) & (n_distinct(availableMabData$label) > 1)) # unlikely but possible that availableMabData ends up with a single row, also possible one set of fits has MAB values but the other does not { - #if ((nrow(availableMabData) < 2) | (n_distinct(availableMabData$label) < 2)) - #{ - # stop(paste0("MAB ROC label formation error with name = ", otherModelName, " for ", fitResults$species[1], " ", fitResults$responseVariable[1], ". nrow(fitResults) = ", nrow(fitResults), ", nrow(otherFitResults) = ", nrow(otherFitResults), ", nrow(availableMabData) = ", nrow(availableMabData), ".")) - #} + if ((nrow(availableMabData) < 2) | (n_distinct(availableMabData$label) < 2)) + { + stop(paste0("MAB ROC label formation error with name = ", otherModelName, " for ", fitResults$species[1], " ", fitResults$responseVariable[1], ". nrow(fitResults) = ", nrow(fitResults), ", nrow(otherFitResults) = ", nrow(otherFitResults), ", nrow(availableMabData) = ", nrow(availableMabData), ".")) + } aucMab = WeightedAUC(WeightedROC(guess = availableMabData$guess, label = availableMabData$label)) } @@ -714,8 +743,8 @@ print(heightDiameterModelRanking %>% filter(significant, isBaseForm) %>% select( group_by(species, responseVariable, statistic) %>% slice_max(auc, n = 1) %>% arrange(species, desc(responseVariable), statistic), n = 70) -if (exists("psmeHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/PSME preferred models.Rdata") } -if (exists("alruHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/ALRU2 preferred models.Rdata") } +if (exists("psmeHeightFromDiameterPreferred") == FALSE) { load("data/PSME preferred models.Rdata") } +if (exists("alruHeightFromDiameterPreferred") == FALSE) { load("data/ALRU2 preferred models.Rdata") } # Temesgen et al. 2007 height = 1.3 + exp(b1 - b2 * DBH^b3) => b1 - b2 * DBH^b3 = ln(height - 1.3) => DBH^b3 = 1/b2 * (b1 - ln(height - 1.3)) # DBH = (1/b2 * (b1 - ln(height - 1.3)))^(1/b3) @@ -811,8 +840,8 @@ ggsave("trees/height-diameter/figures/Figure 06 PSME-ALRU2 curves 1000.pdf", hei ## Figure 7: western hemlock and bigleaf maple preferred models #print(preferredForms %>% filter(species %in% c("western hemlock", "bigleaf maple")) %>% select(-mabName, -aucMab, -nseName, -aucNse) %>% rename(respVar = responseVariable, base = isBaseForm, aucAic = aucDeltaAicN) %>% mutate(species = factor(species, labels = c("PSME", "ALRU2", "TSHE", "ACMA3", "UMCA", "THPL", "other"), levels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species")), maeName = str_trunc(maeName, 28, ellipsis = ""), rmseName = str_trunc(rmseName, 28, ellipsis = ""), aicName = str_trunc(aicName, 28, ellipsis = "")), n = 32) -if (exists("tsheHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/TSHE preferred models.Rdata") } -if (exists("acmaHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/ACMA3 preferred models.Rdata") } +if (exists("tsheHeightFromDiameterPreferred") == FALSE) { load("data/TSHE preferred models.Rdata") } +if (exists("acmaHeightFromDiameterPreferred") == FALSE) { load("data/ACMA3 preferred models.Rdata") } tsheReference = bind_rows(bind_rows(tsheHeightFromDiameterPreferred$gam$stats %>% mutate(model = "base form 1"), tsheHeightFromDiameterPreferred$chapmanRichards$stats %>% mutate(model = "base form 2"), @@ -905,8 +934,8 @@ ggsave("trees/height-diameter/figures/Figure 07 TSHE-ACMA3 curves.pdf", height = ## Figure 8: Oregon myrtle and western redcedar preferred models #print(preferredForms %>% filter(species %in% c("Oregon myrtle", "western redcedar")) %>% select(-mabName, -aucMab, -nseName, -aucNse) %>% rename(respVar = responseVariable, base = isBaseForm, aucAic = aucDeltaAicN) %>% mutate(species = factor(species, labels = c("PSME", "ALRU2", "TSHE", "ACMA3", "UMCA", "THPL", "other"), levels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species")), maeName = str_trunc(maeName, 28, ellipsis = ""), rmseName = str_trunc(rmseName, 28, ellipsis = ""), aicName = str_trunc(aicName, 28, ellipsis = "")), n = 32) -if (exists("umcaHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/UMCA preferred models.Rdata") } -if (exists("thplHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/THPL preferred models.Rdata") } +if (exists("umcaHeightFromDiameterPreferred") == FALSE) { load("data/UMCA preferred models.Rdata") } +if (exists("thplHeightFromDiameterPreferred") == FALSE) { load("data/THPL preferred models.Rdata") } # no prior height model for Oregon myrtle, so no UMCA reference or reference DBH umcaReference = bind_rows(bind_rows(umcaHeightFromDiameterPreferred$michaelisMenten$stats %>% mutate(model = "base form 1"), @@ -1009,7 +1038,7 @@ ggsave("trees/height-diameter/figures/Figure 08 UMCA-THPL curves.pdf", height = # power REML GAM BAL+L physio parabolic Chapman-Richards form RelHt # Korf linear #print(preferredForms %>% filter(species == "other species") %>% select(-mabName, -aucMab, -nseName, -aucNse) %>% rename(respVar = responseVariable, base = isBaseForm, aucAic = aucDeltaAicN) %>% mutate(species = factor(species, labels = c("PSME", "ALRU2", "TSHE", "ALRU2", "ACMA3", "UMCA", "THPL", "other"), levels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar", "other species")), maeName = str_trunc(maeName, 28, ellipsis = ""), rmseName = str_trunc(rmseName, 28, ellipsis = ""), aicName = str_trunc(aicName, 28, ellipsis = "")), n = 16) -if (exists("otherHeightFromDiameterPreferred") == FALSE) { load("trees/height-diameter/data/other preferred models.Rdata") } +if (exists("otherHeightFromDiameterPreferred") == FALSE) { load("data/other preferred models.Rdata") } # no prior height model for other species, so no reference or reference DBH otherReference = bind_rows(bind_rows(otherHeightFromDiameterPreferred$gam$stats %>% mutate(model = "base form 1"), From 61ab35d18e8f61f1e6575868f74158100ca7a530 Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 11 Jun 2025 13:49:46 -0700 Subject: [PATCH 10/13] update thpl for public dataset --- trees/height-diameter/THPL.R | 112 +++++++++++++++++------------------ 1 file changed, 56 insertions(+), 56 deletions(-) diff --git a/trees/height-diameter/THPL.R b/trees/height-diameter/THPL.R index fd98e6f..18854b4 100644 --- a/trees/height-diameter/THPL.R +++ b/trees/height-diameter/THPL.R @@ -32,11 +32,11 @@ thpl2016defaultWeightPhysio = thpl2016defaultWeight %>% filter(is.na(elevation) #make a tibble to store the parameters and later call them into the code thplOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response fitHeightNlrob = TRUE, #robust non-linear least square, height as response - fitHeightGnls = FALSE, #generalized least square, height as response - fitHeightMixed = FALSE, #non-linear mixed effects, height as response + fitHeightGnls = TRUE, #generalized least square, height as response + fitHeightMixed = TRUE, #non-linear mixed effects, height as response fitDbh = TRUE, #non-linear least square, dbh as response - fitDbhNlrob = FALSE, #robust non-linear least square, dbh as response - fitDbhMixed = FALSE, #non-linear mixed effects, dbh as response + fitDbhNlrob = TRUE, #robust non-linear least square, dbh as response + fitDbhMixed = TRUE, #non-linear mixed effects, dbh as response includeInvestigatory = TRUE #added investigatory plots, and figures of the results ) @@ -146,14 +146,14 @@ if (thplOptions$fitHeight) { #if the value in the column fitHeight of thplOption thplHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) thplHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), thpl2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) - thplHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types - thplHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20), data = thpl2016, constraint = thpl2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model - thplHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18), data = thpl2016, constraint = thpl2016gamConstraint) # k reduces from 85 to 18 without aspect - thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16), data = thpl2016, constraint = thpl2016gamConstraint) - thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation)), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + thplHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + thplHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # k reduces from 85 to 18 without aspect + thplHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) + thplHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) save(file = "data/THPL TotalHt.Rdata", thplHeightFromDiameter, thplHeightFromDiameterNlrob, thplHeightFromDiameterGslNlsDefault) } @@ -208,10 +208,10 @@ if (thplOptions$fitHeightGnls) { thplHeightFromDiameterGnls = list(chapmanRichards = fit_gnls("Chapman-Richards GNLS", TotalHt ~ 1.37 + a1*(1 - exp(b1*DBH))^b2, thpl2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), control = gnlsControl(nlsTol = 0.001))) # step halving at nlsTol = 1 with corSymm #thplHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, thpl2016, start = thplHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm - thplHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm - thplHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + # thplHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + # thplHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation #thplHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, start = thplHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation - thplHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + # thplHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, start = thplHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation thplHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, start = thplHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped thplHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), thpl2016, start = thplHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm @@ -297,15 +297,15 @@ if (thplOptions$fitHeightMixed){ #fitting height diameter using mixed effect mod thplHeightFromDiameterMixed$sharmaPartonPhysio = fit_nlme("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 1E-3)) # singular precision matrix, step halving - thplHeightFromDiameterMixed$sharmaZhang = fit_nlme("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, - fixedFormula = a1 + a1p + b1 + b2 + b3 + b4 + b4p ~ 1, randomFormula = a1r ~ 1, - start = list(fixed = c(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve - thplHeightFromDiameterMixed$sharmaZhangBal = fit_nlme("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, - fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, - start = list(fixed = c(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve - #thplHeightFromDiameterMixed$sibbesen = fit_nlme("Sibbesen", TotalHt ~ 1.37 + a1*DBH^((b1 + b1r)*DBH^b2), thpl2016, - # fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = b1r ~ 1, - # start = list(fixed = c(a1 = 0.302, b1 = 1.495, b2 = -0.078))) # a1r: step halving, singular precision + # thplHeightFromDiameterMixed$sharmaZhang = fit_nlme("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), thpl2016, + # fixedFormula = a1 + a1p + b1 + b2 + b3 + b4 + b4p ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + # thplHeightFromDiameterMixed$sharmaZhangBal = fit_nlme("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, thpl2016, + # fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + thplHeightFromDiameterMixed$sibbesen = fit_nlme("Sibbesen", TotalHt ~ 1.37 + a1*DBH^((b1 + b1r)*DBH^b2), thpl2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = b1r ~ 1, + start = list(fixed = c(a1 = 0.302, b1 = 1.495, b2 = -0.078))) # a1r: step halving, singular precision thplHeightFromDiameterMixed$weibull = fit_nlme("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), thpl2016, fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141))) @@ -381,7 +381,7 @@ if (thplOptions$fitDbh) { thplDiameterFromHeightNlrob$sibbesenReplaceAbat = fit_nlrob("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.1, a2 = -0.004, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4)) # job step factor thplDiameterFromHeightNlrob$sibbesenReplaceAbatPhysio = fit_nlrob("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) thplDiameterFromHeightNlrob$sibbesenReplaceAbatPhysioRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.01, a9 = 0.5, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor - thplDiameterFromHeightNlrob$sibbesenReplaceAbatRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.1, a2 = 0, a9 = 0, a9p = 0.7, b1 = 0.6, b2 = 0.12), significant = FALSE) + # thplDiameterFromHeightNlrob$sibbesenReplaceAbatRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.1, a2 = 0, a9 = 0, a9p = 0.7, b1 = 0.6, b2 = 0.12), significant = FALSE) thplDiameterFromHeightNlrob$sibbesenReplacePhysio = fit_nlrob("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) thplDiameterFromHeightNlrob$sibbesenReplaceRelHt = fit_nlrob("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) thplDiameterFromHeightNlrob$weibull = fit_nlrob("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016, start = list(a1 = -250, b1 = 0.043, b2 = 0.58), control = nls.control(maxiter = 500)) @@ -390,38 +390,38 @@ if (thplOptions$fitDbh) { thplDiameterFromHeightNlrob = list() } thpl2016defaultWeight <- thpl2016defaultWeight %>% filter(TotalHt > 5) #the code was not running and giving an error, probably because some variable used in the following models were not valid. Therefore subset of trees taller that 5 ft is taken for further analysis. - thplDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) + #thplDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) thplDiameterFromHeightGslNlsDefault$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, thpl2016defaultWeight, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) - #thplDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) + thplDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) + # thplDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) thplDiameterFromHeightGslNlsDefault$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) + thplDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) thplDiameterFromHeightGslNlsDefault$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016defaultWeight, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) #thplDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), thpl2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) thplDiameterFromHeightGslNlsDefault$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) thplDiameterFromHeightGslNlsDefault$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.93, b1 = 1.08)) - #thplDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) - #thplDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, thpl2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + thplDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + thplDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, thpl2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + thplDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, thpl2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) thplDiameterFromHeightGslNlsDefault$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) thplDiameterFromHeightGslNlsDefault$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a2 = -0.01, a4 = -0.0006, b1 = 1.2, b2 = -0.009), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a3 = -0.003, a4 = -0.0006, a9 = 0.4, b1 = 1.27, b2 = -0.01), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 1.3, a3 = -0.003, a9 = 0.25, b1 = 1.3, b2 = -0.008), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + thplDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) thplDiameterFromHeightGslNlsDefault$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeight, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant - #thplDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), thpl2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) + thplDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), thpl2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant + thplDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), thpl2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) thplDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, thpl2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) thplDiameterFromHeightGslNlsDefault$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.5, a2 = -0.009, a8 = -0.005, b1 = 1.2, b2 = -0.04), significant = FALSE) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.41, a2 = -0.009, a8 = -0.005, a9 = 0, b1 = 1.4, b2 = -0.05), significant = FALSE) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 1.5, a2 = -0.008, a9 = 0, a9p = 0, b1 = 1.4, b2 = 0), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + thplDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeight, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) - #thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant - #thplDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) + thplDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), thpl2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant + thplDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, thpl2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined thplDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint) # newton() step failure with scat() @@ -494,9 +494,9 @@ if (thplOptions$fitDbhMixed) { #thplDiameterFromHeightMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards inverse physio", DBH ~ (a1 + a1r + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), thpl2016, # fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, # start = list(fixed = c(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations, step halving - thplDiameterFromHeightMixed$chapmanRichardsRelHt = fit_nlme("Chapman-Richards inverse RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016, - fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, - start = list(fixed = c(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving, singularity in backsolve + # thplDiameterFromHeightMixed$chapmanRichardsRelHt = fit_nlme("Chapman-Richards inverse RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), thpl2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving, singularity in backsolve thplDiameterFromHeightMixed$michaelisMentenReplace = fit_nlme("Michaelis-Menten replace", DBH ~ (a1 + a1r) * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), thpl2016, fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 519, a2 = 237, b1 = 1.00)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations, step halving @@ -591,11 +591,11 @@ if (thplOptions$fitDbhMixed) { ## collect model results and parameters if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) { - if (exists("thplHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/THPL TotalHt.Rdata") } + if (exists("thplHeightFromDiameter") == FALSE) { load("data/THPL TotalHt.Rdata") } #if (exists("thplHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/THPL TotalHt gnls.Rdata") } - if (exists("thplHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/THPL TotalHt mixed.Rdata") } - if (exists("thplDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/THPL DBH.Rdata") } - if (exists("thplDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/THPL DBH mixed.Rdata") } + if (exists("thplHeightFromDiameterMixed") == FALSE) { load("data/THPL TotalHt mixed.Rdata") } + if (exists("thplDiameterFromHeight") == FALSE) { load("data/THPL DBH.Rdata") } + if (exists("thplDiameterFromHeightMixed") == FALSE) { load("data/THPL DBH mixed.Rdata") } thplCoefficients = bind_rows(bind_rows(bind_rows(lapply(thplHeightFromDiameter, get_list_coefficients)), #bind_rows(lapply(thplHeightFromDiameterGnls, get_model_coefficients)), bind_rows(lapply(thplHeightFromDiameterGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), @@ -626,8 +626,8 @@ if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & th save(file = "data/THPL results.Rdata", thplCoefficients, thplResults) } else if (thplOptions$fitHeight & thplOptions$fitHeightMixed & thplOptions$fitDbh & thplOptions$fitDbhMixed) { - if (exists("thplHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/THPL TotalHt.Rdata") } - if (exists("thplDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/THPL DBH.Rdata") } + if (exists("thplHeightFromDiameter") == FALSE) { load("data/THPL TotalHt.Rdata") } + if (exists("thplDiameterFromHeight") == FALSE) { load("data/THPL DBH.Rdata") } thplCoefficients = bind_rows(bind_rows(bind_rows(lapply(thplHeightFromDiameter, get_list_coefficients))) %>% mutate(responseVariable = "height"), @@ -655,18 +655,18 @@ if (thplOptions$fitHeight & thplOptions$fitDbh) thplHeightFromDiameterPreferred$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), thpl2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176), folds = 1, repetitions = 1) thplHeightFromDiameterPreferred$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), thpl2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176), folds = 1, repetitions = 1) thplHeightFromDiameterPreferred$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), thpl2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649), folds = 1, repetitions = 1) - #thplHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) - #thplHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) + thplHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) + thplHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, thpl2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) thplHeightFromDiameterPreferred$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, thpl2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09), folds = 1, repetitions = 1) - #thplHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) - #AIC(thplHeightFromDiameterPreferred$hossfeld, thplHeightFromDiameterPreferred$michaelisMenten, thplHeightFromDiameterPreferred$prodan, thplHeightFromDiameterPreferred$ratkowsky) + thplHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), thpl2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) + AIC(thplHeightFromDiameterPreferred$hossfeld, thplHeightFromDiameterPreferred$michaelisMenten, thplHeightFromDiameterPreferred$prodan, thplHeightFromDiameterPreferred$ratkowsky) thplDiameterFromHeightPreferred = list(gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1)) - #thplDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) + thplDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), thpl2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), thpl2016, folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, thpl2016, start = list(a1 = 1.93, b1 = 1.08), folds = 1, repetitions = 1) - #thplDiameterFromHeightPreferred$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) - #thplDiameterFromHeightPreferred$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) + thplDiameterFromHeightPreferred$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) + thplDiameterFromHeightPreferred$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) thplDiameterFromHeightPreferred$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = thpl2016, constraint = thpl2016gamConstraint, folds = 1, repetitions = 1) @@ -679,7 +679,7 @@ if (htDiaOptions$includeInvestigatory) { thplBasalAreaFromHeightKorf = gsl_nls(basalArea ~ a1*(exp(b1*(imputedHeight - 1.37)^b2) - 1), thpl2016, start = list(a1 = 90, b1 = 0.000003, b2 = 2.18), weights = heightWeight^2) # a1p, b1p, b2p not significant thplBasalAreaFromHeightPower = gsl_nls(basalArea ~ a1*(imputedHeight - 1.37)^(b1 + b1p * isPlantation), thpl2016, start = list(a1 = 3/7 * 0.25 * pi * 0.01^2, b1 = 2.14, b1p = 0.34), weights = heightWeight^2) # a1p not significant - #confint2(thplBasalAreaFromHeightPower, level = 0.99) + confint2(thplBasalAreaFromHeightPower, level = 0.99) tribble(~method, ~aic, ~biasCm2, ~maeM2, ~nse, "Korf", AIC(thplBasalAreaFromHeightKorf), 100^2 * mean(residuals(thplBasalAreaFromHeightKorf)), mean(abs(residuals(thplBasalAreaFromHeightKorf))), 1 - sum(residuals(thplBasalAreaFromHeightKorf)^2) / sum((thpl2016$basalArea - mean(thpl2016$basalArea)^2)), @@ -774,7 +774,7 @@ if (htDiaOptions$includeInvestigatory) { library(caret) library(ranger) - #thplForest = ranger(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger, thpl2016, classification = TRUE, num.threads = 12) + thplForest = ranger(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger, thpl2016, classification = TRUE, num.threads = 12) repeatedCrossValidation = trainControl(method = "repeatedcv", number = htDiaOptions$folds, repeats = htDiaOptions$repetitions, verboseIter = FALSE) thplHeightForest = train(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger + elevation + slope + aspect + topographicShelterIndex + relativeDiameter, data = thpl2016, method = "ranger", trControl = repeatedCrossValidation, importance = "impurity_corrected", From f60f2a71cb3406fd7669b41c8cbbd489e98ed9cf Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 11 Jun 2025 13:50:22 -0700 Subject: [PATCH 11/13] update arme for public dataset --- trees/height-diameter/ARME.R | 813 +++++++++++++++++++++++++++++++++++ 1 file changed, 813 insertions(+) create mode 100644 trees/height-diameter/ARME.R diff --git a/trees/height-diameter/ARME.R b/trees/height-diameter/ARME.R new file mode 100644 index 0000000..751610f --- /dev/null +++ b/trees/height-diameter/ARME.R @@ -0,0 +1,813 @@ +# load libraries, functions, and trees2016 from Elliott Stand Data Feb2022.R + + +## cascara buckthorn height-diameter regression form sweep + +#arme HeightFromDiameter$gamPhysio = gam(TotalHt ~ s(DBH, elevation, slope, sin(3.14159/180 * aspect), cos(3.14159/180 * aspect), topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 85, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, select = TRUE, weights = dbhWeight) + +# bs= "ts" -> 367, gamma = 2 -> 367, k = 169 min vs 367 default, method = "REML" -> 367 + +#arme HeightFromDiameter$sharmaPartonBalPhysio = gsl_nls(TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^(a2 + a2p * isPlantation) * (1 + a3 * elevation + a4 * sin(3.14159/180 * aspect) + a5 * cos(3.14159/180 * aspect) + a6 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^(b2 + b2p * isPlantation)*DBH))^(b3 + b3p * isPlantation), arme2016, start = list(a1 = 39.8, a1p = -12.3, a2 = 0.52, a2p = 0.0027, a3 = 0.00001, a4 = 0.0131, a5 = 0.0046, a6 = 0.0060, b1 = -0.0098, b1p = -0.0143, b2 = 0.125, b2p = -0.186, b3 = 1.12, b3p = 0.0086), weights = armeHeightFromDiameterWeights) + +arme2016 = trees2016 %>% + filter(Species == "ARME", isLiveUnbroken, is.na(TotalHt) == FALSE,is.na(elevation)==FALSE) %>% # live cascara buckthorns measured for height + mutate(dbhWeight = pmin(TreeCount/(0.14*DBH^1.20), 5*TreeCount), + heightWeight = pmin(TreeCount/(2.29*(TotalHt - 1.37)^1.45), 5*TreeCount)) + +# no trees without physiographic variables +arme2016gamConstraint = c(DBH = -1.2264/0.5099, TotalHt = 1.37, standBasalAreaPerHectare = median(arme2016$standBasalAreaPerHectare), basalAreaLarger = median(arme2016$basalAreaLarger), standBasalAreaApprox = median(arme2016$standBasalAreaApprox), tallerApproxBasalArea = median(arme2016$tallerApproxBasalArea), elevation = median(arme2016$elevation), slope = median(arme2016$slope), aspect = median(arme2016$aspect), topographicShelterIndex = median(arme2016$topographicShelterIndex), relativeHeight = median(arme2016$relativeHeight), relativeDiameter = median(arme2016$relativeDiameter)) # point constraint for mgcv::s() + +arme2016defaultWeight = arme2016 %>% mutate(dbhWeight = pmin(TreeCount/DBH, 5*TreeCount), + heightWeight = pmin(TreeCount/TotalHt, 5*TreeCount)) +arme2016defaultWeightPhysio = arme2016defaultWeight %>% filter(is.na(elevation) == FALSE) + +# armeOptions = tibble(fitHeight = TRUE, +# fitHeightNlrob = FALSE, +# fitHeightGnls = FALSE, +# fitHeightMixed = FALSE, +# fitDbh = TRUE, +# fitDbhNlrob = FALSE, +# fitDbhMixed = FALSE) + +#make a tibble to store the parameters and later call them into the code +armeOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response + fitHeightNlrob = FALSE, #robust non-linear least square, height as response + fitHeightGnls = TRUE, #generalized least square, height as response + fitHeightMixed = FALSE, #non-linear mixed effects, height as response + fitDbh = TRUE, #non-linear least square, dbh as response + fitDbhNlrob = FALSE, #robust non-linear least square, dbh as response + fitDbhMixed = FALSE, #non-linear mixed effects, dbh as response + includeInvestigatory = TRUE #added investigatory plots, and figures of the results +) + +if (armeOptions$fitHeight) { #if the value in the column fitHeight of armeOptions table is TRUE execute the expression within the curly braces. + armeHeightFromDiameter = list(linear = fit_lm("linear", TotalHt ~ 0 + DBH, arme2016)) # isPlantation*DBH not significant (p = 0.044) #creates output from the model fitting and validation 10*10=100 rows of all combination of folds and repetition and stores it as a list and adds all the following models in a similar fashion to the existing list (notice the $ sign in the code from the second line withing the curly braces) + armeHeightFromDiameter$parabolic = fit_lm("parabolic", TotalHt ~ 0 + DBH + I(DBH^2), arme2016) # isPlantation*DBH not quite significant (p = 0.106), isPlantation*DBH^2 not significant + + #armeHeightFromDiameter$chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131)) # a1p, b1p, b2p not significant + armeHeightFromDiameter$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) # a3, a3p, b1p, b2p not significant + #armeHeightFromDiameter$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) # a2, a3, a4, a5, a6, a7, a8p, b2p not significant + #armeHeightFromDiameter$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016, start = list(a1 = 58, a1p = -16, a2 = 0, a2p = 0.4, a8 = 0.3, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) # a2, a10, a10p not significant + #armeHeightFromDiameter$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.3, b1 = -0.012, b2 = 1.1), significant = FALSE) # a2, a10, a10p not significant + armeHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), arme2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() + #armeHeightFromDiameter$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) # a4, a5, a6, a7, a8p, b2p not significant + #armeHeightFromDiameter$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 72, a10 = -3.2, b1 = -0.012, b2 = 1.09)) # a10p not significant + #armeHeightFromDiameter$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) # a10, a10p not significant + armeHeightFromDiameter$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, arme2016, start = list(a1 = 0.560, b1 = 0.069)) # a1p, b1p not significant + #armeHeightFromDiameter$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), arme2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) # b2p not significant + #armeHeightFromDiameter$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), arme2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) # a1p, b1p, b2p not significant + #armeHeightFromDiameter$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), arme2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) # b1p not significant + armeHeightFromDiameter$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), arme2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) # a2p, a3p not significant + armeHeightFromDiameter$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, arme2016, start = list(a1 = 0.542, b1 = 0.939)) # a1p, b1p not significant + armeHeightFromDiameter$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), arme2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #armeHeightFromDiameter$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), arme2016, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) # dp not significant, susceptible to NaN-inf + #armeHeightFromDiameter$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)) # a1p, b3p, b4p not significant + armeHeightFromDiameter$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)) # a1p, b1p, b2p, b3p, b4p not significant + #armeHeightFromDiameter$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) # b1, b1p, a4, a5, a6, a7, b3p, b4p not significant + #armeHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant + #armeHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant + #armeHeightFromDiameter$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) # a4, a5, a5, a6, a7, b1p, b3p, b4p not significant + #armeHeightFromDiameter$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016, start = list(a1 = 21, a10 = 0, b1 = 0.25, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = 0, b4 = 1.12), significant = FALSE) # a10, a10p not significant + #armeHeightFromDiameter$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016, start = list(a1 = 36, a8 = 0.18, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = -0.03, b4 = 1.09), significant = FALSE) # a1p, a10, a10p, b2p not significant + #armeHeightFromDiameter$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), arme2016, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) # b1, b1p, b2p, b3p not significant + #armeHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, arme2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant + armeHeightFromDiameter$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), arme2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) # a1p, b1p, b2p not significant + #armeHeightFromDiameter$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), arme2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) # b2p not significant + #armeHeightFromDiameter$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), arme2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) # a1p, a2, a3, b1p, b2p not significant + #armeHeightFromDiameter$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), arme2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) # a1p, a2, a3, a3p, b1p, b2p not significant + + if (armeOptions$fitHeightNlrob) + { + armeHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 5.2, b1 = -0.015, b2 = 1.131))) + #armeHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + #armeHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + #armeHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) + #armeHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) + armeHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), arme2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor + #armeHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + armeHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) + #armeHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) + armeHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, arme2016, start = list(a1 = 0.560, b1 = 0.069)) + armeHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), arme2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + armeHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), arme2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + #armeHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), arme2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + armeHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), arme2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + armeHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, arme2016, start = list(a1 = 0.542, b1 = 0.939)) + armeHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), arme2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #armeHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), arme2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor + #armeHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor + armeHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor + #armeHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor + #armeHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor + #armeHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor + #armeHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor + #armeHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) + #armeHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) + #armeHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), arme2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant + #armeHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, arme2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor + armeHeightFromDiameterNlrob$sibbesen = fit_nlrob("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), arme2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + armeHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), arme2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor + #armeHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), arme2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + armeHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), arme2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + lapply(armeHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) + } else { + armeHeightFromDiameterNlrob = list() + } + #fitting models with defaultweight 'arme2016defaultWeight' which were fitted earlier without any weights. + #commented out models without any note at the end did not converge, for others the note is given mentioning the reason of error. + #armeHeightFromDiameterGslNlsDefault = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, arme2016defaultWeight, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) + #armeHeightFromDiameterGslNlsDefault$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, arme2016defaultWeight, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + #armeHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016defaultWeightPhysio, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) + armeHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), arme2016defaultWeight, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a3 = -0.03, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) + #armeHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016, start = list(a1 = 58, a1p = -14, a2 = -0.07, a2p = 0.48, a8 = 0.27, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) + armeHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.11), significant = FALSE) + #armeHeightFromDiameterGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016defaultWeightPhysio, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + #armeHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, arme2016defaultWeight, start = list(a1 = 74, a10 = -3.2, b1 = -0.011, b2 = 1.09)) + #armeHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016defaultWeightPhysio, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) #produced NA or infinity + armeHeightFromDiameterGslNlsDefault$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, arme2016defaultWeight, start = list(a1 = 0.560, b1 = 0.069)) + #armeHeightFromDiameterGslNlsDefault$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), arme2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + #armeHeightFromDiameterGslNlsDefault$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), arme2016defaultWeight, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + #armeHeightFromDiameterGslNlsDefault$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), arme2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + armeHeightFromDiameterGslNlsDefault$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), arme2016defaultWeight, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + armeHeightFromDiameterGslNlsDefault$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, arme2016defaultWeight, start = list(a1 = 0.542, b1 = 0.939)) + armeHeightFromDiameterGslNlsDefault$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), arme2016defaultWeight, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #armeHeightFromDiameterGslNlsDefault$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), arme2016defaultWeight, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) #produced NA or infinity + #armeHeightFromDiameterGslNlsDefault$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016defaultWeight, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09))#produced NA or infinity + #armeHeightFromDiameterGslNlsDefault$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016defaultWeight, start = list(a1 = 38, b1 = 0.12, b2 = -0.013, b3 = -0.1, b4 = 1.02)) + #armeHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016defaultWeightPhysio, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) + #armeHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016defaultWeightPhysio, start = list(a1 = 23, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.01, b2p = -0.010, b3 = -0.012, b4 = 1.14), significant = FALSE)#produced NA or infinity + #armeHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE)#produced NA or infinity + #armeHeightFromDiameterGslNlsDefault$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016defaultWeightPhysio, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09))#produced NA or infinity + #armeHeightFromDiameterGslNlsDefault$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016defaultWeight, start = list(a1 = 19, a10 = -0.3, b1 = 0.29, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.03, b4 = 1.13), significant = FALSE)#produced NA or infinity + #armeHeightFromDiameterGslNlsDefault$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016defaultWeightPhysio, start = list(a1 = 36, a8 = 0.18, a10 = 0, b1 = 0.2, b2 = -0.01, b3 = 0.03, b4 = 1.09), significant = FALSE) + #armeHeightFromDiameterGslNlsDefault$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), arme2016defaultWeight, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) + #armeHeightFromDiameterGslNlsDefault$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, arme2016defaultWeight, start = list(a1 = 53.2, a1p = -8.857, a2 = -0.002, a2p = 0.10, b1 = -0.016, b2 = -0.025, b3 = -0.078, b4 = 1.126)) + armeHeightFromDiameterGslNlsDefault$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), arme2016defaultWeight, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + #armeHeightFromDiameterGslNlsDefault$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), arme2016defaultWeight, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) + #armeHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), arme2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + #armeHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), arme2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + + armeHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + armeHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + armeHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # k reduces from 85 to 18 without aspect + armeHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + + save(file = "data/arme TotalHt.Rdata", armeHeightFromDiameter, armeHeightFromDiameterNlrob, armeHeightFromDiameterGslNlsDefault) +} +if (htDiaOptions$includeInvestigatory) +{ + print(armeHeightFromDiameterResults %>% select(-responseVariable, -species, -fixedWeight, -n, -power, -significant, -contains("NaturalRegen"), -contains("Plantation")), n = 30) + ggplot() + + geom_point(aes(x = arme2016$DBH, y = arme2016$TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$sharmaZhang), color = "Sharma-Zhang", group = arme2016$isPlantation), alpha = 0.5) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$sharmaParton), color = "Sharma-Parton", group = arme2016$isPlantation), alpha = 0.5) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$chapmanRichards), color = "Chapman-Richards", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$curtis), color = "Curtis", group = arme2016$isPlantation)) + + geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$gam), color = "GAM", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$korf), color = "Korf", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$linear), color = "linear", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$michaelisMenten), color = "Michaelis-Menten", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$parabolic), color = "parabolic", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$power), color = "power", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$prodan), color = "Prodan", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$ratkowsky), color = "Ratkowsky", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$richardsW), color = "unified Richards", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$sibbesen), color = "Sibbesen", group = arme2016$isPlantation)) + + #geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$weibull), color = "Weibull", group = arme2016$isPlantation)) + + annotate("text", x = 0, y = 65, label = "cascara buckthorn, height from diameter", hjust = 0, size = 3.5) + + coord_cartesian(ylim = c(0, 65)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + theme(legend.justification = c(1, 0), legend.position = c(1, 0.03)) + + # dbhClassSize = 50 + # errorByDbhClass = tibble(dbhClass = dbhClassSize*floor(arme2016$DBH/dbhClassSize) + 0.5*dbhClassSize, fittedValue = predict(armeHeightFromDiameter$gam, arme2016), height = arme2016$TotalHt, residual = fittedValue - height) %>% + # #mutate(residual = residual - if_else(dbhClass == 50, -0.477/376, 0.107/95)) %>% + # group_by(dbhClass) %>% + # summarize(n = n(), + # totalHeight = sum(height), + # totalFitted = sum(fittedValue), + # meanBiasPerTree = sum(residual) / n, + # meanBiasPerTreePct = 100 * sum(residual/height) / n, + # minError = min(residual), + # meanError = mean(residual), + # maxError = max(residual), + # minPct = 100 * min(residual/height), + # meanPct = 100 * mean(residual/height), + # maxPct = 100 * max(residual/height), + # .groups = "drop") %>% + # filter(n >= 10) + # errorByDbhClass +} + + +## cascara buckthorn height-diameter GNLS regressions +if (armeOptions$fitHeightGnls) +{ + armeHeightFromDiameterGnls = list(chapmanRichards = fit_gnls("Chapman-Richards GNLS", TotalHt ~ 1.37 + a1*(1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), control = gnlsControl(nlsTol = 0.001))) # step halving at nlsTol = 1 with corSymm + #armeHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, arme2016, start = armeHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + #armeHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016, start = armeHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + #armeHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = armeHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #armeHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), arme2016, start = armeHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation + #armeHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, arme2016, start = armeHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #armeHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), arme2016, start = armeHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped + #armeHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), arme2016, start = armeHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm + + save(file = "data/arme TotalHt gnls.Rdata", armeHeightFromDiameterGnls) +} +if (htDiaOptions$includeInvestigatory) +{ + armeHeightFromDiameterResultsGnls %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic) %>% arrange(method) + + #bind_cols(parameter = c("a1", "a2", "a3", "b1", "b2"), bal = confint2(armeHeightFromDiameter$weibullBAL, level = 0.99), balN = confint2(armeHeightFromDiameter$weibullBalNatural, level = 0.99), balP = confint2(armeHeightFromDiameter$weibullBalPlantation, level = 0.99)) %>% + # mutate(bal005 = bal[, 1], bal995 = bal[, 2], balN005 = balN[, 1], balN995 = balN[, 2], balP005 = balP[, 1], balP995 = balP[, 2]) %>% + # select(-bal, -balN, -balP) + ggplot() + + geom_point(aes(x = arme2016natural$DBH, y = arme2016natural$TotalHt), alpha = 0.15, color = "navyblue", na.rm = TRUE, shape = 16) + + geom_smooth(aes(x = arme2016natural$DBH, y = arme2016natural$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "natural regeneration DBH, cm", y = "cascara buckthorn naturally regenerated height, m") + + ggplot() + + geom_point(aes(x = arme2016plantation$DBH, y = arme2016plantation$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + + geom_smooth(aes(x = arme2016plantation$DBH, y = arme2016plantation$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "plantation DBH, cm", y = "cascara buckthorn plantation height, m") + + ggplot() + + geom_point(aes(x = arme2016$DBH, y = arme2016$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + + geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$weibullBal), color = "Weibull BA+L"), alpha = 0.5) + # Temesgen et al. 2007, Eq. 5 + geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$power), color = "power")) + + geom_line(aes(x = arme2016$DBH, y = predict(armeHeightFromDiameter$weibull), color = "Weibull")) + + annotate("text", x = 0, y = 85, label = "a) cascara buckthorn, height from diameter", hjust = 0, size = 3.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + scale_color_manual(breaks = c("base", "ElliottWeibull", "ElliottBAL", "ElliottBALn", "ElliottBALp", "TemesgenWeibull"), labels = c(bquote("1.37 + b"[0]*"DBH"^{b[1]}), "Weibull", "Weibull with BA+L", "Weibull with BA+L, natural regeneration", "Weibull with BA+L, plantation", "Weibull, Temesgen et al. 2007"), values = c("#ac92eb", "#4dc1e8", "#a0d568", "#ffce54", "#ed5564", "grey65")) + + scale_y_continuous(breaks = seq(0, 100, by = 20)) + + theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) +} + + +if (armeOptions$fitHeightMixed){ #fitting height diameter using mixed effect models + armeHeightFromDiameterMixed = list(chapmanRichards = fit_nlme("Chapman-Richards", TotalHt ~ 1.37 + (a1 + a1r)*(1 - exp(b1*DBH))^b2, arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 48.2, b1 = -0.015, b2 = 1.131)), control = nlmeControl(maxIter = 250))) + armeHeightFromDiameterMixed$chapmanRichardsBal = fit_nlme("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, arme2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)), control = nlmeControl(maxIter = 500)) + armeHeightFromDiameterMixed$chapmanRichardsBalPhysio = fit_nlme("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, arme2016, + fixedFormula = a1 + a1p + a2 + a2p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12)), control = nlmeControl(maxIter = 250), significant = FALSE) + armeHeightFromDiameterMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, arme2016, + fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15))) + # armeHeightFromDiameterMixed$curtis = fit_nlme("Curtis", TotalHt ~ 1.37 + (a1 + a1r) * DBH / (1 + DBH)^b1, arme2016, + # fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 0.560, b1 = 0.069)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # max iterations in job + armeHeightFromDiameterMixed$hossfeld = fit_nlme("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) / (1 + (b1 + b1p * isPlantation) *DBH^b2), arme2016, + fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)), control = nlmeControl(maxIter = 250)) + armeHeightFromDiameterMixed$korf = fit_nlme("Korf", TotalHt ~ 1.37 + (a1 + a1r)*exp(b1*DBH^b2), arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1825, b1 = -8.726, b2 = -0.175)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations + armeHeightFromDiameterMixed$michaelisMenten = fit_nlme("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), arme2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)), control = nlmeControl(maxIter = 250)) # job >100 iterations + armeHeightFromDiameterMixed$prodan = fit_nlme("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3 + a3r), arme2016, + fixedFormula = a1 + a1p + a2 + a3 ~ 1, randomFormula = a3r ~ 1, + start = list(fixed = c(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649))) + armeHeightFromDiameterMixed$power = fit_nlme("power", TotalHt ~ 1.37 + (a1 + a1r)*DBH^b1, arme2016, + fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 0.542, b1 = 0.939)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) # job >500 iterations without relaxed tolerances + #armeHeightFromDiameterMixed$ratkowsky = fit_nlme("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), arme2016, + # fixedFormula = a1 + a1p + b1 + b1p + b2 + b2p ~ 1, randomFormula = a1r ~ 1, + #start = list(fixed = c(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151))) + #armeHeightFromDiameterMixed$richardsW = fit_nlme("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation + Har) * (1 + ((1.37/(Ha + Hap*isPlantation + Har))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), arme2016, + #fixedFormula = Ha + Hap + d + kU + kUp ~ 1, randomFormula = Har ~ 1, + #start = list(fixed = c(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008))) + armeHeightFromDiameterMixed$sharmaParton = fit_nlme("Sharma-Parton", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, arme2016, + fixedFormula = a1 + b1 + b1p + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + armeHeightFromDiameterMixed$sharmaPartonBal = fit_nlme("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, + fixedFormula = a1 + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve, step halving + armeHeightFromDiameterMixed$sharmaPartonBalPhysio = fit_nlme("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, + fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + armeHeightFromDiameterMixed$sharmaPartonPhysio = fit_nlme("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016, + fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 1E-3)) # singular precision matrix, step halving + armeHeightFromDiameterMixed$sharmaZhang = fit_nlme("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), arme2016, + fixedFormula = a1 + a1p + b1 + b2 + b3 + b4 + b4p ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + armeHeightFromDiameterMixed$sharmaZhangBal = fit_nlme("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, arme2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + #armeHeightFromDiameterMixed$sibbesen = fit_nlme("Sibbesen", TotalHt ~ 1.37 + a1*DBH^((b1 + b1r)*DBH^b2), arme2016, + # fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = b1r ~ 1, + # start = list(fixed = c(a1 = 0.302, b1 = 1.495, b2 = -0.078))) # a1r: step halving, singular precision + armeHeightFromDiameterMixed$weibull = fit_nlme("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), arme2016, + fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141))) + armeHeightFromDiameterMixed$weibullBal = fit_nlme("Weibull BA+L", TotalHt ~ 1.37 + (a1 + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), arme2016, + fixedFormula = a1 + a2 + a2p + a3 + a3p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131))) + + armeHeightFromDiameterMixed$gamm = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8) + s(StandID, bs = "re"), data = arme2016, mixed = TRUE) + armeHeightFromDiameterMixed$gammBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13) + s(StandID, bs = "re"), data = arme2016, mixed = TRUE) + + save(file = "data/arme TotalHt mixed.Rdata", armeHeightFromDiameterMixed) +} + + +## Cascara buckthorn diameter-height regressions +if (armeOptions$fitDbh) { + armeDiameterFromHeight = list(linear = fit_lm("linear", DBH ~ 0 + I(TotalHt - 1.37), arme2016)) # isPlantation*(TotalHt - 1.37) not significant + armeDiameterFromHeight$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), arme2016) # (TotalHt - 1.37)^2 not significant + + armeDiameterFromHeight$chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, arme2016, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 500, xtol = 1E-5)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: singular gradient with nls(), no convergence from nls_multstart(), NaN-inf with nlrob() + #armeDiameterFromHeight$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, arme2016, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # NaN-inf with nls() and nlrob + armeDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() + armeDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 + armeDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() + armeDiameterFromHeight$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) # a1p and b2p not significant, poor convergence with b1p, step factor with nlrob() + armeDiameterFromHeight$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # a1p, b1p not significant, step factor with nlrob() + armeDiameterFromHeight$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), arme2016, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) # no physiographic effects significant, a1-b1 parameter evaporation: step factor with nlrob() + armeDiameterFromHeight$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) # step factor with nlrob() + armeDiameterFromHeight$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), arme2016, start = list(a1 = 519, a2 = 237, b1 = 1.00)) # a1p, a2p, b1p not significant, singular gradient with nlrob() + #armeDiameterFromHeight$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), arme2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) + armeDiameterFromHeight$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.93, b1 = 1.08)) # no significant plantation effects + armeDiameterFromHeight$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) # no significant plantation effects + armeDiameterFromHeight$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) # no significant physiographic effects + armeDiameterFromHeight$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) # a1p and b1p not significant + armeDiameterFromHeight$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) # a1p, b1p, b2p not significant + #armeDiameterFromHeight$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) # a2, a2p, a3, a3p, b1p, b2p not significant + armeDiameterFromHeight$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.9, a2 = -0.005, a4 = -0.001, b1 = 0.93, b2 = 0.006), significant = FALSE) # a2, a3 not significant, no AIC discrimination + armeDiameterFromHeight$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = -1, b1 = 0.9, b2 = 0), significant = FALSE) # a2, a3, a4, a9, b2 not significant, drop ABA on AIC + #armeDiameterFromHeight$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.7, a3 = 0, a9 = 0, b1 = 0.95, b2 = 0.005), significant = FALSE) # a9, a9p, b2 not significant + armeDiameterFromHeight$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) # a1p, a5, a6, a7, a8, b1p, b2p not significant + armeDiameterFromHeight$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) # a9, a9p, b1p, b2, b2p not significant + armeDiameterFromHeight$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 3.2, a4 = 0, a9 = -1, b1 = 0.9, b2 = 0.01), significant = FALSE) # a4, a9 not significant + #armeDiameterFromHeight$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), arme2016, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) # singular gradient with nlrob() and gsl_nls() + #armeDiameterFromHeight$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, arme2016, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) # a1-b2 evaporation, b1, b3 not significant, NaN-inf with nls() from nls_multstart() point, NaN-inf, singular gradient, or code syntax error with nlrob() + armeDiameterFromHeight$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) # no significant plantation effects + armeDiameterFromHeight$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029), significant = FALSE) # no significant plantation effects + armeDiameterFromHeight$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) # a2, a3, a8 not significant, drop ABA on AIC + armeDiameterFromHeight$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.017, a9 = 1.0, b1 = 0.7, b2 = 0), significant = FALSE) # a2, a3, a8, a9, b2 not significant, no a2-a3 AIC discrimination + armeDiameterFromHeight$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.5, a2 = 0, a9 = 0, a9p = 0, b1 = 0.6, b2 = 0.12), significant = FALSE) # a2, a9, a9p, b2 not significant + armeDiameterFromHeight$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) # a1p, no physiographic effects significant + armeDiameterFromHeight$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + armeDiameterFromHeight$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.6, a8 = -0.01, a9 = 0.7, b1 = 0.7, b2 = 0.1), significant = FALSE) # a9 not significant + #armeDiameterFromHeight$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, arme2016, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: NaN-inf with nlrob() + lapply(armeDiameterFromHeight$chapmanReplaceAbat$fit, confint2, level = 0.99) + lapply(armeDiameterFromHeight$chapmanReplaceAbat$fit, get_model_coefficients) + + if (armeOptions$fitDbhNlrob) + { + armeDiameterFromHeightNlrob = list(naslund = fit_nlrob("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), arme2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) + #armeDiameterFromHeightNlrob$power = fit_nlrob("power", DBH ~ a1*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.93, b1 = 1.08)) + #armeDiameterFromHeightNlrob$powerAbat = fit_nlrob("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + #armeDiameterFromHeightNlrob$powerPhysio = fit_nlrob("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + #armeDiameterFromHeightNlrob$powerRelHt = fit_nlrob("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + armeDiameterFromHeightNlrob$ruark = fit_nlrob("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) + armeDiameterFromHeightNlrob$ruarkAbat = fit_nlrob("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # occasional job step factor + armeDiameterFromHeightNlrob$ruarkAbatPhysio = fit_nlrob("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.9, a2 = 0, a4 = -0.001, b1 = 0.93, b2 = 0.006), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # step factor + armeDiameterFromHeightNlrob$ruarkAbatPhysioRelHt = fit_nlrob("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = 2.3, b1 = 0.9, b2 = 0), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + armeDiameterFromHeightNlrob$ruarkAbatRelHt = fit_nlrob("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.4, a3 = 0, a9 = 3, b1 = 0.8, b2 = 0.01), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor + armeDiameterFromHeightNlrob$ruarkPhysio = fit_nlrob("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + armeDiameterFromHeightNlrob$ruarkRelHt = fit_nlrob("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) + armeDiameterFromHeightNlrob$ruarkRelHtPhysio = fit_nlrob("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, start = list(a1 = 3.2, a4 = -0.001, a9 = 1, b1 = 0.8, b2 = 0), significant = FALSE) # a4, a9, b2 not significant + armeDiameterFromHeightNlrob$sibbesenReplace = fit_nlrob("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) + armeDiameterFromHeightNlrob$sibbesenReplaceAbat = fit_nlrob("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.1, a2 = -0.004, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4)) # job step factor + armeDiameterFromHeightNlrob$sibbesenReplaceAbatPhysio = fit_nlrob("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) + armeDiameterFromHeightNlrob$sibbesenReplaceAbatPhysioRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.01, a9 = 0.5, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor + armeDiameterFromHeightNlrob$sibbesenReplaceAbatRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.1, a2 = 0, a9 = 0, a9p = 0.7, b1 = 0.6, b2 = 0.12), significant = FALSE) + armeDiameterFromHeightNlrob$sibbesenReplacePhysio = fit_nlrob("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + armeDiameterFromHeightNlrob$sibbesenReplaceRelHt = fit_nlrob("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + armeDiameterFromHeightNlrob$weibull = fit_nlrob("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, arme2016, start = list(a1 = -250, b1 = 0.043, b2 = 0.58), control = nls.control(maxiter = 500)) + confint_nlrob(armeDiameterFromHeight$sibbesenReplacePhysio, level = 0.99, weights = pmin(arme2016$TotalHt^if_else(arme2016$isPlantation, -1.7, -1.6), 0.5)) + } else { + armeDiameterFromHeightNlrob = list() + } + armeDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, arme2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) + armeDiameterFromHeightGslNlsDefault$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, arme2016defaultWeight, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) + armeDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) + armeDiameterFromHeightGslNlsDefault$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016defaultWeight, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), arme2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) + armeDiameterFromHeightGslNlsDefault$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016defaultWeight, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), arme2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) + armeDiameterFromHeightGslNlsDefault$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), arme2016defaultWeight, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) + armeDiameterFromHeightGslNlsDefault$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, arme2016defaultWeight, start = list(a1 = 1.93, b1 = 1.08)) + armeDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, arme2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + armeDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, arme2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, arme2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + armeDiameterFromHeightGslNlsDefault$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeight, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) + armeDiameterFromHeightGslNlsDefault$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeight, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeightPhysio, start = list(a1 = 1.6, a2 = -0.01, a4 = -0.0006, b1 = 1.2, b2 = -0.009), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeightPhysio, start = list(a1 = 1.6, a3 = -0.003, a4 = -0.0006, a9 = 0.4, b1 = 1.27, b2 = -0.01), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeight, start = list(a1 = 1.3, a3 = -0.003, a9 = 0.25, b1 = 1.3, b2 = -0.008), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeight, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant + #armeDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), arme2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) + #armeDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, arme2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) + armeDiameterFromHeightGslNlsDefault$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeight, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) + armeDiameterFromHeightGslNlsDefault$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeight, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)) + armeDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeightPhysio, start = list(a1 = 1.5, a2 = -0.009, a8 = -0.005, b1 = 1.2, b2 = -0.04), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeightPhysio, start = list(a1 = 1.41, a2 = -0.009, a8 = -0.005, a9 = 0, b1 = 1.4, b2 = -0.05), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeight, start = list(a1 = 1.5, a2 = -0.008, a9 = 0, a9p = 0, b1 = 1.4, b2 = 0), significant = FALSE) + #armeDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + armeDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeight, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + #armeDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant + #armeDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, arme2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) + + # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined + armeDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # newton() step failure with scat() + armeDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # drop ABA and elevation on AIC + armeDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # drop elevation and topographic shelter on AIC + armeDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) + armeDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint) # drop elevation and aspect on AIC + + save(file = "data/arme DBH.Rdata", armeDiameterFromHeight, armeDiameterFromHeightNlrob, armeDiameterFromHeightGslNlsDefault) +} +if (htDiaOptions$includeInvestigatory) { + print(armeDiameterFromHeightResults %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic), n = 25) + + ggplot(arme2016) + + geom_point(aes(x = DBH, y = TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + #geom_line(aes(x = predict(armeDiameterFromHeight$sharmaParton), y = TotalHt, color = "modified Sharma-Parton", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(armeDiameterFromHeight$chapmanReplace), y = TotalHt, color = "Chapman-Richards replace", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$chapmanReplaceAbat), y = TotalHt, color = "Chapman-Richards replace approximate BA+L", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(armeDiameterFromHeight$chapmanReplaceBal), y = TotalHt, color = "Chapman-Richards replace BA+L", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(armeDiameterFromHeight$chapmanRichards), y = TotalHt, color = "Chapman-Richards", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$michaelisMentenReplace), y = TotalHt, color = "Michaelis-Menten replace", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$naslund), y = TotalHt, color = "Näslund", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$power), y = TotalHt, color = "power", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$ruark), y = TotalHt, color = "Ruark", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$schnute), y = TotalHt, color = "Schnute inverse", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$sibbesenReplace), y = TotalHt, color = "Sibbesen replace", group = isPlantation)) + + #geom_line(aes(x = predict(armeDiameterFromHeight$weibull), y = TotalHt, color = "Weibull", group = isPlantation)) + + #geom_line(aes(x = 5*standBasalAreaPerHectare^0.5 * exp(0.0005*tph^0.5*(TotalHt - 1.37))^1, y = TotalHt, color = "Sharma-Zhang"), alpha = 0.5) + + #geom_line(aes(x = -100 * log(1 - pmin(0.015*(TotalHt - 1.37)^1.0, 0.999)), y = TotalHt, color = "Chapman-Richards inversion"), na.rm = TRUE) + + #geom_line(aes(x = 0.5*(TotalHt - 1.37)^1*exp(0.02*(tph/topHeight)^0.26*(TotalHt - 1.37))^0.9, y = TotalHt, color = "modified Sharma-Parton", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 15 * (exp(0.1*(TotalHt - 1.37)) - 1)^0.45, y = TotalHt, color = "Chapman-Richards replace", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 15 * (exp(0.1*(TotalHt - 1.37)) - 1)^0.35, y = TotalHt, color = "Chapman-Richards replace", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = (1.75 + 0.000001 * tallerApproxBasalArea + -0.000001 * standBasalAreaApprox) * exp(1.46*(TotalHt - 1.37)^0.280), y = TotalHt, color = "Chapman-Richards replace ABA+T", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 0.03*topHeight*exp(1.6*(TotalHt - 1.37)^0.26), y = TotalHt, color = "Chapman-Richards replace top height", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = -1/0.0003*log(1 - (1 - exp(-0.1))*(TotalHt^1.5 - 1.37^1.5)/(75^1.5 - 1.37^1.5)), y = TotalHt, color = "Schnute inverse"), alpha = 0.5) + + geom_line(aes(x = 30*topHeight^0.5*(exp(0.01 * (tph/standBasalAreaPerHectare)^0.25*(TotalHt - 1.37)) - 1)^0.5, y = TotalHt, color = "modified Sharma-Parton"), alpha = 0.5) + + annotate("text", x = 0, y = 62, label = "cascara buckthorn, diameter from height", hjust = 0, size = 3.5) + + #coord_cartesian(xlim = c(0, 250), ylim = c(0, 90)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + #scale_color_manual(breaks = c(FALSE, TRUE, "Chapman-Richards"), values = c("grey25", "transparent", "red")) + + #scale_color_manual(breaks = c(FALSE, TRUE, "Chapman-Richards"), values = c("transparent", "grey25", "red")) + + scale_y_continuous(breaks = seq(0, 100, by = 20)) + + theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) +} + +if (armeOptions$fitDbhMixed) { + armeDiameterFromHeightMixed = list(chapmanReplace = fit_nlme("Chapman-Richards replace", DBH ~ (a1 + a1r)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 200, b1 = 0.01, b2 = 0.95)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001))) # singularity in backsolve, max iterations + armeDiameterFromHeightMixed$chapmanReplaceAbat = fit_nlme("Chapman-Richards replace ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, arme2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # singularity in backsolve + #armeDiameterFromHeightMixed$chapmanReplaceBal = fit_nlme("Chapman-Richards replace BA+L", DBH ~ (a1 + a1r + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, + # fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 300, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving + #armeDiameterFromHeightMixed$chapmanReplaceBalRelHt = fit_nlme("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a1r + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, + # fixedFormula = a1 + a2 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 250, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # singularity in backsolve + #armeDiameterFromHeightMixed$chapmanReplaceRelHt = fit_nlme("Chapman-Richards replace RelHt", DBH ~ (a1 + a1r + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # step halving + armeDiameterFromHeightMixed$chapmanRichards = fit_nlme("Chapman-Richards inverse", DBH ~ (a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations + armeDiameterFromHeightMixed$chapmanRichardsAbat = fit_nlme("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations, step halving + #armeDiameterFromHeightMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards inverse physio", DBH ~ (a1 + a1r + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), arme2016, + # fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations, step halving + armeDiameterFromHeightMixed$chapmanRichardsRelHt = fit_nlme("Chapman-Richards inverse RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), arme2016, + fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving, singularity in backsolve + armeDiameterFromHeightMixed$michaelisMentenReplace = fit_nlme("Michaelis-Menten replace", DBH ~ (a1 + a1r) * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), arme2016, + fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 519, a2 = 237, b1 = 1.00)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations, step halving + armeDiameterFromHeightMixed$naslund = fit_nlme("Näslund inverse", DBH ~ (a1 + a1r + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), arme2016, + fixedFormula = a1 + a1p + a2 + a2p ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) + armeDiameterFromHeightMixed$power = fit_nlme("power", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1, arme2016, + fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1.93, b1 = 1.08)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # job max iterations + #armeDiameterFromHeightMixed$powerAbat = fit_nlme("power ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, arme2016, + # fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 1.94, a2 = -0.00051, b1 = 1.09))) + #armeDiameterFromHeightMixed$powerPhysio = fit_nlme("power physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, arme2016, + # fixedFormula = a1 + a8 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 2.26, a8 = -0.0060, b1 = 1.08)), significant = FALSE) + #armeDiameterFromHeightMixed$powerRelHt = fit_nlme("power RelHt", DBH ~ (a1 + a1r + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, arme2016, + # fixedFormula = a1 + a9 + a9p + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13))) + armeDiameterFromHeightMixed$ruark = fit_nlme("Ruark", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.8, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations + armeDiameterFromHeightMixed$ruarkAbat = fit_nlme("Ruark ABA+T", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + fixedFormula = a1 + a3 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # job max iterations + armeDiameterFromHeightMixed$ruarkAbatPhysio = fit_nlme("Ruark ABA+T physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + fixedFormula = a1 + a2 + a4 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.9, a2 = -0.005, a4 = -0.001, b1 = 0.93, b2 = 0.006)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # job max iterations + #armeDiameterFromHeightMixed$ruarkAbatPhysioRelHt = fit_nlme("Ruark ABA+T RelHt physio", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + # fixedFormula = a1 + a3 + a4 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = -1, b1 = 0.9, b2 = 0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations + armeDiameterFromHeightMixed$ruarkAbatRelHt = fit_nlme("Ruark ABA+T RelHt", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + fixedFormula = a1 + a3 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.7, a3 = 0, a9 = 0, b1 = 0.95, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + armeDiameterFromHeightMixed$ruarkPhysio = fit_nlme("Ruark physio", DBH ~ (a1 + a1r + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + fixedFormula = a1 + a4 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + #armeDiameterFromHeightMixed$ruarkRelHt = fit_nlme("Ruark RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + armeDiameterFromHeightMixed$ruarkRelHtPhysio = fit_nlme("Ruark RelHt physio", DBH ~ (a1 + a1r + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), arme2016, + fixedFormula = a1 + a4 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.2, a4 = 0, a9 = -1, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations, false convergence + #armeDiameterFromHeightMixed$schnute = fit_nlme("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/((Ha + Har)^b1 - 1.3^b1)), arme2016, + # fixedFormula = a1 + a2 + b1 + Ha ~ 1, randomFormula = Har ~ 1, + # start = list(fixed = c(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30)), control = nlmeControl(maxIter = 100, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # step halving + #armeDiameterFromHeightMixed$sharmaParton = fit_nlme("modified Sharma-Parton", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, arme2016, + # fixedFormula = a1 + b1 + b2 + b4 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1)), control = nlmeControl(maxIter = 250, tolerance = 0.1, pnlsTol = 1, msTol = 0.01)) # singularity in backsolve + armeDiameterFromHeightMixed$sibbesenReplace = fit_nlme("Sibbesen replace", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.4, b1 = 0.8, b2 = 0.12)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations + armeDiameterFromHeightMixed$sibbesenReplaceAbat = fit_nlme("Sibbesen replace ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) + armeDiameterFromHeightMixed$sibbesenReplaceAbatPhysio = fit_nlme("Sibbesen replace ABA+T physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + a2 + a8 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + #armeDiameterFromHeightMixed$sibbesenReplaceAbatPhysioRelHt = fit_nlme("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + # fixedFormula = a1 + a2 + a8 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 3.3, a2 = 0, a8 = -0.017, a9 = 1.0, b1 = 0.7, b2 = 0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations + armeDiameterFromHeightMixed$sibbesenReplaceAbatRelHt = fit_nlme("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + a2 + a9 + a9p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.5, a2 = 0, a9 = 0, a9p = 0, b1 = 0.6, b2 = 0.12)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5), significant = FALSE) # singular precision matrix + armeDiameterFromHeightMixed$sibbesenReplacePhysio = fit_nlme("Sibbesen replace physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + a8 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1)), control = nlmeControl(maxIter = 500), significant = FALSE) + armeDiameterFromHeightMixed$sibbesenReplaceRelHt = fit_nlme("Sibbesen replace RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + armeDiameterFromHeightMixed$sibbesenReplaceRelHtPhysio = fit_nlme("Sibbesen replace RelHt physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), arme2016, + fixedFormula = a1 + a8 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.0, a8 = -0.01, a9 = 0, b1 = 0.73, b2 = 0.07)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + armeDiameterFromHeightMixed$weibull = fit_nlme("Weibull inverse", DBH ~ ((a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, arme2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -300, b1 = 0.04, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + + armeDiameterFromHeightMixed$gamm = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = arme2016, mixed = TRUE) + armeDiameterFromHeightMixed$gammAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16) + s(StandID, bs = "re"), data = arme2016, mixed = TRUE) + armeDiameterFromHeightMixed$gammRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = arme2016, mixed = TRUE) + + save(file = "data/arme DBH mixed.Rdata", armeDiameterFromHeightMixed) +} + + +# ## collect model results and parameters +# if (armeOptions$fitHeight & armeOptions$fitHeightMixed & armeOptions$fitDbh & armeOptions$fitDbhMixed) { +# if (exists("armeHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/arme TotalHt.Rdata") } +# #if (exists("armeHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/arme TotalHt gnls.Rdata") } +# if (exists("armeHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/arme TotalHt mixed.Rdata") } +# if (exists("armeDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/arme DBH.Rdata") } +# if (exists("armeDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/arme DBH mixed.Rdata") } + +## collect model results and parameters +if (armeOptions$fitHeight & armeOptions$fitHeightMixed & armeOptions$fitDbh & armeOptions$fitDbhMixed) { + if (exists("armeHeightFromDiameter") == FALSE) { load("data/arme TotalHt.Rdata") } + #if (exists("armeHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/arme TotalHt gnls.Rdata") } + if (exists("armeHeightFromDiameterMixed") == FALSE) { load("data/arme TotalHt mixed.Rdata") } + if (exists("armeDiameterFromHeight") == FALSE) { load("data/arme DBH.Rdata") } + if (exists("armeDiameterFromHeightMixed") == FALSE) { load("data/arme DBH mixed.Rdata") } + armeCoefficients = bind_rows(bind_rows(bind_rows(lapply(armeHeightFromDiameter, get_list_coefficients)), + #bind_rows(lapply(armeHeightFromDiameterGnls, get_model_coefficients)), + bind_rows(lapply(armeHeightFromDiameterGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(armeHeightFromDiameterMixed, get_list_coefficients, fitSet = "mixed")), + bind_rows(lapply(armeHeightFromDiameterNlrob, get_list_coefficients, fitSet = "nlrob"))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(armeDiameterFromHeight, get_list_coefficients)), + bind_rows(lapply(armeDiameterFromHeightGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(armeDiameterFromHeightMixed, get_list_coefficients, fitSet = "mixed")), + bind_rows(lapply(armeDiameterFromHeightNlrob, get_list_coefficients, fitSet = "nlrob"))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "arme") + armeResults = bind_rows(bind_rows(bind_rows(lapply(armeHeightFromDiameter, get_list_stats)), + #bind_rows(lapply(armeHeightFromDiameterGnls, get_stats)), + bind_rows(lapply(armeHeightFromDiameterGslNlsDefault, get_list_stats, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(armeHeightFromDiameterMixed, get_list_stats, fitSet = "mixed")), + bind_rows(lapply(armeHeightFromDiameterNlrob, get_list_stats, fitSet = "nlrob"))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(armeDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitSet = "primary", fittingMethod = "gsl_nls"), + bind_rows(lapply(armeDiameterFromHeightGslNlsDefault, get_list_stats, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(armeDiameterFromHeightMixed, get_list_stats, fitSet = "mixed")), + bind_rows(lapply(armeDiameterFromHeightNlrob, get_list_stats, fitSet = "nlrob"))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "arme") + + check_plot_results(armeResults) + save(file = "data/arme results.Rdata", armeCoefficients, armeResults) +} else if (armeOptions$fitHeight & armeOptions$fitHeightMixed & armeOptions$fitDbh & armeOptions$fitDbhMixed) +{ + if (exists("armeHeightFromDiameter") == FALSE) { load("data/arme TotalHt.Rdata") } + if (exists("armeDiameterFromHeight") == FALSE) { load("data/arme DBH.Rdata") } + + armeCoefficients = bind_rows(bind_rows(bind_rows(lapply(armeHeightFromDiameter, get_list_coefficients))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(armeDiameterFromHeight, get_list_coefficients))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "arme") + armeResults = bind_rows(bind_rows(bind_rows(lapply(armeHeightFromDiameter, get_list_stats))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(armeDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitting = "gsl_nls", fitSet = "primary")) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "arme") + + check_plot_results(armeResults) + save(file = "data/arme results.Rdata", armeCoefficients, armeResults) +}else(armeOptions$fitHeight &armeOptions$fitDbh) #added for height and diameter fit only. +{ + if (exists("armeHeightFromDiameter") == FALSE) { load("data/arme TotalHt.Rdata") } + if (exists("armeDiameterFromHeight") == FALSE) { load("data/arme DBH.Rdata") } + + armeCoefficients = bind_rows(bind_rows(bind_rows(lapply(armeHeightFromDiameter, get_list_coefficients))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(armeDiameterFromHeight, get_list_coefficients))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "arme") + armeResults = bind_rows(bind_rows(bind_rows(lapply(armeHeightFromDiameter, get_list_stats))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(armeDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitting = "gsl_nls", fitSet = "primary")) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "arme") + + check_plot_results(armeResults) + save(file = "data/arme results.Rdata", armeCoefficients, armeResults) +} + +## preferred forms identified (results.R, Figure 8) +if (armeOptions$fitHeight & armeOptions$fitDbh) +{ + armeHeightFromDiameterPreferred = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, arme2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), folds = 1, repetitions = 1)) + armeHeightFromDiameterPreferred$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + #armeHeightFromDiameterPreferred$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + armeHeightFromDiameterPreferred$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), arme2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176), folds = 1, repetitions = 1) + armeHeightFromDiameterPreferred$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), arme2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176), folds = 1, repetitions = 1) + armeHeightFromDiameterPreferred$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), arme2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649), folds = 1, repetitions = 1) + #armeHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) + #armeHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, arme2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) + #armeHeightFromDiameterPreferred$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, arme2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09), folds = 1, repetitions = 1) + armeHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), arme2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) + AIC(armeHeightFromDiameterPreferred$hossfeld, armeHeightFromDiameterPreferred$michaelisMenten, armeHeightFromDiameterPreferred$prodan, armeHeightFromDiameterPreferred$ratkowsky) + + armeDiameterFromHeightPreferred = list(gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1)) + #armeDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), arme2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) + armeDiameterFromHeightPreferred$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), arme2016, folds = 1, repetitions = 1) + armeDiameterFromHeightPreferred$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, arme2016, start = list(a1 = 1.93, b1 = 1.08), folds = 1, repetitions = 1) + #armeDiameterFromHeightPreferred$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + #armeDiameterFromHeightPreferred$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + #armeDiameterFromHeightPreferred$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + armeDiameterFromHeightPreferred$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + + save(file = "data/arme preferred models.Rdata", armeHeightFromDiameterPreferred, armeDiameterFromHeightPreferred) +} + + +## basal area from height +if (htDiaOptions$includeInvestigatory) +{ + armeBasalAreaFromHeightKorf = gsl_nls(basalArea ~ a1*(exp(b1*(imputedHeight - 1.37)^b2) - 1), arme2016, start = list(a1 = 90, b1 = 0.000003, b2 = 2.18), weights = heightWeight^2) # a1p, b1p, b2p not significant + armeBasalAreaFromHeightPower = gsl_nls(basalArea ~ a1*(imputedHeight - 1.37)^(b1 + b1p * isPlantation), arme2016, start = list(a1 = 3/7 * 0.25 * pi * 0.01^2, b1 = 2.14, b1p = 0.34), weights = heightWeight^2) # a1p not significant + #confint2(armeBasalAreaFromHeightPower, level = 0.99) + + tribble(~method, ~aic, ~biasCm2, ~maeM2, ~nse, + "Korf", AIC(armeBasalAreaFromHeightKorf), 100^2 * mean(residuals(armeBasalAreaFromHeightKorf)), mean(abs(residuals(armeBasalAreaFromHeightKorf))), 1 - sum(residuals(armeBasalAreaFromHeightKorf)^2) / sum((arme2016$basalArea - mean(arme2016$basalArea)^2)), + "power", AIC(armeBasalAreaFromHeightPower), 100^2 * mean(residuals(armeBasalAreaFromHeightPower)), mean(abs(residuals(armeBasalAreaFromHeightPower))), 1 - sum(residuals(armeBasalAreaFromHeightPower)^2) / sum((arme2016$basalArea - mean(arme2016$basalArea)^2))) %>% + mutate(deltaAIC = aic - min(aic)) %>% + arrange(desc(deltaAIC)) + + ggplot(arme2016) + + geom_point(aes(x = imputedHeight, y = 0.25*pi*(0.01*DBH)^2), alpha = 0.1, color = "grey25", shape = 16) + + geom_line(aes(x = imputedHeight, y = predict(armeBasalAreaFromHeightKorf), color = "Korf", group = isPlantation)) + + geom_line(aes(x = imputedHeight, y = predict(armeBasalAreaFromHeightPower), color = "power", group = isPlantation)) + + #geom_path(aes(x = imputedHeight, y = 10*(1 - exp(-0.1*(imputedHeight - 1.37)))^1.2, color = "Chapman-Richards")) + + labs(x = "cascara buckthorn height, m", y = "basal area, m²", color = NULL) + + theme(legend.justification = c(0, 1), legend.position = c(0.03, 0.99)) +} + + +## exploratory plots +if (htDiaOptions$includeInvestigatory) +{ + library(GGally) + ggpairs(arme2016 %>% mutate(regeneration = if_else(isPlantation, "plantation", "natural regen")) %>% select(TotalHt, DBH, standBasalAreaPerHectare, basalAreaLarger, relativeHeight, regeneration), + aes(alpha = 0.1, color = regeneration, shape = "16"), + columnLabels = c("DBH, cm", "height, m", "BA, m² ha⁻¹", "BAL, m² ha⁻¹", "relative height, %", "stand type"), + upper = list(continuous = wrap("cor", size = 3)), + lower = list(combo = wrap("facethist", bins = 30))) + + scale_color_discrete(type = c("forestgreen", "darkviolet")) + + #scale_color_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + # https://github.com/ggobi/ggally/issues/445 + scale_fill_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + + theme(strip.background = element_blank()) + ggpairs(arme2016 %>% mutate(regeneration = if_else(isPlantation, "plantation", "natural regen")) %>% select(TotalHt, DBH, slope, elevation, topographicShelterIndex, regeneration), + aes(alpha = 0.1, color = if_else(arme2016$isPlantation, "plantation", "natural regen"), shape = "16"), + columnLabels = c("DBH, cm", "height, m", "slope, °", "elevation, m", "TSI, °", "stand type"), + upper = list(continuous = wrap("cor", size = 3)), + lower = list(combo = wrap("facethist", bins = 30))) + + scale_color_discrete(type = c("forestgreen", "darkviolet")) + + scale_fill_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + + theme(strip.background = element_blank()) + scatterPlotMatrix::scatterPlotMatrix(arme2016 %>% select(TotalHt, DBH, standBasalAreaPerHectare, basalAreaLarger)) +} + + +## GAM smooth effects +if (htDiaOptions$includeInvestigatory) +{ + #armeInteraction = lm(TotalHt ~ DBH*standBasalAreaPerHectare + DBH:basalAreaLarger + standBasalAreaPerHectare:basalAreaLarger, arme2016) + #summary(armeInteraction) + #ggplot() + + # geom_point(aes(x = DBH, y = basalAreaLarger, color = armeInteraction$residuals), arme2016, shape = 16) + + # labs(x = "DBH, cm", y = bquote("BAL, m"^2*" ha"^-1), color = "height\nresidual, m") + + # scale_color_scico(palette = "bam", limits = c(-20, 20)) + armeHeightGam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint) + + #s(standBasalAreaPerHectare, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + #s(basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + s(topographicShelterIndex, bs = "ts", k = 5, pc = gamConstraint) + + s(relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint), + data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + #armeHeightGam = fit_gam("REML GAM", TotalHt ~ s(DBH, standBasalAreaPerHectare, bs = "ts", by = as.factor(isPlantation), k = 11, pc = gamConstraint) + + # #s(basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + # #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # s(topographicShelterIndex, bs = "ts", k = 5, pc = gamConstraint), + # #s(relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint), # not significant + # data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + k.check(armeHeightGam) + summary(armeHeightGam) + par(mfrow = c(2, 3), mar = c(2.2, 2.2, 0.5, 0) + 0.1, mgp = c(1.5, 0.4, 0)) + plot.gam(armeHeightGam, scale = 0, scheme = 2) + + armeDbhGam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), + #s(standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(tallerApproxBasalArea, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(topographicShelterIndex, bs = "ts", k = 3, pc = gamConstraint), # not significant + #s(relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint), # not significant + data = arme2016, constraint = arme2016gamConstraint, folds = 1, repetitions = 1) + k.check(armeDbhGam) + summary(armeDbhGam) + par(mfrow = c(1, 4), mar = c(2.2, 2.2, 0.5, 0) + 0.1, mgp = c(1.5, 0.4, 0)) + plot.gam(armeDbhGam, scale = 0) +} + + +## random forest regression +if (htDiaOptions$includeInvestigatory) +{ + library(caret) + library(ranger) + #armeForest = ranger(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger, arme2016, classification = TRUE, num.threads = 12) + repeatedCrossValidation = trainControl(method = "repeatedcv", number = htDiaOptions$folds, repeats = htDiaOptions$repetitions, verboseIter = FALSE) + armeHeightForest = train(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger + elevation + slope + aspect + topographicShelterIndex + relativeDiameter, data = arme2016, method = "ranger", trControl = repeatedCrossValidation, + importance = "impurity_corrected", + tuneGrid = expand.grid(mtry = c(6, 8), + splitrule = "variance", + min.node.size = c(1, 2))) + armeHeightForest + varImp(armeHeightForest) + + armeDbhForest = train(DBH ~ TotalHt + standBasalAreaApprox + tallerApproxBasalArea + elevation + slope + aspect + topographicShelterIndex + relativeHeight, data = arme2016, method = "ranger", trControl = repeatedCrossValidation, + importance = "impurity_corrected", + tuneGrid = expand.grid(mtry = c(7, 8), + splitrule = "variance", + min.node.size = c(2, 3, 4))) + armeDbhForest + varImp(armeDbhForest) +} + From 47e8bae9d4a420166a24143c7b3556cfb22432ab Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Wed, 11 Jun 2025 13:50:41 -0700 Subject: [PATCH 12/13] update pisi for public dataset --- trees/height-diameter/PISI.R | 813 +++++++++++++++++++++++++++++++++++ 1 file changed, 813 insertions(+) create mode 100644 trees/height-diameter/PISI.R diff --git a/trees/height-diameter/PISI.R b/trees/height-diameter/PISI.R new file mode 100644 index 0000000..0f65e36 --- /dev/null +++ b/trees/height-diameter/PISI.R @@ -0,0 +1,813 @@ +# load libraries, functions, and trees2016 from Elliott Stand Data Feb2022.R + + +## cascara buckthorn height-diameter regression form sweep + +#pisi HeightFromDiameter$gamPhysio = gam(TotalHt ~ s(DBH, elevation, slope, sin(3.14159/180 * aspect), cos(3.14159/180 * aspect), topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 85, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, select = TRUE, weights = dbhWeight) + +# bs= "ts" -> 367, gamma = 2 -> 367, k = 169 min vs 367 default, method = "REML" -> 367 + +#pisi HeightFromDiameter$sharmaPartonBalPhysio = gsl_nls(TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^(a2 + a2p * isPlantation) * (1 + a3 * elevation + a4 * sin(3.14159/180 * aspect) + a5 * cos(3.14159/180 * aspect) + a6 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^(b2 + b2p * isPlantation)*DBH))^(b3 + b3p * isPlantation), pisi2016, start = list(a1 = 39.8, a1p = -12.3, a2 = 0.52, a2p = 0.0027, a3 = 0.00001, a4 = 0.0131, a5 = 0.0046, a6 = 0.0060, b1 = -0.0098, b1p = -0.0143, b2 = 0.125, b2p = -0.186, b3 = 1.12, b3p = 0.0086), weights = pisiHeightFromDiameterWeights) + +pisi2016 = trees2016 %>% + filter(Species == "PISI", isLiveUnbroken, is.na(TotalHt) == FALSE,is.na(elevation)==FALSE) %>% # live cascara buckthorns measured for height + mutate(dbhWeight = pmin(TreeCount/(0.14*DBH^1.20), 5*TreeCount), + heightWeight = pmin(TreeCount/(2.29*(TotalHt - 1.37)^1.45), 5*TreeCount)) + +# no trees without physiographic variables +pisi2016gamConstraint = c(DBH = -1.2264/0.5099, TotalHt = 1.37, standBasalAreaPerHectare = median(pisi2016$standBasalAreaPerHectare), basalAreaLarger = median(pisi2016$basalAreaLarger), standBasalAreaApprox = median(pisi2016$standBasalAreaApprox), tallerApproxBasalArea = median(pisi2016$tallerApproxBasalArea), elevation = median(pisi2016$elevation), slope = median(pisi2016$slope), aspect = median(pisi2016$aspect), topographicShelterIndex = median(pisi2016$topographicShelterIndex), relativeHeight = median(pisi2016$relativeHeight), relativeDiameter = median(pisi2016$relativeDiameter)) # point constraint for mgcv::s() + +pisi2016defaultWeight = pisi2016 %>% mutate(dbhWeight = pmin(TreeCount/DBH, 5*TreeCount), + heightWeight = pmin(TreeCount/TotalHt, 5*TreeCount)) +pisi2016defaultWeightPhysio = pisi2016defaultWeight %>% filter(is.na(elevation) == FALSE) + +# pisiOptions = tibble(fitHeight = TRUE, +# fitHeightNlrob = FALSE, +# fitHeightGnls = FALSE, +# fitHeightMixed = FALSE, +# fitDbh = TRUE, +# fitDbhNlrob = FALSE, +# fitDbhMixed = FALSE) + +#make a tibble to store the parameters and later call them into the code +pisiOptions = tibble(fitHeight = TRUE, #non-linear least square, height as response + fitHeightNlrob = FALSE, #robust non-linear least square, height as response + fitHeightGnls = TRUE, #generalized least square, height as response + fitHeightMixed = FALSE, #non-linear mixed effects, height as response + fitDbh = TRUE, #non-linear least square, dbh as response + fitDbhNlrob = FALSE, #robust non-linear least square, dbh as response + fitDbhMixed = FALSE, #non-linear mixed effects, dbh as response + includeInvestigatory = TRUE #added investigatory plots, and figures of the results +) + +if (pisiOptions$fitHeight) { #if the value in the column fitHeight of pisiOptions table is TRUE execute the expression within the curly braces. + pisiHeightFromDiameter = list(linear = fit_lm("linear", TotalHt ~ 0 + DBH, pisi2016)) # isPlantation*DBH not significant (p = 0.044) #creates output from the model fitting and validation 10*10=100 rows of all combination of folds and repetition and stores it as a list and adds all the following models in a similar fashion to the existing list (notice the $ sign in the code from the second line withing the curly braces) + pisiHeightFromDiameter$parabolic = fit_lm("parabolic", TotalHt ~ 0 + DBH + I(DBH^2), pisi2016) # isPlantation*DBH not quite significant (p = 0.106), isPlantation*DBH^2 not significant + + pisiHeightFromDiameter$chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131)) # a1p, b1p, b2p not significant + pisiHeightFromDiameter$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) # a3, a3p, b1p, b2p not significant + pisiHeightFromDiameter$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) # a2, a3, a4, a5, a6, a7, a8p, b2p not significant + pisiHeightFromDiameter$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016, start = list(a1 = 58, a1p = -16, a2 = 0, a2p = 0.4, a8 = 0.3, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) # a2, a10, a10p not significant + pisiHeightFromDiameter$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.3, b1 = -0.012, b2 = 1.1), significant = FALSE) # a2, a10, a10p not significant + pisiHeightFromDiameter$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), pisi2016, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) # a2, a3, a3p, b1p not significant, job step factor with nlrob() + pisiHeightFromDiameter$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) # a4, a5, a6, a7, a8p, b2p not significant + pisiHeightFromDiameter$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 72, a10 = -3.2, b1 = -0.012, b2 = 1.09)) # a10p not significant + pisiHeightFromDiameter$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) # a10, a10p not significant + pisiHeightFromDiameter$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, pisi2016, start = list(a1 = 0.560, b1 = 0.069)) # a1p, b1p not significant + pisiHeightFromDiameter$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), pisi2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) # b2p not significant + pisiHeightFromDiameter$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), pisi2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) # a1p, b1p, b2p not significant + pisiHeightFromDiameter$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), pisi2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) # b1p not significant + pisiHeightFromDiameter$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), pisi2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) # a2p, a3p not significant + pisiHeightFromDiameter$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, pisi2016, start = list(a1 = 0.542, b1 = 0.939)) # a1p, b1p not significant + pisiHeightFromDiameter$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), pisi2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + pisiHeightFromDiameter$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), pisi2016, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) # dp not significant, susceptible to NaN-inf + #pisiHeightFromDiameter$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)) # a1p, b3p, b4p not significant + pisiHeightFromDiameter$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)) # a1p, b1p, b2p, b3p, b4p not significant + pisiHeightFromDiameter$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) # b1, b1p, a4, a5, a6, a7, b3p, b4p not significant + #pisiHeightFromDiameter$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 25, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.008, b2p = -0.011, b3 = -0.01, b4 = 1.12), significant = FALSE) # a10, a10p not significant + pisiHeightFromDiameter$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 39, a10 = -1.7, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE) # a10, a10p not significant + pisiHeightFromDiameter$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)) # a4, a5, a5, a6, a7, b1p, b3p, b4p not significant + #pisiHeightFromDiameter$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016, start = list(a1 = 21, a10 = 0, b1 = 0.25, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = 0, b4 = 1.12), significant = FALSE) # a10, a10p not significant + pisiHeightFromDiameter$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016, start = list(a1 = 36, a8 = 0.18, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = -0.03, b4 = 1.09), significant = FALSE) # a1p, a10, a10p, b2p not significant + pisiHeightFromDiameter$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), pisi2016, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) # b1, b1p, b2p, b3p not significant + pisiHeightFromDiameter$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, pisi2016, start = list(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)) # a2, b1, b1p, b3, b3p, b4p not significant + pisiHeightFromDiameter$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), pisi2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) # a1p, b1p, b2p not significant + pisiHeightFromDiameter$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), pisi2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) # b2p not significant + pisiHeightFromDiameter$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), pisi2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) # a1p, a2, a3, b1p, b2p not significant + pisiHeightFromDiameter$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), pisi2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) # a1p, a2, a3, a3p, b1p, b2p not significant + + if (pisiOptions$fitHeightNlrob) + { + pisiHeightFromDiameterNlrob = list(chapmanRichards = fit_nlrob("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 5.2, b1 = -0.015, b2 = 1.131))) + #pisiHeightFromDiameterNlrob$chapmanRichardsBal = fit_nlrob("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + #pisiHeightFromDiameterNlrob$chapmanRichardsBalPhysio = fit_nlrob("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + #pisiHeightFromDiameterNlrob$chapmanRichardsBalPhysioRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016, start = list(a1 = 58, a1p = -14, a2 = -0.11, a2p = 0.5, a8 = 0.3, a10 = -1.8, b1 = -0.012, b1p = -0.003, b2 = 1.14), significant = FALSE) + #pisiHeightFromDiameterNlrob$chapmanRichardsBalRelDbh = fit_nlrob("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 61, a1p = -8, a2 = -0.13, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.12), significant = FALSE) + pisiHeightFromDiameterNlrob$chapmanRichardsBalRelHt = fit_nlrob("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), pisi2016, start = list(a1 = 0, a1p = 17, a2 = 0, a2p = 0.25, a3 = 0.02, a9 = 38, a9p = -28, b1 = -0.023, b2 = 0.4, b2p = 0.9), control = nls.control(tol = 0.01)) # job step factor + #pisiHeightFromDiameterNlrob$chapmanRichardsPhysio = fit_nlrob("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + pisiHeightFromDiameterNlrob$chapmanRichardsRelDbh = fit_nlrob("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 66, a10 = -3.2, b1 = -0.010, b2 = 1.09)) + #pisiHeightFromDiameterNlrob$chapmanRichardsRelDbhPhysio = fit_nlrob("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), control = nls.control(tol = 1E-4), significant = FALSE) + pisiHeightFromDiameterNlrob$curtis = fit_nlrob("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, pisi2016, start = list(a1 = 0.560, b1 = 0.069)) + pisiHeightFromDiameterNlrob$hossfeld = fit_nlrob("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), pisi2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + pisiHeightFromDiameterNlrob$korf = fit_nlrob("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), pisi2016, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + #pisiHeightFromDiameterNlrob$michaelisMenten = fit_nlrob("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), pisi2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + pisiHeightFromDiameterNlrob$prodan = fit_nlrob("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), pisi2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + pisiHeightFromDiameterNlrob$power = fit_nlrob("power", TotalHt ~ 1.37 + a1*DBH^b1, pisi2016, start = list(a1 = 0.542, b1 = 0.939)) + pisiHeightFromDiameterNlrob$ratkowsky = fit_nlrob("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), pisi2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + #pisiHeightFromDiameterNlrob$richardsW = fit_nlrob("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), pisi2016, start = list(Ha = 43, Hap = -10, d = 0.9, kU = 0.012, kUp = 0.004), control = nls.control(tol = 0.001)) # job step factor + #pisiHeightFromDiameterNlrob$sharmaParton = fit_nlrob("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09), control = nls.control(tol = 0.001)) # job step factor + pisiHeightFromDiameterNlrob$sharmaPartonBal = fit_nlrob("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 44, b1 = 0.07, b2 = -0.013, b3 = -0.10, b4 = 1.03), control = nls.control(maxiter = 100, tol = 0.001)) # job step factor + #pisiHeightFromDiameterNlrob$sharmaPartonBalPhysio = fit_nlrob("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), control = nls.control(tol = 1E-4)) # job step factor + #pisiHeightFromDiameterNlrob$sharmaPartonBalPhysioRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 25, a1p = -8, a8 = 0.13, a10 = -0.9, b1 = 0.18, b2 = -0.011, b2p = -0.010, b3 = 0, b4 = 1.13), control = nls.control(tol = 0.001), significant = FALSE) # job step factor + #pisiHeightFromDiameterNlrob$sharmaPartonBalRelDbh = fit_nlrob("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 50, a10 = -3, b1 = 0.12, b2 = -0.01, b3 = 0, b4 = 1.07), control = nls.control(maxiter = 100, tol = 0.001), significant = FALSE) # step factor + #pisiHeightFromDiameterNlrob$sharmaPartonPhysio = fit_nlrob("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016, start = list(a1 = 28, a1p = -10, a8 = 0.13, b1 = 0.16, b2 = -0.011, b2p = -0.01, b3 = 0, b4 = 1.1), control = nls.control(tol = 0.01)) # b3 not significant, job step factor + #pisiHeightFromDiameterNlrob$sharmaPartonRelDbh = fit_nlrob("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016, start = list(a1 = 27, a10 = -0.7, b1 = 0.22, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.003, b4 = 1.12), control = nls.control(tol = 0.001), significant = FALSE) + #pisiHeightFromDiameterNlrob$sharmaPartonRelDbhPhysio = fit_nlrob("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016, start = list(a1 = 41, a8 = 0.2, a10 = -2, b1 = 0.13, b2 = -0.01, b3 = 0, b4 = 1.09), significant = FALSE) + #pisiHeightFromDiameterNlrob$sharmaZhang = fit_nlrob("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), pisi2016, start = list(a1 = 36, a1p = -3.0, b1 = 0.1, b2 = -0.02, b3 = 0, b4 = 1.2, b4p = -0.2)) # b3 not significant + #pisiHeightFromDiameterNlrob$sharmaZhangBal = fit_nlrob("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, pisi2016, start = list(a1 = 44, a1p = -7, a2 = -0.12, a2p = 0.45, b1 = 0.05, b2 = -0.017, b3 = -0.02, b4 = 1.1), control = nls.control(maxiter = 100, tol = 0.001)) # b3 not significant, job step factor + pisiHeightFromDiameterNlrob$sibbesen = fit_nlrob("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), pisi2016, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + pisiHeightFromDiameterNlrob$weibull = fit_nlrob("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), pisi2016, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141), control = nls.control(maxiter = 100, tol = 1E-4)) # job step factor + #pisiHeightFromDiameterNlrob$weibullBal = fit_nlrob("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), pisi2016, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + pisiHeightFromDiameterNlrob$weibullBalRelHt = fit_nlrob("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), pisi2016, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + lapply(pisiHeightFromDiameterNlrob$sharmaPartonPhysio$fit, confint_nlrob, level = 0.99) + } else { + pisiHeightFromDiameterNlrob = list() + } + #fitting models with defaultweight 'pisi2016defaultWeight' which were fitted earlier without any weights. + #commented out models without any note at the end did not converge, for others the note is given mentioning the reason of error. + pisiHeightFromDiameterGslNlsDefault = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, pisi2016defaultWeight, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131))) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsBal = fit_gsl_nls("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, pisi2016defaultWeight, start = list(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysio = fit_gsl_nls("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016defaultWeightPhysio, start = list(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12), significant = FALSE) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelHt = fit_gsl_nls("Chapman-Richards BA+L RelHt", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3 * standBasalAreaPerHectare + (a9 + a9p * isPlantation) * relativeHeight) * (1 - exp(b1*DBH))^(b2 + b2p * isPlantation), pisi2016defaultWeight, start = list(a1 = 7, a1p = 5, a2 = 0.2, a2p = 0.24, a3 = -0.03, a9 = 47, a9p = -27, b1 = -0.021, b2 = 0.8, b2p = 0.2)) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsBalPhysioRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016, start = list(a1 = 58, a1p = -14, a2 = -0.07, a2p = 0.48, a8 = 0.27, a10 = -1.3, b1 = -0.012, b1p = -0.003, b2 = 1.13), significant = FALSE) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsBalRelDbh = fit_gsl_nls("Chapman-Richards BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 61, a1p = -9, a2 = -0.1, a2p = 0.6, a10 = -1.4, b1 = -0.012, b2 = 1.11), significant = FALSE) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016defaultWeightPhysio, start = list(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15)) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbh = fit_gsl_nls("Chapman-Richards RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter) * (1 - exp(b1*DBH))^b2, pisi2016defaultWeight, start = list(a1 = 74, a10 = -3.2, b1 = -0.011, b2 = 1.09)) + pisiHeightFromDiameterGslNlsDefault$chapmanRichardsRelDbhPhysio = fit_gsl_nls("Chapman-Richards RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016defaultWeightPhysio, start = list(a1 = 63, a1p = -17, a8 = 0.3, a10 = -2.1, b1 = -0.011, b1p = -0.006, b2 = 1.15), significant = FALSE) #produced NA or infinity + pisiHeightFromDiameterGslNlsDefault$curtis = fit_gsl_nls("Curtis", TotalHt ~ 1.37 + a1 * DBH / (1 + DBH)^b1, pisi2016defaultWeight, start = list(a1 = 0.560, b1 = 0.069)) + pisiHeightFromDiameterGslNlsDefault$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), pisi2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)) + pisiHeightFromDiameterGslNlsDefault$korf = fit_gsl_nls("Korf", TotalHt ~ 1.37 + a1*exp(b1*DBH^b2), pisi2016defaultWeight, start = list(a1 = 1825, b1 = -8.726, b2 = -0.175)) + pisiHeightFromDiameterGslNlsDefault$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), pisi2016defaultWeight, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)) + pisiHeightFromDiameterGslNlsDefault$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), pisi2016defaultWeight, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649)) + pisiHeightFromDiameterGslNlsDefault$power = fit_gsl_nls("power", TotalHt ~ 1.37 + a1*DBH^b1, pisi2016defaultWeight, start = list(a1 = 0.542, b1 = 0.939)) + pisiHeightFromDiameterGslNlsDefault$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), pisi2016defaultWeight, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151)) + pisiHeightFromDiameterGslNlsDefault$richardsW = fit_gsl_nls("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation) * (1 + ((1.37/(Ha + Hap*isPlantation))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), pisi2016defaultWeight, start = list(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008)) #produced NA or infinity + #pisiHeightFromDiameterGslNlsDefault$sharmaParton = fit_gsl_nls("Sharma-Parton", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016defaultWeight, start = list(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09))#produced NA or infinity + pisiHeightFromDiameterGslNlsDefault$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + a1*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016defaultWeight, start = list(a1 = 38, b1 = 0.12, b2 = -0.013, b3 = -0.1, b4 = 1.02)) + #pisiHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016defaultWeightPhysio, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)) + pisiHeightFromDiameterGslNlsDefault$sharmaPartonBalPhysioRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016defaultWeightPhysio, start = list(a1 = 23, a1p = -6, a8 = 0.12, a10 = -0.7, b1 = 0.21, b2 = -0.01, b2p = -0.010, b3 = -0.012, b4 = 1.14), significant = FALSE)#produced NA or infinity + pisiHeightFromDiameterGslNlsDefault$sharmaPartonBalRelDbh = fit_gsl_nls("Sharma-Parton BA+L RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016defaultWeight, start = list(a1 = 35, a10 = -1.4, b1 = 0.15, b2 = -0.01, b3 = 0, b4 = 1.07), significant = FALSE)#produced NA or infinity + pisiHeightFromDiameterGslNlsDefault$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016defaultWeightPhysio, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09))#produced NA or infinity + #pisiHeightFromDiameterGslNlsDefault$sharmaPartonRelDbh = fit_gsl_nls("Sharma-Parton RelDbh", TotalHt ~ 1.37 + (a1 + a10 * relativeDiameter)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016defaultWeight, start = list(a1 = 19, a10 = -0.3, b1 = 0.29, b1p = -0.09, b2 = -0.013, b2p = -0.011, b3 = -0.03, b4 = 1.13), significant = FALSE)#produced NA or infinity + pisiHeightFromDiameterGslNlsDefault$sharmaPartonRelDbhPhysio = fit_gsl_nls("Sharma-Parton RelDbh physio", TotalHt ~ 1.37 + (a1 + a8 * topographicShelterIndex + a10 * relativeDiameter)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016defaultWeightPhysio, start = list(a1 = 36, a8 = 0.18, a10 = 0, b1 = 0.2, b2 = -0.01, b3 = 0.03, b4 = 1.09), significant = FALSE) + pisiHeightFromDiameterGslNlsDefault$sharmaZhang = fit_gsl_nls("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), pisi2016defaultWeight, start = list(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)) + pisiHeightFromDiameterGslNlsDefault$sharmaZhangBal = fit_gsl_nls("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, pisi2016defaultWeight, start = list(a1 = 53.2, a1p = -8.857, a2 = -0.002, a2p = 0.10, b1 = -0.016, b2 = -0.025, b3 = -0.078, b4 = 1.126)) + pisiHeightFromDiameterGslNlsDefault$sibbesen = fit_gsl_nls("Sibbesen", TotalHt ~ 1.37 + a1*DBH^(b1*DBH^b2), pisi2016defaultWeight, start = list(a1 = 0.302, b1 = 1.495, b2 = -0.078)) + pisiHeightFromDiameterGslNlsDefault$weibull = fit_gsl_nls("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), pisi2016defaultWeight, start = list(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141)) + pisiHeightFromDiameterGslNlsDefault$weibullBal = fit_gsl_nls("Weibull BA+L", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), pisi2016defaultWeight, start = list(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131)) + pisiHeightFromDiameterGslNlsDefault$weibullBalRelHt = fit_gsl_nls("Weibull BA+L RelHt", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a9 + a9p * isPlantation) * pmin(relativeHeight, 1.5)) * (1 - exp(b1*DBH^b2)), pisi2016defaultWeight, start = list(a1 = 18.9, a2 = 0.171, a2p = 0.166, a9 = 46.6, a9p = -9.98, b1 = -0.019, b2 = 0.778)) + + pisiHeightFromDiameter$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # newton() step failure with family = scat, internal code errors with scat(theta = ), see https://stats.stackexchange.com/questions/410515/how-different-are-restricted-cubic-splines-and-penalized-splines for discusson of thin plate versus other spline types + pisiHeightFromDiameter$gamBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiHeightFromDiameter$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # slope and elevation not supported, aspect not tested since insufficient data for full model + pisiHeightFromDiameter$gamBalPhysioRelDbh = fit_gam("REML GAM BA+L RelDbh physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiHeightFromDiameter$gamBalRelDbh = fit_gam("REML GAM BA+L RelDbh", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiHeightFromDiameter$gamPhysio = fit_gam("REML GAM physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 18, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # k reduces from 85 to 18 without aspect + pisiHeightFromDiameter$gamRelDbh = fit_gam("REML GAM RelDbh", TotalHt ~ s(DBH, relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiHeightFromDiameter$gamRelDbhPhysio = fit_gam("REML GAM RelDbh physio", TotalHt ~ s(DBH, elevation, slope, topographicShelterIndex, relativeDiameter, bs = "ts", k = 57, by = as.factor(isPlantation), pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + + save(file = "data/pisi TotalHt.Rdata", pisiHeightFromDiameter, pisiHeightFromDiameterNlrob, pisiHeightFromDiameterGslNlsDefault) +} +if (htDiaOptions$includeInvestigatory) +{ + print(pisiHeightFromDiameterResults %>% select(-responseVariable, -species, -fixedWeight, -n, -power, -significant, -contains("NaturalRegen"), -contains("Plantation")), n = 30) + ggplot() + + geom_point(aes(x = pisi2016$DBH, y = pisi2016$TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$sharmaZhang), color = "Sharma-Zhang", group = pisi2016$isPlantation), alpha = 0.5) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$sharmaParton), color = "Sharma-Parton", group = pisi2016$isPlantation), alpha = 0.5) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$chapmanRichards), color = "Chapman-Richards", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$curtis), color = "Curtis", group = pisi2016$isPlantation)) + + geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$gam), color = "GAM", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$korf), color = "Korf", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$linear), color = "linear", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$michaelisMenten), color = "Michaelis-Menten", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$parabolic), color = "parabolic", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$power), color = "power", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$prodan), color = "Prodan", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$ratkowsky), color = "Ratkowsky", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$richardsW), color = "unified Richards", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$sibbesen), color = "Sibbesen", group = pisi2016$isPlantation)) + + #geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$weibull), color = "Weibull", group = pisi2016$isPlantation)) + + annotate("text", x = 0, y = 65, label = "cascara buckthorn, height from diameter", hjust = 0, size = 3.5) + + coord_cartesian(ylim = c(0, 65)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + theme(legend.justification = c(1, 0), legend.position = c(1, 0.03)) + + # dbhClassSize = 50 + # errorByDbhClass = tibble(dbhClass = dbhClassSize*floor(pisi2016$DBH/dbhClassSize) + 0.5*dbhClassSize, fittedValue = predict(pisiHeightFromDiameter$gam, pisi2016), height = pisi2016$TotalHt, residual = fittedValue - height) %>% + # #mutate(residual = residual - if_else(dbhClass == 50, -0.477/376, 0.107/95)) %>% + # group_by(dbhClass) %>% + # summarize(n = n(), + # totalHeight = sum(height), + # totalFitted = sum(fittedValue), + # meanBiasPerTree = sum(residual) / n, + # meanBiasPerTreePct = 100 * sum(residual/height) / n, + # minError = min(residual), + # meanError = mean(residual), + # maxError = max(residual), + # minPct = 100 * min(residual/height), + # meanPct = 100 * mean(residual/height), + # maxPct = 100 * max(residual/height), + # .groups = "drop") %>% + # filter(n >= 10) + # errorByDbhClass +} + + +## cascara buckthorn height-diameter GNLS regressions +if (pisiOptions$fitHeightGnls) +{ + pisiHeightFromDiameterGnls = list(chapmanRichards = fit_gnls("Chapman-Richards GNLS", TotalHt ~ 1.37 + a1*(1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), control = gnlsControl(nlsTol = 0.001))) # step halving at nlsTol = 1 with corSymm + #pisiHeightFromDiameterGnls$chapmanRichardsBal = fit_gnls("Chapman-Richards BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger + a3*standBasalAreaPerHectare) * (1 - exp(b1*DBH))^b2, pisi2016, start = pisiHeightFromDiameter$chapmanRichardsBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + #pisiHeightFromDiameterGnls$sharmaParton = fit_gnls("Sharma-Parton GNLS", TotalHt ~ 1.37 + a1*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016, start = pisiHeightFromDiameter$sharmaParton$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving at nlsTol = 0.2 with corSymm + #pisiHeightFromDiameterGnls$sharmaPartonBal = fit_gnls("Sharma-Parton BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = pisiHeightFromDiameter$sharmaPartonBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #pisiHeightFromDiameterGnls$sharmaZhang = fit_gnls("Sharma-Zhang GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), pisi2016, start = pisiHeightFromDiameter$sharmaZhang$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving with plot correlation + #pisiHeightFromDiameterGnls$sharmaZhangBal = fit_gnls("Sharma-Zhang BA+L GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, pisi2016, start = pisiHeightFromDiameter$sharmaZhangBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # step halving with plot correlation + #pisiHeightFromDiameterGnls$weibull = fit_gnls("Weibull GNLS", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), pisi2016, start = pisiHeightFromDiameter$weibull$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001, maxIter = 250, nlsMaxIter = 50)) # corSymm() viable but dropped + #pisiHeightFromDiameterGnls$weibullBal = fit_gnls("Weibull BA+L GNLS", TotalHt ~ 1.37 + (a1 + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), pisi2016, start = pisiHeightFromDiameter$weibullBal$fit[[1]]$m$getPars(), control = gnlsControl(nlsTol = 0.001)) # step halving at nlsTol = 1 with corSymm + + save(file = "data/pisi TotalHt gnls.Rdata", pisiHeightFromDiameterGnls) +} +if (htDiaOptions$includeInvestigatory) +{ + pisiHeightFromDiameterResultsGnls %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic) %>% arrange(method) + + #bind_cols(parameter = c("a1", "a2", "a3", "b1", "b2"), bal = confint2(pisiHeightFromDiameter$weibullBAL, level = 0.99), balN = confint2(pisiHeightFromDiameter$weibullBalNatural, level = 0.99), balP = confint2(pisiHeightFromDiameter$weibullBalPlantation, level = 0.99)) %>% + # mutate(bal005 = bal[, 1], bal995 = bal[, 2], balN005 = balN[, 1], balN995 = balN[, 2], balP005 = balP[, 1], balP995 = balP[, 2]) %>% + # select(-bal, -balN, -balP) + ggplot() + + geom_point(aes(x = pisi2016natural$DBH, y = pisi2016natural$TotalHt), alpha = 0.15, color = "navyblue", na.rm = TRUE, shape = 16) + + geom_smooth(aes(x = pisi2016natural$DBH, y = pisi2016natural$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "natural regeneration DBH, cm", y = "cascara buckthorn naturally regenerated height, m") + + ggplot() + + geom_point(aes(x = pisi2016plantation$DBH, y = pisi2016plantation$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + + geom_smooth(aes(x = pisi2016plantation$DBH, y = pisi2016plantation$TotalHt), alpha = 0.20, color = "red", formula = y ~ s(x, k = 20), method = "gam", size = 0.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "plantation DBH, cm", y = "cascara buckthorn plantation height, m") + + ggplot() + + geom_point(aes(x = pisi2016$DBH, y = pisi2016$TotalHt), alpha = 0.15, color = "black", na.rm = TRUE, shape = 16) + + geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$weibullBal), color = "Weibull BA+L"), alpha = 0.5) + # Temesgen et al. 2007, Eq. 5 + geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$power), color = "power")) + + geom_line(aes(x = pisi2016$DBH, y = predict(pisiHeightFromDiameter$weibull), color = "Weibull")) + + annotate("text", x = 0, y = 85, label = "a) cascara buckthorn, height from diameter", hjust = 0, size = 3.5) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 85)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + scale_color_manual(breaks = c("base", "ElliottWeibull", "ElliottBAL", "ElliottBALn", "ElliottBALp", "TemesgenWeibull"), labels = c(bquote("1.37 + b"[0]*"DBH"^{b[1]}), "Weibull", "Weibull with BA+L", "Weibull with BA+L, natural regeneration", "Weibull with BA+L, plantation", "Weibull, Temesgen et al. 2007"), values = c("#ac92eb", "#4dc1e8", "#a0d568", "#ffce54", "#ed5564", "grey65")) + + scale_y_continuous(breaks = seq(0, 100, by = 20)) + + theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) +} + + +if (pisiOptions$fitHeightMixed){ #fitting height diameter using mixed effect models + pisiHeightFromDiameterMixed = list(chapmanRichards = fit_nlme("Chapman-Richards", TotalHt ~ 1.37 + (a1 + a1r)*(1 - exp(b1*DBH))^b2, pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 48.2, b1 = -0.015, b2 = 1.131)), control = nlmeControl(maxIter = 250))) + pisiHeightFromDiameterMixed$chapmanRichardsBal = fit_nlme("Chapman-Richards BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger) * (1 - exp(b1*DBH))^b2, pisi2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 55, a1p = -10, a2 = -0.1, a2p = 0.6, b1 = -0.012, b2 = 1.1)), control = nlmeControl(maxIter = 500)) + pisiHeightFromDiameterMixed$chapmanRichardsBalPhysio = fit_nlme("Chapman-Richards BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation)*DBH))^b2, pisi2016, + fixedFormula = a1 + a1p + a2 + a2p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 50.8, a1p = -14.4, a2 = -0.09, a2p = 0.47, a8 = 0.23, b1 = -0.013, b1p = -0.003, b2 = 1.12)), control = nlmeControl(maxIter = 250), significant = FALSE) + pisiHeightFromDiameterMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex) * (1 - exp((b1 + b1p * isPlantation) * DBH))^b2, pisi2016, + fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, start = list(fixed = c(a1 = 52.0, a1p = -19.0, a8 = 0.20, b1 = -0.013, b1p = -0.009, b2 = 1.15))) + # pisiHeightFromDiameterMixed$curtis = fit_nlme("Curtis", TotalHt ~ 1.37 + (a1 + a1r) * DBH / (1 + DBH)^b1, pisi2016, + # fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 0.560, b1 = 0.069)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # max iterations in job + pisiHeightFromDiameterMixed$hossfeld = fit_nlme("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) / (1 + (b1 + b1p * isPlantation) *DBH^b2), pisi2016, + fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176)), control = nlmeControl(maxIter = 250)) + pisiHeightFromDiameterMixed$korf = fit_nlme("Korf", TotalHt ~ 1.37 + (a1 + a1r)*exp(b1*DBH^b2), pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1825, b1 = -8.726, b2 = -0.175)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations + pisiHeightFromDiameterMixed$michaelisMenten = fit_nlme("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), pisi2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176)), control = nlmeControl(maxIter = 250)) # job >100 iterations + pisiHeightFromDiameterMixed$prodan = fit_nlme("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3 + a3r), pisi2016, + fixedFormula = a1 + a1p + a2 + a3 ~ 1, randomFormula = a3r ~ 1, + start = list(fixed = c(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649))) + pisiHeightFromDiameterMixed$power = fit_nlme("power", TotalHt ~ 1.37 + (a1 + a1r)*DBH^b1, pisi2016, + fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 0.542, b1 = 0.939)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) # job >500 iterations without relaxed tolerances + #pisiHeightFromDiameterMixed$ratkowsky = fit_nlme("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), pisi2016, + # fixedFormula = a1 + a1p + b1 + b1p + b2 + b2p ~ 1, randomFormula = a1r ~ 1, + #start = list(fixed = c(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151))) + #pisiHeightFromDiameterMixed$richardsW = fit_nlme("unified Richards", TotalHt ~ 1.37 + (Ha + Hap*isPlantation + Har) * (1 + ((1.37/(Ha + Hap*isPlantation + Har))^(1 - d) - 1) * exp((-(kU + kUp * isPlantation) * DBH)/d^(d/(1 - d))))^(1/(1 - d)), pisi2016, + #fixedFormula = Ha + Hap + d + kU + kUp ~ 1, randomFormula = Har ~ 1, + #start = list(fixed = c(Ha = 52, Hap = -20, d = 0.5, kU = 0.008, kUp = 0.008))) + pisiHeightFromDiameterMixed$sharmaParton = fit_nlme("Sharma-Parton", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^(b1 + b1p * isPlantation)*(1 - exp((b2 + b2p * isPlantation)*(tph/standBasalAreaPerHectare)^b3*DBH))^b4, pisi2016, + fixedFormula = a1 + b1 + b1p + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 38.0, b1 = 0.131, b1p = -0.135, b2 = -0.015, b2p = -0.011, b3 = -0.114, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + pisiHeightFromDiameterMixed$sharmaPartonBal = fit_nlme("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1r)*topHeight^b1 * (1 - exp(b2*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, + fixedFormula = a1 + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 38, b1 = 0.1, b2 = -0.013, b3 = -0.1, b4 = 1.03)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve, step halving + pisiHeightFromDiameterMixed$sharmaPartonBalPhysio = fit_nlme("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, + fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + pisiHeightFromDiameterMixed$sharmaPartonPhysio = fit_nlme("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016, + fixedFormula = a1 + a1p + a8 + b1 + b2 + b2p + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 1E-3)) # singular precision matrix, step halving + pisiHeightFromDiameterMixed$sharmaZhang = fit_nlme("Sharma-Zhang", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*standBasalAreaPerHectare^b1*(1 - exp(b2*tph^b3*DBH))^(b4 + b4p * isPlantation), pisi2016, + fixedFormula = a1 + a1p + b1 + b2 + b3 + b4 + b4p ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 40.1, a1p = -4.259, b1 = 0.040, b2 = -0.042, b3 = -0.148, b4 = 1.190, b4p = -0.097)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + pisiHeightFromDiameterMixed$sharmaZhangBal = fit_nlme("Sharma-Zhang BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r + (a2 + a2p * isPlantation) * basalAreaLarger)*standBasalAreaPerHectare^b1 * (1 - exp(b2*tph^b3*DBH))^b4, pisi2016, + fixedFormula = a1 + a1p + a2 + a2p + b1 + b2 + b3 + b4 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 45, a1p = -7, a2 = -0.1, a2p = 0.4, b1 = -0.05, b2 = -0.02, b3 = -0.078, b4 = 1.08)), control = nlmeControl(tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + #pisiHeightFromDiameterMixed$sibbesen = fit_nlme("Sibbesen", TotalHt ~ 1.37 + a1*DBH^((b1 + b1r)*DBH^b2), pisi2016, + # fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = b1r ~ 1, + # start = list(fixed = c(a1 = 0.302, b1 = 1.495, b2 = -0.078))) # a1r: step halving, singular precision + pisiHeightFromDiameterMixed$weibull = fit_nlme("Weibull", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a1r)*(1 - exp((b1 + b1p * isPlantation)*DBH^b2)), pisi2016, + fixedFormula = a1 + a1p + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 49.3, a1p = -13.8, b1 = -0.007, b1p = -0.004, b2 = 1.141))) + pisiHeightFromDiameterMixed$weibullBal = fit_nlme("Weibull BA+L", TotalHt ~ 1.37 + (a1 + a1r + (a2 + a2p * isPlantation) * basalAreaLarger + (a3 + a3p * isPlantation) * standBasalAreaPerHectare) * (1 - exp(b1*DBH^b2)), pisi2016, + fixedFormula = a1 + a2 + a2p + a3 + a3p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 45.4, a2 = -0.178, a2p = 0.581, a3 = 0.096, a3p = -0.258, b1 = -0.008, b2 = 1.131))) + + pisiHeightFromDiameterMixed$gamm = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8) + s(StandID, bs = "re"), data = pisi2016, mixed = TRUE) + pisiHeightFromDiameterMixed$gammBal = fit_gam("REML GAM BA+L", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 13) + s(StandID, bs = "re"), data = pisi2016, mixed = TRUE) + + save(file = "data/pisi TotalHt mixed.Rdata", pisiHeightFromDiameterMixed) +} + + +## Cascara buckthorn diameter-height regressions +if (pisiOptions$fitDbh) { + pisiDiameterFromHeight = list(linear = fit_lm("linear", DBH ~ 0 + I(TotalHt - 1.37), pisi2016)) # isPlantation*(TotalHt - 1.37) not significant + pisiDiameterFromHeight$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), pisi2016) # (TotalHt - 1.37)^2 not significant + + pisiDiameterFromHeight$chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, pisi2016, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 500, xtol = 1E-5)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: singular gradient with nls(), no convergence from nls_multstart(), NaN-inf with nlrob() + #pisiDiameterFromHeight$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, pisi2016, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # NaN-inf with nls() and nlrob + pisiDiameterFromHeight$chapmanReplaceBal = fit_gsl_nls("Chapman-Richards replace BA+L", DBH ~ (a1 + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, start = list(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 300), significant = FALSE) # step size with nls() and nlrob() + pisiDiameterFromHeight$chapmanReplaceBalRelHt = fit_gsl_nls("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, start = list(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250, xtol = 0.001), significant = FALSE) # a2, a3 not significant, a1-b1 parameter evaporation: nlrob() step factor with either a2 or a3 + pisiDiameterFromHeight$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) # step size with nls(), >500 iterations with nlrob() + pisiDiameterFromHeight$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) # a1p and b2p not significant, poor convergence with b1p, step factor with nlrob() + pisiDiameterFromHeight$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) # a1p, b1p not significant, step factor with nlrob() + pisiDiameterFromHeight$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) # no physiographic effects significant, a1-b1 parameter evaporation: step factor with nlrob() + pisiDiameterFromHeight$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) # step factor with nlrob() + pisiDiameterFromHeight$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), pisi2016, start = list(a1 = 519, a2 = 237, b1 = 1.00)) # a1p, a2p, b1p not significant, singular gradient with nlrob() + #pisiDiameterFromHeight$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), pisi2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) + pisiDiameterFromHeight$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.93, b1 = 1.08)) # no significant plantation effects + pisiDiameterFromHeight$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) # no significant plantation effects + pisiDiameterFromHeight$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) # no significant physiographic effects + pisiDiameterFromHeight$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) # a1p and b1p not significant + pisiDiameterFromHeight$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) # a1p, b1p, b2p not significant + #pisiDiameterFromHeight$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) # a2, a2p, a3, a3p, b1p, b2p not significant + pisiDiameterFromHeight$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.9, a2 = -0.005, a4 = -0.001, b1 = 0.93, b2 = 0.006), significant = FALSE) # a2, a3 not significant, no AIC discrimination + pisiDiameterFromHeight$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = -1, b1 = 0.9, b2 = 0), significant = FALSE) # a2, a3, a4, a9, b2 not significant, drop ABA on AIC + #pisiDiameterFromHeight$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.7, a3 = 0, a9 = 0, b1 = 0.95, b2 = 0.005), significant = FALSE) # a9, a9p, b2 not significant + pisiDiameterFromHeight$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) # a1p, a5, a6, a7, a8, b1p, b2p not significant + pisiDiameterFromHeight$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) # a9, a9p, b1p, b2, b2p not significant + pisiDiameterFromHeight$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 3.2, a4 = 0, a9 = -1, b1 = 0.9, b2 = 0.01), significant = FALSE) # a4, a9 not significant + #pisiDiameterFromHeight$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), pisi2016, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) # singular gradient with nlrob() and gsl_nls() + #pisiDiameterFromHeight$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, pisi2016, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) # a1-b2 evaporation, b1, b3 not significant, NaN-inf with nls() from nls_multstart() point, NaN-inf, singular gradient, or code syntax error with nlrob() + pisiDiameterFromHeight$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) # no significant plantation effects + pisiDiameterFromHeight$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029), significant = FALSE) # no significant plantation effects + pisiDiameterFromHeight$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) # a2, a3, a8 not significant, drop ABA on AIC + pisiDiameterFromHeight$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.017, a9 = 1.0, b1 = 0.7, b2 = 0), significant = FALSE) # a2, a3, a8, a9, b2 not significant, no a2-a3 AIC discrimination + pisiDiameterFromHeight$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.5, a2 = 0, a9 = 0, a9p = 0, b1 = 0.6, b2 = 0.12), significant = FALSE) # a2, a9, a9p, b2 not significant + pisiDiameterFromHeight$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) # a1p, no physiographic effects significant + pisiDiameterFromHeight$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + pisiDiameterFromHeight$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.6, a8 = -0.01, a9 = 0.7, b1 = 0.7, b2 = 0.1), significant = FALSE) # a9 not significant + #pisiDiameterFromHeight$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, pisi2016, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) # a1p, b1p, b2p not significant, a1-b1 parameter evaporation: NaN-inf with nlrob() + lapply(pisiDiameterFromHeight$chapmanReplaceAbat$fit, confint2, level = 0.99) + lapply(pisiDiameterFromHeight$chapmanReplaceAbat$fit, get_model_coefficients) + + if (pisiOptions$fitDbhNlrob) + { + pisiDiameterFromHeightNlrob = list(naslund = fit_nlrob("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), pisi2016, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) + #pisiDiameterFromHeightNlrob$power = fit_nlrob("power", DBH ~ a1*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.93, b1 = 1.08)) + #pisiDiameterFromHeightNlrob$powerAbat = fit_nlrob("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + #pisiDiameterFromHeightNlrob$powerPhysio = fit_nlrob("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + #pisiDiameterFromHeightNlrob$powerRelHt = fit_nlrob("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + pisiDiameterFromHeightNlrob$ruark = fit_nlrob("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) + pisiDiameterFromHeightNlrob$ruarkAbat = fit_nlrob("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # occasional job step factor + pisiDiameterFromHeightNlrob$ruarkAbatPhysio = fit_nlrob("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.9, a2 = 0, a4 = -0.001, b1 = 0.93, b2 = 0.006), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # step factor + pisiDiameterFromHeightNlrob$ruarkAbatPhysioRelHt = fit_nlrob("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = 2.3, b1 = 0.9, b2 = 0), control = nls.control(maxiter = 100, tol = 1E-4), significant = FALSE) # job step factor + pisiDiameterFromHeightNlrob$ruarkAbatRelHt = fit_nlrob("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.4, a3 = 0, a9 = 3, b1 = 0.8, b2 = 0.01), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor + pisiDiameterFromHeightNlrob$ruarkPhysio = fit_nlrob("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + pisiDiameterFromHeightNlrob$ruarkRelHt = fit_nlrob("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) + pisiDiameterFromHeightNlrob$ruarkRelHtPhysio = fit_nlrob("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, start = list(a1 = 3.2, a4 = -0.001, a9 = 1, b1 = 0.8, b2 = 0), significant = FALSE) # a4, a9, b2 not significant + pisiDiameterFromHeightNlrob$sibbesenReplace = fit_nlrob("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) + pisiDiameterFromHeightNlrob$sibbesenReplaceAbat = fit_nlrob("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.1, a2 = -0.004, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4)) # job step factor + pisiDiameterFromHeightNlrob$sibbesenReplaceAbatPhysio = fit_nlrob("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1), significant = FALSE) + pisiDiameterFromHeightNlrob$sibbesenReplaceAbatPhysioRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.3, a2 = 0, a8 = -0.01, a9 = 0.5, b1 = 0.7, b2 = 0.1), control = nls.control(tol = 1E-4), significant = FALSE) # job step factor + pisiDiameterFromHeightNlrob$sibbesenReplaceAbatRelHt = fit_nlrob("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.1, a2 = 0, a9 = 0, a9p = 0.7, b1 = 0.6, b2 = 0.12), significant = FALSE) + pisiDiameterFromHeightNlrob$sibbesenReplacePhysio = fit_nlrob("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + pisiDiameterFromHeightNlrob$sibbesenReplaceRelHt = fit_nlrob("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + pisiDiameterFromHeightNlrob$weibull = fit_nlrob("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, pisi2016, start = list(a1 = -250, b1 = 0.043, b2 = 0.58), control = nls.control(maxiter = 500)) + confint_nlrob(pisiDiameterFromHeight$sibbesenReplacePhysio, level = 0.99, weights = pmin(pisi2016$TotalHt^if_else(pisi2016$isPlantation, -1.7, -1.6), 0.5)) + } else { + pisiDiameterFromHeightNlrob = list() + } + pisiDiameterFromHeightGslNlsDefault = list(chapmanReplace = fit_gsl_nls("Chapman-Richards replace", DBH ~ a1*(exp(b1*(TotalHt - 1.37)) - 1)^b2, pisi2016defaultWeight, start = list(a1 = 200, b1 = 0.01, b2 = 0.95), control = gsl_nls_control(maxiter = 250, xtol = 1E-5))) + pisiDiameterFromHeightGslNlsDefault$chapmanReplaceAbat = fit_gsl_nls("Chapman-Richards replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, pisi2016defaultWeight, start = list(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016defaultWeight, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500)) + pisiDiameterFromHeightGslNlsDefault$chapmanRichards = fit_gsl_nls("Chapman-Richards inverse", DBH ~ a1*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016defaultWeight, start = list(a1 = -200, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 250)) + pisiDiameterFromHeightGslNlsDefault$chapmanRichardsAbat = fit_gsl_nls("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016defaultWeight, start = list(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0), control = gsl_nls_control(maxiter = 500), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$chapmanRichardsPhysio = fit_gsl_nls("Chapman-Richards inverse physio", DBH ~ (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), pisi2016defaultWeightPhysio, start = list(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 5E-5)) + pisiDiameterFromHeightGslNlsDefault$chapmanRichardsRelHt = fit_gsl_nls("Chapman-Richards inverse RelHt", DBH ~ (a1 + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016defaultWeight, start = list(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9), control = gsl_nls_control(maxiter = 500), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$michaelisMentenReplace = fit_gsl_nls("Michaelis-Menten replace", DBH ~ a1 * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), pisi2016defaultWeight, start = list(a1 = 519, a2 = 237, b1 = 1.00)) + pisiDiameterFromHeightGslNlsDefault$naslund = fit_gsl_nls("Näslund inverse", DBH ~ (a1 + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), pisi2016defaultWeight, start = list(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024)) + pisiDiameterFromHeightGslNlsDefault$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, pisi2016defaultWeight, start = list(a1 = 1.93, b1 = 1.08)) + pisiDiameterFromHeightGslNlsDefault$powerAbat = fit_gsl_nls("power ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, pisi2016defaultWeight, start = list(a1 = 1.94, a2 = -0.00051, b1 = 1.09)) + pisiDiameterFromHeightGslNlsDefault$powerPhysio = fit_gsl_nls("power physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, pisi2016defaultWeightPhysio, start = list(a1 = 2.26, a8 = -0.0060, b1 = 1.08), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$powerRelHt = fit_gsl_nls("power RelHt", DBH ~ (a1 + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, pisi2016defaultWeight, start = list(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13)) + pisiDiameterFromHeightGslNlsDefault$ruark = fit_gsl_nls("Ruark", DBH ~ a1*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeight, start = list(a1 = 2.8, b1 = 0.9, b2 = 0.01)) + pisiDiameterFromHeightGslNlsDefault$ruarkAbat = fit_gsl_nls("Ruark ABA+T", DBH ~ (a1 + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeight, start = list(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$ruarkAbatPhysio = fit_gsl_nls("Ruark ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeightPhysio, start = list(a1 = 1.6, a2 = -0.01, a4 = -0.0006, b1 = 1.2, b2 = -0.009), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$ruarkAbatPhysioRelHt = fit_gsl_nls("Ruark ABA+T RelHt physio", DBH ~ (a1 + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeightPhysio, start = list(a1 = 1.6, a3 = -0.003, a4 = -0.0006, a9 = 0.4, b1 = 1.27, b2 = -0.01), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$ruarkAbatRelHt = fit_gsl_nls("Ruark ABA+T RelHt", DBH ~ (a1 + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeight, start = list(a1 = 1.3, a3 = -0.003, a9 = 0.25, b1 = 1.3, b2 = -0.008), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$ruarkPhysio = fit_gsl_nls("Ruark physio", DBH ~ (a1 + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeightPhysio, start = list(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$ruarkRelHt = fit_gsl_nls("Ruark RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeight, start = list(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$ruarkRelHtPhysio = fit_gsl_nls("Ruark RelHt physio", DBH ~ (a1 + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016defaultWeightPhysio, start = list(a1 = 1.6, a4 = -0.0005, a9 = -0.4, b1 = 1.2, b2 = -0.01), significant = FALSE) # a4, a9 not significant + #pisiDiameterFromHeightGslNlsDefault$schnute = fit_gsl_nls("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/(Ha^b1 - 1.3^b1)), pisi2016defaultWeight, start = list(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30), control = gsl_nls_control(maxiter = 200)) + #pisiDiameterFromHeightGslNlsDefault$sharmaParton = fit_gsl_nls("modified Sharma-Parton", DBH ~ a1*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, pisi2016defaultWeight, start = list(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1), control = gsl_nls_control(maxiter = 250, xtol = 0.025)) + pisiDiameterFromHeightGslNlsDefault$sibbesenReplace = fit_gsl_nls("Sibbesen replace", DBH ~ a1*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeight, start = list(a1 = 3.4, b1 = 0.8, b2 = 0.12)) + pisiDiameterFromHeightGslNlsDefault$sibbesenReplaceAbat = fit_gsl_nls("Sibbesen replace ABA+T", DBH ~ (a1 + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeight, start = list(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)) + pisiDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysio = fit_gsl_nls("Sibbesen replace ABA+T physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeightPhysio, start = list(a1 = 1.5, a2 = -0.009, a8 = -0.005, b1 = 1.2, b2 = -0.04), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatPhysioRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeightPhysio, start = list(a1 = 1.41, a2 = -0.009, a8 = -0.005, a9 = 0, b1 = 1.4, b2 = -0.05), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$sibbesenReplaceAbatRelHt = fit_gsl_nls("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeight, start = list(a1 = 1.5, a2 = -0.008, a9 = 0, a9p = 0, b1 = 1.4, b2 = 0), significant = FALSE) + #pisiDiameterFromHeightGslNlsDefault$sibbesenReplacePhysio = fit_gsl_nls("Sibbesen replace physio", DBH ~ (a1 + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeightPhysio, start = list(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + pisiDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHt = fit_gsl_nls("Sibbesen replace RelHt", DBH ~ (a1 + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeight, start = list(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1), significant = FALSE) + #pisiDiameterFromHeightGslNlsDefault$sibbesenReplaceRelHtPhysio = fit_gsl_nls("Sibbesen replace RelHt physio", DBH ~ (a1 + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016defaultWeightPhysio, start = list(a1 = 1.4, a8 = 0, a9 = 0.3, b1 = 1.3, b2 = -0.035), significant = FALSE) # a8, a9 not significant + #pisiDiameterFromHeightGslNlsDefault$weibull = fit_gsl_nls("Weibull inverse", DBH ~ (a1*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, pisi2016defaultWeight, start = list(a1 = -300, b1 = 0.04, b2 = 0.55), control = gsl_nls_control(maxiter = 250, xtol = 1E-4)) + + # individual term selection: TotalHt by = isPlantation only, AAT retained by AIC but not significant (p = 0.38), #did not run this part of the code because the variable 'pc=gamConstraint' is not defined, or not any information on how it may be defined + pisiDiameterFromHeight$gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # newton() step failure with scat() + pisiDiameterFromHeight$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiDiameterFromHeight$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiDiameterFromHeight$gamAbatPhysioRelHt = fit_gam("REML GAM ABA+T RelHt physio", DBH ~ s(TotalHt, standBasalAreaApprox, topographicShelterIndex, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 22, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # drop ABA and elevation on AIC + pisiDiameterFromHeight$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # drop elevation and topographic shelter on AIC + pisiDiameterFromHeight$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) + pisiDiameterFromHeight$gamRelHtPhysio = fit_gam("REML GAM RelHt physio", DBH ~ s(TotalHt, slope, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 57, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint) # drop elevation and aspect on AIC + + save(file = "data/pisi DBH.Rdata", pisiDiameterFromHeight, pisiDiameterFromHeightNlrob, pisiDiameterFromHeightGslNlsDefault) +} +if (htDiaOptions$includeInvestigatory) { + print(pisiDiameterFromHeightResults %>% select(-responseVariable, -species, -biasNR, -biasPl, -rmse, -rmseNR, -rmsePl, -pearsonNR, -pearsonPl, -aic, -bic), n = 25) + + ggplot(pisi2016) + + geom_point(aes(x = DBH, y = TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$sharmaParton), y = TotalHt, color = "modified Sharma-Parton", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$chapmanReplace), y = TotalHt, color = "Chapman-Richards replace", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$chapmanReplaceAbat), y = TotalHt, color = "Chapman-Richards replace approximate BA+L", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$chapmanReplaceBal), y = TotalHt, color = "Chapman-Richards replace BA+L", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$chapmanRichards), y = TotalHt, color = "Chapman-Richards", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$michaelisMentenReplace), y = TotalHt, color = "Michaelis-Menten replace", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$naslund), y = TotalHt, color = "Näslund", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$power), y = TotalHt, color = "power", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$ruark), y = TotalHt, color = "Ruark", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$schnute), y = TotalHt, color = "Schnute inverse", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$sibbesenReplace), y = TotalHt, color = "Sibbesen replace", group = isPlantation)) + + #geom_line(aes(x = predict(pisiDiameterFromHeight$weibull), y = TotalHt, color = "Weibull", group = isPlantation)) + + #geom_line(aes(x = 5*standBasalAreaPerHectare^0.5 * exp(0.0005*tph^0.5*(TotalHt - 1.37))^1, y = TotalHt, color = "Sharma-Zhang"), alpha = 0.5) + + #geom_line(aes(x = -100 * log(1 - pmin(0.015*(TotalHt - 1.37)^1.0, 0.999)), y = TotalHt, color = "Chapman-Richards inversion"), na.rm = TRUE) + + #geom_line(aes(x = 0.5*(TotalHt - 1.37)^1*exp(0.02*(tph/topHeight)^0.26*(TotalHt - 1.37))^0.9, y = TotalHt, color = "modified Sharma-Parton", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 15 * (exp(0.1*(TotalHt - 1.37)) - 1)^0.45, y = TotalHt, color = "Chapman-Richards replace", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 15 * (exp(0.1*(TotalHt - 1.37)) - 1)^0.35, y = TotalHt, color = "Chapman-Richards replace", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = (1.75 + 0.000001 * tallerApproxBasalArea + -0.000001 * standBasalAreaApprox) * exp(1.46*(TotalHt - 1.37)^0.280), y = TotalHt, color = "Chapman-Richards replace ABA+T", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = 0.03*topHeight*exp(1.6*(TotalHt - 1.37)^0.26), y = TotalHt, color = "Chapman-Richards replace top height", group = isPlantation), alpha = 0.5) + + #geom_line(aes(x = -1/0.0003*log(1 - (1 - exp(-0.1))*(TotalHt^1.5 - 1.37^1.5)/(75^1.5 - 1.37^1.5)), y = TotalHt, color = "Schnute inverse"), alpha = 0.5) + + geom_line(aes(x = 30*topHeight^0.5*(exp(0.01 * (tph/standBasalAreaPerHectare)^0.25*(TotalHt - 1.37)) - 1)^0.5, y = TotalHt, color = "modified Sharma-Parton"), alpha = 0.5) + + annotate("text", x = 0, y = 62, label = "cascara buckthorn, diameter from height", hjust = 0, size = 3.5) + + #coord_cartesian(xlim = c(0, 250), ylim = c(0, 90)) + + labs(x = "DBH, cm", y = "height, m", color = NULL) + + #scale_color_manual(breaks = c(FALSE, TRUE, "Chapman-Richards"), values = c("grey25", "transparent", "red")) + + #scale_color_manual(breaks = c(FALSE, TRUE, "Chapman-Richards"), values = c("transparent", "grey25", "red")) + + scale_y_continuous(breaks = seq(0, 100, by = 20)) + + theme(legend.justification = c(1, 0), legend.position = c(0.99, 0.03)) +} + +if (pisiOptions$fitDbhMixed) { + pisiDiameterFromHeightMixed = list(chapmanReplace = fit_nlme("Chapman-Richards replace", DBH ~ (a1 + a1r)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 200, b1 = 0.01, b2 = 0.95)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001))) # singularity in backsolve, max iterations + pisiDiameterFromHeightMixed$chapmanReplaceAbat = fit_nlme("Chapman-Richards replace ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(exp(b1*(TotalHt - 1.37)) - 1)^b2, pisi2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 200, a2 = 0, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # singularity in backsolve + #pisiDiameterFromHeightMixed$chapmanReplaceBal = fit_nlme("Chapman-Richards replace BA+L", DBH ~ (a1 + a1r + a2 * basalAreaLarger) * (exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, + # fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 200, a2 = -10, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 300, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving + #pisiDiameterFromHeightMixed$chapmanReplaceBalRelHt = fit_nlme("Chapman-Richards replace BA+L RelHt", DBH ~ (a1 + a1r + a2 * basalAreaLarger + a9 * pmin(relativeHeight, 1.5)) * (exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, + # fixedFormula = a1 + a2 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 10, a2 = 0, a9 = 2.3, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 250, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # singularity in backsolve + #pisiDiameterFromHeightMixed$chapmanReplaceRelHt = fit_nlme("Chapman-Richards replace RelHt", DBH ~ (a1 + a1r + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # step halving + pisiDiameterFromHeightMixed$chapmanRichards = fit_nlme("Chapman-Richards inverse", DBH ~ (a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations + pisiDiameterFromHeightMixed$chapmanRichardsAbat = fit_nlme("Chapman-Richards inverse ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, a2 = 0, b1 = 0.01, b2 = 1.0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations, step halving + #pisiDiameterFromHeightMixed$chapmanRichardsPhysio = fit_nlme("Chapman-Richards inverse physio", DBH ~ (a1 + a1r + a1p * isPlantation + a8 * topographicShelterIndex)*log(1 - pmin((b1 + b1p * isPlantation)*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, + # fixedFormula = a1 + a1p + a8 + b1 + b1p + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = -70, a1p = 40, a8 = 0.3, b1 = 0.01, b1p = 0.03, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations, step halving + pisiDiameterFromHeightMixed$chapmanRichardsRelHt = fit_nlme("Chapman-Richards inverse RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*log(1 - pmin(b1*(TotalHt - 1.37)^b2, 0.9999)), pisi2016, + fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -200, a9 = -70, b1 = 0.01, b2 = 0.9)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # step halving, singularity in backsolve + pisiDiameterFromHeightMixed$michaelisMentenReplace = fit_nlme("Michaelis-Menten replace", DBH ~ (a1 + a1r) * (TotalHt - 1.37)^b1 / (a2 - (TotalHt - 1.37)^b1), pisi2016, + fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 519, a2 = 237, b1 = 1.00)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # max iterations, step halving + pisiDiameterFromHeightMixed$naslund = fit_nlme("Näslund inverse", DBH ~ (a1 + a1r + a1p * isPlantation) * sqrt(TotalHt - 1.37) / (1 + (a2 + a2p * isPlantation) * sqrt(TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + a1p + a2 + a2p ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 5.1, a1p = -1.6, a2 = -0.11, a2p = -0.024))) + pisiDiameterFromHeightMixed$power = fit_nlme("power", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1, pisi2016, + fixedFormula = a1 + b1 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1.93, b1 = 1.08)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4)) # job max iterations + #pisiDiameterFromHeightMixed$powerAbat = fit_nlme("power ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^b1, pisi2016, + # fixedFormula = a1 + a2 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 1.94, a2 = -0.00051, b1 = 1.09))) + #pisiDiameterFromHeightMixed$powerPhysio = fit_nlme("power physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex)*(TotalHt - 1.37)^b1, pisi2016, + # fixedFormula = a1 + a8 + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 2.26, a8 = -0.0060, b1 = 1.08)), significant = FALSE) + #pisiDiameterFromHeightMixed$powerRelHt = fit_nlme("power RelHt", DBH ~ (a1 + a1r + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^b1, pisi2016, + # fixedFormula = a1 + a9 + a9p + b1 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 1.68, a9 = -0.11, a9p = 0.23, b1 = 1.13))) + pisiDiameterFromHeightMixed$ruark = fit_nlme("Ruark", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.8, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations + pisiDiameterFromHeightMixed$ruarkAbat = fit_nlme("Ruark ABA+T", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + a3 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.7, a3 = -0.003, b1 = 0.95, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # job max iterations + pisiDiameterFromHeightMixed$ruarkAbatPhysio = fit_nlme("Ruark ABA+T physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + a2 + a4 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.9, a2 = -0.005, a4 = -0.001, b1 = 0.93, b2 = 0.006)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # job max iterations + #pisiDiameterFromHeightMixed$ruarkAbatPhysioRelHt = fit_nlme("Ruark ABA+T RelHt physio", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + # fixedFormula = a1 + a3 + a4 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 3.2, a3 = 0, a4 = -0.002, a9 = -1, b1 = 0.9, b2 = 0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations + pisiDiameterFromHeightMixed$ruarkAbatRelHt = fit_nlme("Ruark ABA+T RelHt", DBH ~ (a1 + a1r + a3 * standBasalAreaApprox + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + a3 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.7, a3 = 0, a9 = 0, b1 = 0.95, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + pisiDiameterFromHeightMixed$ruarkPhysio = fit_nlme("Ruark physio", DBH ~ (a1 + a1r + a4 * elevation)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + a4 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 2.9, a4 = -0.001, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + #pisiDiameterFromHeightMixed$ruarkRelHt = fit_nlme("Ruark RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + # fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 2.8, a9 = 0.5, b1 = 0.9, b2 = 0.005)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # job max iterations + pisiDiameterFromHeightMixed$ruarkRelHtPhysio = fit_nlme("Ruark RelHt physio", DBH ~ (a1 + a1r + a4 * elevation + a9 * relativeHeight)*(TotalHt - 1.37)^b1 * exp(b2 * (TotalHt - 1.37)), pisi2016, + fixedFormula = a1 + a4 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.2, a4 = 0, a9 = -1, b1 = 0.9, b2 = 0.01)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations, false convergence + #pisiDiameterFromHeightMixed$schnute = fit_nlme("Schnute inverse", DBH ~ -1/a1 * log(1 - (1 - exp(-a2))*(TotalHt^b1 - 1.37^b1)/((Ha + Har)^b1 - 1.3^b1)), pisi2016, + # fixedFormula = a1 + a2 + b1 + Ha ~ 1, randomFormula = Har ~ 1, + # start = list(fixed = c(a1 = 0.00005, a2 = 0.001, b1 = 1.05, Ha = 30)), control = nlmeControl(maxIter = 100, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # step halving + #pisiDiameterFromHeightMixed$sharmaParton = fit_nlme("modified Sharma-Parton", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^b1*(exp(b2*(TotalHt - 1.37)) - 1)^b4, pisi2016, + # fixedFormula = a1 + b1 + b2 + b4 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 100, b1 = -0.15, b2 = 0.01, b4 = 1.1)), control = nlmeControl(maxIter = 250, tolerance = 0.1, pnlsTol = 1, msTol = 0.01)) # singularity in backsolve + pisiDiameterFromHeightMixed$sibbesenReplace = fit_nlme("Sibbesen replace", DBH ~ (a1 + a1r)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.4, b1 = 0.8, b2 = 0.12)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # job max iterations + pisiDiameterFromHeightMixed$sibbesenReplaceAbat = fit_nlme("Sibbesen replace ABA+T", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + a2 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 1.39, a2 = -0.00036, b1 = 1.31, b2 = -0.029)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5)) + pisiDiameterFromHeightMixed$sibbesenReplaceAbatPhysio = fit_nlme("Sibbesen replace ABA+T physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + a2 + a8 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.6, a2 = 0, a8 = -0.01, b1 = 0.7, b2 = 0.1)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + #pisiDiameterFromHeightMixed$sibbesenReplaceAbatPhysioRelHt = fit_nlme("Sibbesen replace ABA+T RelHt physio", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + # fixedFormula = a1 + a2 + a8 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + # start = list(fixed = c(a1 = 3.3, a2 = 0, a8 = -0.017, a9 = 1.0, b1 = 0.7, b2 = 0)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001), significant = FALSE) # max iterations + pisiDiameterFromHeightMixed$sibbesenReplaceAbatRelHt = fit_nlme("Sibbesen replace ABA+T RelHt", DBH ~ (a1 + a1r + a2 * tallerApproxBasalArea + (a9 + a9p * isPlantation) * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + a2 + a9 + a9p + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.5, a2 = 0, a9 = 0, a9p = 0, b1 = 0.6, b2 = 0.12)), control = nlmeControl(maxIter = 500, tolerance = 1E-4, pnlsTol = 0.01, msTol = 1E-5), significant = FALSE) # singular precision matrix + pisiDiameterFromHeightMixed$sibbesenReplacePhysio = fit_nlme("Sibbesen replace physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + a8 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.6, a8 = 0, b1 = 0.6, b2 = 0.1)), control = nlmeControl(maxIter = 500), significant = FALSE) + pisiDiameterFromHeightMixed$sibbesenReplaceRelHt = fit_nlme("Sibbesen replace RelHt", DBH ~ (a1 + a1r + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.3, a9 = 0, b1 = 0.6, b2 = 0.1)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + pisiDiameterFromHeightMixed$sibbesenReplaceRelHtPhysio = fit_nlme("Sibbesen replace RelHt physio", DBH ~ (a1 + a1r + a8 * topographicShelterIndex + a9 * relativeHeight)*(TotalHt - 1.37)^(b1*(TotalHt - 1.37)^b2), pisi2016, + fixedFormula = a1 + a8 + a9 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = 3.0, a8 = -0.01, a9 = 0, b1 = 0.73, b2 = 0.07)), control = nlmeControl(maxIter = 500, tolerance = 0.001, pnlsTol = 0.1, msTol = 1E-4), significant = FALSE) # max iterations + pisiDiameterFromHeightMixed$weibull = fit_nlme("Weibull inverse", DBH ~ ((a1 + a1r)*log(1 - pmin(b1*(TotalHt - 1.37), 0.9999)))^b2, pisi2016, + fixedFormula = a1 + b1 + b2 ~ 1, randomFormula = a1r ~ 1, + start = list(fixed = c(a1 = -300, b1 = 0.04, b2 = 0.55)), control = nlmeControl(maxIter = 500, tolerance = 0.01, pnlsTol = 1, msTol = 0.001)) # singularity in backsolve + + pisiDiameterFromHeightMixed$gamm = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = pisi2016, mixed = TRUE) + pisiDiameterFromHeightMixed$gammAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16) + s(StandID, bs = "re"), data = pisi2016, mixed = TRUE) + pisiDiameterFromHeightMixed$gammRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9) + s(StandID, bs = "re"), data = pisi2016, mixed = TRUE) + + save(file = "data/pisi DBH mixed.Rdata", pisiDiameterFromHeightMixed) +} + + +# ## collect model results and parameters +# if (pisiOptions$fitHeight & pisiOptions$fitHeightMixed & pisiOptions$fitDbh & pisiOptions$fitDbhMixed) { +# if (exists("pisiHeightFromDiameter") == FALSE) { load("trees/height-diameter/data/pisi TotalHt.Rdata") } +# #if (exists("pisiHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/pisi TotalHt gnls.Rdata") } +# if (exists("pisiHeightFromDiameterMixed") == FALSE) { load("trees/height-diameter/data/pisi TotalHt mixed.Rdata") } +# if (exists("pisiDiameterFromHeight") == FALSE) { load("trees/height-diameter/data/pisi DBH.Rdata") } +# if (exists("pisiDiameterFromHeightMixed") == FALSE) { load("trees/height-diameter/data/pisi DBH mixed.Rdata") } + +## collect model results and parameters +if (pisiOptions$fitHeight & pisiOptions$fitHeightMixed & pisiOptions$fitDbh & pisiOptions$fitDbhMixed) { + if (exists("pisiHeightFromDiameter") == FALSE) { load("data/pisi TotalHt.Rdata") } + #if (exists("pisiHeightFromDiameterGnls") == FALSE) { load("trees/height-diameter/data/pisi TotalHt gnls.Rdata") } + if (exists("pisiHeightFromDiameterMixed") == FALSE) { load("data/pisi TotalHt mixed.Rdata") } + if (exists("pisiDiameterFromHeight") == FALSE) { load("data/pisi DBH.Rdata") } + if (exists("pisiDiameterFromHeightMixed") == FALSE) { load("data/pisi DBH mixed.Rdata") } + pisiCoefficients = bind_rows(bind_rows(bind_rows(lapply(pisiHeightFromDiameter, get_list_coefficients)), + #bind_rows(lapply(pisiHeightFromDiameterGnls, get_model_coefficients)), + bind_rows(lapply(pisiHeightFromDiameterGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(pisiHeightFromDiameterMixed, get_list_coefficients, fitSet = "mixed")), + bind_rows(lapply(pisiHeightFromDiameterNlrob, get_list_coefficients, fitSet = "nlrob"))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(pisiDiameterFromHeight, get_list_coefficients)), + bind_rows(lapply(pisiDiameterFromHeightGslNlsDefault, get_list_coefficients, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(pisiDiameterFromHeightMixed, get_list_coefficients, fitSet = "mixed")), + bind_rows(lapply(pisiDiameterFromHeightNlrob, get_list_coefficients, fitSet = "nlrob"))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "pisi") + pisiResults = bind_rows(bind_rows(bind_rows(lapply(pisiHeightFromDiameter, get_list_stats)), + #bind_rows(lapply(pisiHeightFromDiameterGnls, get_stats)), + bind_rows(lapply(pisiHeightFromDiameterGslNlsDefault, get_list_stats, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(pisiHeightFromDiameterMixed, get_list_stats, fitSet = "mixed")), + bind_rows(lapply(pisiHeightFromDiameterNlrob, get_list_stats, fitSet = "nlrob"))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(pisiDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitSet = "primary", fittingMethod = "gsl_nls"), + bind_rows(lapply(pisiDiameterFromHeightGslNlsDefault, get_list_stats, fitSet = "gsl_nls", fixedWeight = -1)), + bind_rows(lapply(pisiDiameterFromHeightMixed, get_list_stats, fitSet = "mixed")), + bind_rows(lapply(pisiDiameterFromHeightNlrob, get_list_stats, fitSet = "nlrob"))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "pisi") + + check_plot_results(pisiResults) + save(file = "data/pisi results.Rdata", pisiCoefficients, pisiResults) +} else if (pisiOptions$fitHeight & pisiOptions$fitHeightMixed & pisiOptions$fitDbh & pisiOptions$fitDbhMixed) +{ + if (exists("pisiHeightFromDiameter") == FALSE) { load("data/pisi TotalHt.Rdata") } + if (exists("pisiDiameterFromHeight") == FALSE) { load("data/pisi DBH.Rdata") } + + pisiCoefficients = bind_rows(bind_rows(bind_rows(lapply(pisiHeightFromDiameter, get_list_coefficients))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(pisiDiameterFromHeight, get_list_coefficients))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "pisi") + pisiResults = bind_rows(bind_rows(bind_rows(lapply(pisiHeightFromDiameter, get_list_stats))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(pisiDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitting = "gsl_nls", fitSet = "primary")) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "pisi") + + check_plot_results(pisiResults) + save(file = "data/pisi results.Rdata", pisiCoefficients, pisiResults) +}else(pisiOptions$fitHeight &pisiOptions$fitDbh) #added for height and diameter fit only. +{ + if (exists("pisiHeightFromDiameter") == FALSE) { load("data/pisi TotalHt.Rdata") } + if (exists("pisiDiameterFromHeight") == FALSE) { load("data/pisi DBH.Rdata") } + + pisiCoefficients = bind_rows(bind_rows(bind_rows(lapply(pisiHeightFromDiameter, get_list_coefficients))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(pisiDiameterFromHeight, get_list_coefficients))) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "pisi") + pisiResults = bind_rows(bind_rows(bind_rows(lapply(pisiHeightFromDiameter, get_list_stats))) %>% + mutate(responseVariable = "height"), + bind_rows(bind_rows(lapply(pisiDiameterFromHeight, get_list_stats)), + create_model_stats(name = "Schnute inverse", fitting = "gsl_nls", fitSet = "primary")) %>% + mutate(responseVariable = "DBH")) %>% + mutate(species = "pisi") + + check_plot_results(pisiResults) + save(file = "data/pisi results.Rdata", pisiCoefficients, pisiResults) +} + +## preferred forms identified (results.R, Figure 8) +if (pisiOptions$fitHeight & pisiOptions$fitDbh) +{ + pisiHeightFromDiameterPreferred = list(chapmanRichards = fit_gsl_nls("Chapman-Richards", TotalHt ~ 1.37 + a1 * (1 - exp(b1*DBH))^b2, pisi2016, start = list(a1 = 48.2, b1 = -0.015, b2 = 1.131), folds = 1, repetitions = 1)) + pisiHeightFromDiameterPreferred$gam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + #pisiHeightFromDiameterPreferred$gamBalPhysio = fit_gam("REML GAM BA+L physio", TotalHt ~ s(DBH, standBasalAreaPerHectare, basalAreaLarger, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 20, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + pisiHeightFromDiameterPreferred$hossfeld = fit_gsl_nls("Hossfeld IV", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) / (1 + (b1 + b1p * isPlantation) *DBH^b2), pisi2016, start = list(a1 = 70.3, a1p = -18.7, b1 = 200, b1p = -68.2, b2 = -1.176), folds = 1, repetitions = 1) + pisiHeightFromDiameterPreferred$michaelisMenten = fit_gsl_nls("Michaelis-Menten", TotalHt ~ 1.37 + (a1 + a1p * isPlantation) * DBH^b1 / (a2 + a2p * isPlantation + DBH^b1), pisi2016, start = list(a1 = 70.3, a1p = -18.7, a2 = 200, a2p = -68.2, b1 = 1.176), folds = 1, repetitions = 1) + pisiHeightFromDiameterPreferred$prodan = fit_gsl_nls("Prodan", TotalHt ~ 1.37 + DBH^2 / ((a1 + a1p * isPlantation) * DBH^2 + a2*DBH + a3), pisi2016, start = list(a1 = 0.011, a1p = 0.002, a2 = 1.600, a3 = 1.649), folds = 1, repetitions = 1) + #pisiHeightFromDiameterPreferred$sharmaPartonBal = fit_gsl_nls("Sharma-Parton BA+L", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 50.6, a1p = -15.8, b1 = 0.023, b2 = -0.014, b2p = -0.009, b3 = -0.069, b4 = 1.130), folds = 1, repetitions = 1) + #pisiHeightFromDiameterPreferred$sharmaPartonBalPhysio = fit_gsl_nls("Sharma-Parton BA+L physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare + basalAreaLarger))^b3*DBH))^b4, pisi2016, start = list(a1 = 37.0, a1p = -13.4, a8 = 0.13, b1 = 0.11, b2 = -0.013, b2p = -0.012, b3 = -0.10, b4 = 1.10), folds = 1, repetitions = 1) + #pisiHeightFromDiameterPreferred$sharmaPartonPhysio = fit_gsl_nls("Sharma-Parton physio", TotalHt ~ 1.37 + (a1 + a1p * isPlantation + a8 * topographicShelterIndex)*topHeight^b1 * (1 - exp((b2 + b2p * isPlantation)*(tph/(standBasalAreaPerHectare))^b3*DBH))^b4, pisi2016, start = list(a1 = 32.7, a1p = -11.6, a8 = 0.11, b1 = 0.13, b2 = -0.014, b2p = -0.014, b3 = -0.11, b4 = 1.09), folds = 1, repetitions = 1) + pisiHeightFromDiameterPreferred$ratkowsky = fit_gsl_nls("Ratkowsky", TotalHt ~ 1.37 + (a1 + a1p * isPlantation)*exp((b1 + b1p * isPlantation)/(DBH + b2 + b2p * isPlantation)), pisi2016, start = list(a1 = 62.9, a1p = -19.3, b1 = -61.8, b1p = 23.1, b2 = 13.3, b2p = -5.151), folds = 1, repetitions = 1) + AIC(pisiHeightFromDiameterPreferred$hossfeld, pisiHeightFromDiameterPreferred$michaelisMenten, pisiHeightFromDiameterPreferred$prodan, pisiHeightFromDiameterPreferred$ratkowsky) + + pisiDiameterFromHeightPreferred = list(gam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1)) + #pisiDiameterFromHeightPreferred$chapmanReplaceRelHt = fit_gsl_nls("Chapman-Richards replace RelHt", DBH ~ (a1 + a9 * pmin(relativeHeight, 1.5))*(exp(b1*(TotalHt - 1.37)^b2) - 1), pisi2016, start = list(a1 = 100, a9 = 2.3, b1 = 0.01, b2 = 0.8), control = gsl_nls_control(maxiter = 500), folds = 1, repetitions = 1) + pisiDiameterFromHeightPreferred$parabolic = fit_lm("parabolic", DBH ~ 0 + I(TotalHt - 1.37) + I(isPlantation*(TotalHt - 1.37)) + I(isPlantation*(TotalHt - 1.37)^2), pisi2016, folds = 1, repetitions = 1) + pisiDiameterFromHeightPreferred$power = fit_gsl_nls("power", DBH ~ a1*(TotalHt - 1.37)^b1, pisi2016, start = list(a1 = 1.93, b1 = 1.08), folds = 1, repetitions = 1) + #pisiDiameterFromHeightPreferred$gamAbat = fit_gam("REML GAM ABA+T", DBH ~ s(TotalHt, tallerApproxBasalArea, standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + #pisiDiameterFromHeightPreferred$gamAbatPhysio = fit_gam("REML GAM ABA+T physio", DBH ~ s(TotalHt, tallerApproxBasalArea, slope, bs = "ts", by = as.factor(isPlantation), k = 16, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + #pisiDiameterFromHeightPreferred$gamPhysio = fit_gam("REML GAM physio", DBH ~ s(TotalHt, topographicShelterIndex, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + pisiDiameterFromHeightPreferred$gamRelHt = fit_gam("REML GAM RelHt", DBH ~ s(TotalHt, relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 9, pc = gamConstraint), data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + + save(file = "data/pisi preferred models.Rdata", pisiHeightFromDiameterPreferred, pisiDiameterFromHeightPreferred) +} + + +## basal area from height +if (htDiaOptions$includeInvestigatory) +{ + pisiBasalAreaFromHeightKorf = gsl_nls(basalArea ~ a1*(exp(b1*(imputedHeight - 1.37)^b2) - 1), pisi2016, start = list(a1 = 90, b1 = 0.000003, b2 = 2.18), weights = heightWeight^2) # a1p, b1p, b2p not significant + pisiBasalAreaFromHeightPower = gsl_nls(basalArea ~ a1*(imputedHeight - 1.37)^(b1 + b1p * isPlantation), pisi2016, start = list(a1 = 3/7 * 0.25 * pi * 0.01^2, b1 = 2.14, b1p = 0.34), weights = heightWeight^2) # a1p not significant + #confint2(pisiBasalAreaFromHeightPower, level = 0.99) + + tribble(~method, ~aic, ~biasCm2, ~maeM2, ~nse, + "Korf", AIC(pisiBasalAreaFromHeightKorf), 100^2 * mean(residuals(pisiBasalAreaFromHeightKorf)), mean(abs(residuals(pisiBasalAreaFromHeightKorf))), 1 - sum(residuals(pisiBasalAreaFromHeightKorf)^2) / sum((pisi2016$basalArea - mean(pisi2016$basalArea)^2)), + "power", AIC(pisiBasalAreaFromHeightPower), 100^2 * mean(residuals(pisiBasalAreaFromHeightPower)), mean(abs(residuals(pisiBasalAreaFromHeightPower))), 1 - sum(residuals(pisiBasalAreaFromHeightPower)^2) / sum((pisi2016$basalArea - mean(pisi2016$basalArea)^2))) %>% + mutate(deltaAIC = aic - min(aic)) %>% + arrange(desc(deltaAIC)) + + ggplot(pisi2016) + + geom_point(aes(x = imputedHeight, y = 0.25*pi*(0.01*DBH)^2), alpha = 0.1, color = "grey25", shape = 16) + + geom_line(aes(x = imputedHeight, y = predict(pisiBasalAreaFromHeightKorf), color = "Korf", group = isPlantation)) + + geom_line(aes(x = imputedHeight, y = predict(pisiBasalAreaFromHeightPower), color = "power", group = isPlantation)) + + #geom_path(aes(x = imputedHeight, y = 10*(1 - exp(-0.1*(imputedHeight - 1.37)))^1.2, color = "Chapman-Richards")) + + labs(x = "cascara buckthorn height, m", y = "basal area, m²", color = NULL) + + theme(legend.justification = c(0, 1), legend.position = c(0.03, 0.99)) +} + + +## exploratory plots +if (htDiaOptions$includeInvestigatory) +{ + library(GGally) + ggpairs(pisi2016 %>% mutate(regeneration = if_else(isPlantation, "plantation", "natural regen")) %>% select(TotalHt, DBH, standBasalAreaPerHectare, basalAreaLarger, relativeHeight, regeneration), + aes(alpha = 0.1, color = regeneration, shape = "16"), + columnLabels = c("DBH, cm", "height, m", "BA, m² ha⁻¹", "BAL, m² ha⁻¹", "relative height, %", "stand type"), + upper = list(continuous = wrap("cor", size = 3)), + lower = list(combo = wrap("facethist", bins = 30))) + + scale_color_discrete(type = c("forestgreen", "darkviolet")) + + #scale_color_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + # https://github.com/ggobi/ggally/issues/445 + scale_fill_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + + theme(strip.background = element_blank()) + ggpairs(pisi2016 %>% mutate(regeneration = if_else(isPlantation, "plantation", "natural regen")) %>% select(TotalHt, DBH, slope, elevation, topographicShelterIndex, regeneration), + aes(alpha = 0.1, color = if_else(pisi2016$isPlantation, "plantation", "natural regen"), shape = "16"), + columnLabels = c("DBH, cm", "height, m", "slope, °", "elevation, m", "TSI, °", "stand type"), + upper = list(continuous = wrap("cor", size = 3)), + lower = list(combo = wrap("facethist", bins = 30))) + + scale_color_discrete(type = c("forestgreen", "darkviolet")) + + scale_fill_manual(breaks = c("natural regen", "plantation"), values = c("forestgreen", "darkviolet")) + + theme(strip.background = element_blank()) + scatterPlotMatrix::scatterPlotMatrix(pisi2016 %>% select(TotalHt, DBH, standBasalAreaPerHectare, basalAreaLarger)) +} + + +## GAM smooth effects +if (htDiaOptions$includeInvestigatory) +{ + #pisiInteraction = lm(TotalHt ~ DBH*standBasalAreaPerHectare + DBH:basalAreaLarger + standBasalAreaPerHectare:basalAreaLarger, pisi2016) + #summary(pisiInteraction) + #ggplot() + + # geom_point(aes(x = DBH, y = basalAreaLarger, color = pisiInteraction$residuals), pisi2016, shape = 16) + + # labs(x = "DBH, cm", y = bquote("BAL, m"^2*" ha"^-1), color = "height\nresidual, m") + + # scale_color_scico(palette = "bam", limits = c(-20, 20)) + pisiHeightGam = fit_gam("REML GAM", TotalHt ~ s(DBH, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint) + + #s(standBasalAreaPerHectare, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + #s(basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + s(topographicShelterIndex, bs = "ts", k = 5, pc = gamConstraint) + + s(relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint), + data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + #pisiHeightGam = fit_gam("REML GAM", TotalHt ~ s(DBH, standBasalAreaPerHectare, bs = "ts", by = as.factor(isPlantation), k = 11, pc = gamConstraint) + + # #s(basalAreaLarger, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint) + # not significant + # #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + # s(topographicShelterIndex, bs = "ts", k = 5, pc = gamConstraint), + # #s(relativeDiameter, bs = "ts", by = as.factor(isPlantation), k = 4, pc = gamConstraint), # not significant + # data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + k.check(pisiHeightGam) + summary(pisiHeightGam) + par(mfrow = c(2, 3), mar = c(2.2, 2.2, 0.5, 0) + 0.1, mgp = c(1.5, 0.4, 0)) + plot.gam(pisiHeightGam, scale = 0, scheme = 2) + + pisiDbhGam = fit_gam("REML GAM", DBH ~ s(TotalHt, bs = "ts", by = as.factor(isPlantation), k = 8, pc = gamConstraint), + #s(standBasalAreaApprox, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(tallerApproxBasalArea, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint) + # not significant + #s(elevation, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(slope, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(aspect, bs = "ts", k = 3, pc = gamConstraint) + # not significant + #s(topographicShelterIndex, bs = "ts", k = 3, pc = gamConstraint), # not significant + #s(relativeHeight, bs = "ts", by = as.factor(isPlantation), k = 3, pc = gamConstraint), # not significant + data = pisi2016, constraint = pisi2016gamConstraint, folds = 1, repetitions = 1) + k.check(pisiDbhGam) + summary(pisiDbhGam) + par(mfrow = c(1, 4), mar = c(2.2, 2.2, 0.5, 0) + 0.1, mgp = c(1.5, 0.4, 0)) + plot.gam(pisiDbhGam, scale = 0) +} + + +## random forest regression +if (htDiaOptions$includeInvestigatory) +{ + library(caret) + library(ranger) + #pisiForest = ranger(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger, pisi2016, classification = TRUE, num.threads = 12) + repeatedCrossValidation = trainControl(method = "repeatedcv", number = htDiaOptions$folds, repeats = htDiaOptions$repetitions, verboseIter = FALSE) + pisiHeightForest = train(TotalHt ~ DBH + standBasalAreaPerHectare + basalAreaLarger + elevation + slope + aspect + topographicShelterIndex + relativeDiameter, data = pisi2016, method = "ranger", trControl = repeatedCrossValidation, + importance = "impurity_corrected", + tuneGrid = expand.grid(mtry = c(6, 8), + splitrule = "variance", + min.node.size = c(1, 2))) + pisiHeightForest + varImp(pisiHeightForest) + + pisiDbhForest = train(DBH ~ TotalHt + standBasalAreaApprox + tallerApproxBasalArea + elevation + slope + aspect + topographicShelterIndex + relativeHeight, data = pisi2016, method = "ranger", trControl = repeatedCrossValidation, + importance = "impurity_corrected", + tuneGrid = expand.grid(mtry = c(7, 8), + splitrule = "variance", + min.node.size = c(2, 3, 4))) + pisiDbhForest + varImp(pisiDbhForest) +} + From ed8d149f1724854c900659677eaa58b3ce3f161e Mon Sep 17 00:00:00 2001 From: avii123-byte Date: Thu, 14 May 2026 13:04:16 -0700 Subject: [PATCH 13/13] updates for less abundant species --- trees/height-diameter/Questions.txt | 3 + trees/height-diameter/RHPU.R | 1 + trees/height-diameter/Species Composition.R | 68 +++++ trees/height-diameter/not_significant.R | 6 + trees/height-diameter/results.R | 270 +++++++++++++++++++- trees/height-diameter/setup.R | 28 +- 6 files changed, 339 insertions(+), 37 deletions(-) create mode 100644 trees/height-diameter/Questions.txt create mode 100644 trees/height-diameter/Species Composition.R create mode 100644 trees/height-diameter/not_significant.R diff --git a/trees/height-diameter/Questions.txt b/trees/height-diameter/Questions.txt new file mode 100644 index 0000000..313de59 --- /dev/null +++ b/trees/height-diameter/Questions.txt @@ -0,0 +1,3 @@ +Line 113 to 159, none of the model converged + +Getting NA values in AIC and parameters \ No newline at end of file diff --git a/trees/height-diameter/RHPU.R b/trees/height-diameter/RHPU.R index 8c22cf2..37cf97a 100644 --- a/trees/height-diameter/RHPU.R +++ b/trees/height-diameter/RHPU.R @@ -163,6 +163,7 @@ if (htDiaOptions$includeInvestigatory) #print(rhpuHeightFromDiameterResults %>% select(-responseVariable, -species, -fixedWeight, -n, -power, -significant, -contains("NaturalRegen"), -contains("Plantation")), n = 30) ggplot() + geom_point(aes(x = rhpu2016$DBH, y = rhpu2016$TotalHt), alpha = 0.10, color = "grey25", shape = 16) + + geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$linear), color = "linear", group = rhpu2016$isPlantation), alpha = 0.5) #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$sharmaZhang), color = "Sharma-Zhang", group = rhpu2016$isPlantation), alpha = 0.5) + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$sharmaParton), color = "Sharma-Parton", group = rhpu2016$isPlantation), alpha = 0.5) + #geom_line(aes(x = rhpu2016$DBH, y = predict(rhpuHeightFromDiameter$chapmanRichards), color = "Chapman-Richards", group = rhpu2016$isPlantation)) + diff --git a/trees/height-diameter/Species Composition.R b/trees/height-diameter/Species Composition.R new file mode 100644 index 0000000..8627290 --- /dev/null +++ b/trees/height-diameter/Species Composition.R @@ -0,0 +1,68 @@ +library(dplyr) +library(ggplot2) +library(readr) +library(cowplot) + +# Read your dataset +df <- read_csv("Elliott_timber_cruise_2015-16.csv") # Replace with your file path + +# Filter NA values +filtered_df <- df %>% + filter(!is.na(totalHt), !is.na(DBH)) + +# Define species full names +species_lookup <- c( + "PSME" = "Douglas-fir", + "ALRU2" = "Red alder", + "TSHE" = "Western hemlock", + "ACMA3" = "Bigleaf maple", + "UMCA" = "California bay", + "THPL" = "Western redcedar", + "PISI" = "Sitka spruce", + "RHPU" = "Cascara buckthorn", + "ARME" = "Pacific madrone", + "Other" = "Other" +) + +# Summarize counts with full name labels +species_counts <- filtered_df %>% + mutate(species_category = ifelse(species %in% names(species_lookup), species, "Other")) %>% + count(species_category, name = "count") %>% + mutate( + species_full = species_lookup[species_category], + species_full = factor(species_full, levels = species_lookup[unique(species_category)]) + ) + +# MAIN BARPLOT +main_bar <- ggplot(species_counts, aes(x = species_full, y = count)) + + geom_col(fill = "darkgrey") + + geom_text(aes(label = count), vjust = -0.5, size = 4)+ + labs(title = "Overall Species Composition", x = "Species", y = "Number of Trees") + + theme_minimal(base_size = 14) + + theme(axis.text.x = element_text(angle = 45, hjust = 1,size=16)) + +# ZOOMED-IN BARPLOT FOR RARE SPECIES +zoom_species <- species_counts %>% + filter(species_category %in% c("ARME", "RHPU", "PISI")) + +zoom_bar <- ggplot(zoom_species, aes(x = species_full, y = count)) + + geom_col(fill = "darkorange") + + geom_text(aes(label = count), vjust = -0.5, size = 3.5)+ + labs(title = "Species of Interest", x = NULL, y = NULL) + + theme_minimal(base_size = 9) + + theme( + axis.text.x = element_text(size=12,angle = 30, hjust = 1), + plot.title = element_text(size = 12, face = "bold") + ) + +# COMBINE PLOTS WITH SMALLER INSET +final_plot <- ggdraw() + + draw_plot(main_bar, 0, 0, 1, 1) + + draw_plot(zoom_bar, x = 0.68, y = 0.68, width = 0.28, height = 0.28) + +# Show it +print(final_plot) + +# Save final plot to PNG +ggsave("species_composition_inset.png", plot = final_plot, width = 10, height = 7, dpi = 300) + diff --git a/trees/height-diameter/not_significant.R b/trees/height-diameter/not_significant.R new file mode 100644 index 0000000..f8a522a --- /dev/null +++ b/trees/height-diameter/not_significant.R @@ -0,0 +1,6 @@ + + +#get the models that are not significant from base model + +temp<-heightDiameterResults %>% group_by(responseVariable,species) %>% filter(significant=="FALSE") %>% reframe(unique(name)) +write.csv(temp,"not_significant.csv") diff --git a/trees/height-diameter/results.R b/trees/height-diameter/results.R index d841afa..dd3b3c2 100644 --- a/trees/height-diameter/results.R +++ b/trees/height-diameter/results.R @@ -15,9 +15,9 @@ speciesGroupColors = c("forestgreen", "red2", "blue2", "green3", "mediumorchid1" # if (exists("umcaResults") == FALSE) { load("trees/height-diameter/data/UMCA results.Rdata") } # if (exists("otherResults") == FALSE) { load("trees/height-diameter/data/other results.Rdata") } if (exists("PSME Results") == FALSE) { load("data/PSME results.Rdata") } -if (exists("rhpuResults") == FALSE) { load("data/arme results.Rdata") } -if (exists("rhpuResults") == FALSE) { load("data/pisi results.Rdata") } -if (exists("rhpuResults") == FALSE) { load("data/arme results.Rdata") } +if (exists("rhpuResults") == FALSE) { load("data/rhpu results.Rdata") } +if (exists("pisiResults") == FALSE) { load("data/pisi results.Rdata") } +if (exists("armeResults") == FALSE) { load("data/arme results.Rdata") } ## assemble results tibbles from individual species data # heightDiameterResults = bind_rows(psmeResults, alruResults, tsheResults, acmaResults, # umcaResults, thplResults, otherResults) %>% @@ -37,23 +37,32 @@ if (exists("rhpuResults") == FALSE) { load("data/arme results.Rdata") } # ungroup() heightDiameterResults = bind_rows(rhpuResults,armeResults,pisiResults,psmeResults) %>% - mutate(baseName = if_else(word(name) %in% c("REML", "modified", "unified"), paste(word(name, 1), word(name, 2)), word(name)), #simply paste the names of the model from the tibble as required + mutate(baseName = if_else(word(name) %in% c("REML", "modified", "unified"), paste(word(name, 1), word(name, 2)), word(name)), #check the words in name column, IF the name contains any of the three: "REML", "modified", "unified", paste the first word of the name and secod word of the name, ELSE paste all the words in the name. species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar","cascara buckthorn","sitka spruce","pacific madrone", "other species"), levels = c("PSME", "alru2", "tshe", "acma3", "umca", "thpl", "rhpu","pisi","arme", "other")), speciesFraction = recode(species, "Douglas-fir" = 0.750, "red alder" = 0.101, "western hemlock" = 0.056, "bigleaf maple" = 0.029, "Oregon myrtle" = 0.025, "western redcedar" = 0.013, "cascara buckthorn"= 0.007, "sitka spruce"=0.006, "pacific madrone" = 0.004,"other species" = 0.009), - isBaseForm = (str_detect(name, "Sharma-") == FALSE) & (str_detect(name, "ABA\\+T") == FALSE) & (str_detect(name, "BA\\+L") == FALSE) & (str_detect(name, "physio") == FALSE) & (str_detect(name, "RelDbh") == FALSE) & (str_detect(name, "RelHt") == FALSE), + isBaseForm = (str_detect(name, "Sharma-") == FALSE) & (str_detect(name, "ABA\\+T") == FALSE) & (str_detect(name, "BA\\+L") == FALSE) & (str_detect(name, "physio") == FALSE) & (str_detect(name, "RelDbh") == FALSE) & (str_detect(name, "RelHt") == FALSE), #str_detect()--string detect hasPhysio = str_detect(name, "physio"), hasStand = str_detect(name, "ABA\\+T") | str_detect(name, "BA\\+L"), hasRelative = str_detect(name, "RelDbh") | str_detect(name, "RelHt"), significant = as.logical(significant), # since R lacks NA_logical_ significant can end up being either of type double (0/1/NA_real_) or logical (TRUE/FALSE), standardize back to logical (TRUE/FALSE/NA) weighting = if_else(fitting %in% c("gnls", "nlrob"), "reweighted", "fixed weights"), sizeShapeAlpha = as.factor(if_else(significant == TRUE, weighting, "not significant"))) %>% - group_by(fitSet, fixedWeight, responseVariable, species) %>% - mutate(nFits = n(), + group_by(fitSet, fixedWeight, responseVariable, species) %>% #groups based on unique combination of these, if I have 2 fitSet, 3 fixedWeight, 2 responseVariable, 4 species, I will get 2*3*2*4 =48 groups within the data. + mutate(nFits = n(), # in each of these groups, create a column nFits and put a value equal to the length of the data frame. deltaAicN = aic/nValidation - min(aic/nValidation, na.rm = TRUE)) %>% # ΔAIC within response variable and species, needed for AUCs and figures ungroup() # report duplicate naming and fit failures heightDiameterResults %>% group_by(fitSet, responseVariable, species, name) %>% summarize(n = n(), .groups = "drop") %>% filter(n != htDiaOptions$folds * htDiaOptions$repetitions) +# A tibble: 4 × 5 +# fitSet responseVariable species name n +# +# 1 primary DBH Douglas-fir Schnute inverse 1 +# 2 primary DBH cascara buckthorn Schnute inverse 1 +# 3 primary DBH sitka spruce Schnute inverse 1 +# 4 primary DBH pacific madrone Schnute inverse 1 + +#this tells us that, the Schnute inverse model did not run the 10*10 fits for each model within the species. # heightDiameterCoefficients = left_join(bind_rows(psmeCoefficients, alruCoefficients, tsheCoefficients, acmaCoefficients, # ~28 s # umcaCoefficients, thplCoefficients, otherCoefficients) %>% @@ -64,14 +73,14 @@ heightDiameterResults %>% group_by(fitSet, responseVariable, species, name) %>% # select(-weighting, -sizeShapeAlpha, -nFits, -nTaperImplausible, -speciesFraction) %>% # relocate(responseVariable, species, fitSet, fixedWeight, name, significant, isBaseForm, hasRelative, hasStand, hasPhysio, fitting, repetition, fold, nObservations, nValidation, fitTimeInS, isConverged, effectiveDegreesOfFreedom, nNonPhysical, mab, mapb, mae, mape, rmse, rmspe, aic, deltaAicN, nse, meanAbsolutePlantationEffect, meanAbsolutePercentPlantationEffect, a0, a1, a1p, a2, a2p, a3, a3p, a4, a5, a6, a7, a8, a9, a9p, a10, a10p, b1, b1p, b2, b2p, b3, b3p, b4, b4p) -heightDiameterCoefficients = left_join(bind_rows(rhpuCoefficients,pisiCoefficients,armeCoefficients,psmeCoefficients # ~28 s +heightDiameterCoefficients = left_join(bind_rows(psmeCoefficients,rhpuCoefficients,pisiCoefficients,armeCoefficients # ~28 s ) %>% mutate(species = factor(species, labels = c("Douglas-fir", "red alder", "western hemlock", "bigleaf maple", "Oregon myrtle", "western redcedar","cascara buckthorn","sitka spruce","pacific madrone", "other species"), levels = c("psme", "alru2", "tshe", "acma3", "umca", "thpl","rhpu","pisi","arme", "other"))), heightDiameterResults %>% select(-fitting, -fixedWeight, -significant), # no need to join duplicate columns by = join_by(fitSet, responseVariable, species, name, repetition, fold)) %>% mutate(isConverged = as.logical(isConverged)) %>% select(-weighting, -sizeShapeAlpha, -nFits, -nTaperImplausible, -speciesFraction) %>% - relocate(responseVariable, species, fitSet, fixedWeight, name, significant, isBaseForm, hasRelative, hasStand, hasPhysio, fitting, repetition, fold, nObservations, nValidation, fitTimeInS, isConverged, effectiveDegreesOfFreedom, nNonPhysical, mab, mapb, mae, mape, rmse, rmspe, aic, deltaAicN, nse, meanAbsolutePlantationEffect, meanAbsolutePercentPlantationEffect, a0, a1, a1p, a2, a2p, a3, a3p, a4, a8, a9, a9p, a10, b1, b1p, b2, b2p, b3, b4) + relocate(responseVariable, species, fitSet, fixedWeight, name, significant, isBaseForm, hasRelative, hasStand, hasPhysio, fitting, repetition, fold, nObservations, nValidation, fitTimeInS, isConverged, effectiveDegreesOfFreedom, nNonPhysical, mab, mapb, mae, mape, rmse, rmspe, aic, deltaAicN, nse, meanAbsolutePlantationEffect, meanAbsolutePercentPlantationEffect, a0, a1, a1p, a2, a2p, a3, a3p, a4, a5, a6, a7, a8, a9, a9p, a10, a10p, b1, b1p, b2, b2p, b3, b3p, b4, b4p) #write_xlsx(heightDiameterCoefficients %>% # filter(fitSet == "primary", is.na(fixedWeight)) %>% # select(-baseName, -fitSet, -fixedWeight, -aict, -bic, -bict, -bias, -ends_with("NaturalRegen"), -ends_with("Plantation"), -adaptiveWeightFraction) %>% # drop diagnostic columns @@ -99,30 +108,263 @@ primaryResults %>% group_by(fitSet, species) %>% summarize(deltaAicN = sum(is.na # 16 20.4 +######################################## + +#########NOT USED +library(dplyr) +library(purrr) +library(tibble) +library(WeightedROC) + +# 1. a robust pairwise_auc() that (a) skips degenerate cases, (b) jitters ties, +# (c) catches errors and returns NA if needed +pairwise_auc <- function(a, b, metric, lower_is_better = TRUE){ + # assemble + df <- tibble( + guess = c(a[[metric]], b[[metric]]), + label = c(rep(0, nrow(a)), rep(1, nrow(b))) + ) %>% + filter(!is.na(guess), !is.na(label)) + + # need at least two labels *and* two distinct guesses + if(length(unique(df$label)) < 2 || length(unique(df$guess)) < 2){ + return(NA_real_) + } + + # force numeric labels, break ties + df$label <- as.integer(df$label) + df$guess <- jitter(df$guess, factor = 1e-8) + + # compute AUC, catching any monotonicity errors + roc_obj <- WeightedROC(df$guess, df$label) + tryCatch( + WeightedAUC(roc_obj), + error = function(e) NA_real_ + ) +} + +# 2. now loop over each responseVariable/species group, and for each model form +# compute its AUC vs. the union of all *other* fits in the same group +auc_summary <- primaryResults %>% + filter(nse != -Inf) %>% + group_by(responseVariable, species) %>% + group_map( + ~ { + df_grp <- .x + model_names <- unique(df_grp$name) + map_dfr(model_names, function(mn){ + this_fit <- filter(df_grp, name == mn) + others <- filter(df_grp, name != mn) + tibble( + responseVariable = df_grp$responseVariable[1], + species = df_grp$species[1], + name = mn, + aucMab = pairwise_auc(this_fit, others, "mab", lower_is_better = TRUE), + aucMae = pairwise_auc(this_fit, others, "mae", lower_is_better = TRUE), + aucRmse = pairwise_auc(this_fit, others, "rmse", lower_is_better = TRUE), + aucNse = pairwise_auc(this_fit, others, "nse", lower_is_better = FALSE) + ) + }) + }, + .keep = TRUE + ) %>% + bind_rows() + +# 3. inspect the result +print(auc_summary, n = 50) + + + + +####################################### + +##########USED PAIRWISE AUCS +# Load required libraries +library(ggplot2) +library(tidyr) +library(dplyr) + +# STEP 1: Reshape to long format +auc_long <- auc_summary %>% + pivot_longer( + cols = c(aucMab, aucMae, aucRmse, aucNse), + names_to = "metric", + values_to = "auc_value" + ) + +# STEP 2: Loop over combinations of responseVariable and species +combo_list <- unique(auc_long[, c("responseVariable", "species")]) + +# Optional: Create directory to save plots +# dir.create("AUC_heatmaps", showWarnings = FALSE) + +# STEP 3: Loop and plot +for (i in seq_len(nrow(combo_list))) { + + rv <- combo_list$responseVariable[i] + sp <- combo_list$species[i] + + plot_data <- auc_long %>% + filter(responseVariable == rv, species == sp) + + p <- ggplot(plot_data, aes(x = metric, y = reorder(name, auc_value), fill = auc_value)) + + geom_tile(color = "white") + + scale_fill_viridis_c(option = "C", direction = -1) + + scale_x_discrete(expand = c(0, 0)) + # compress horizontally + scale_y_discrete(expand = c(0, 0)) + # compress vertically + labs( + title = paste("Metrics Heatmap:", rv, "-", sp), + x = "Metric", + y = "Model", + fill = "AUC Value" + ) + + theme_minimal(base_size = 14) + + theme( + axis.text.y = element_text(size = 10), + axis.text.x = element_text(size = 8), + plot.title = element_text(hjust = 0.5, face = "bold", size = 16), + legend.position = "right" + ) + + coord_fixed(ratio = 0.3) # adjust height vs width + + + print(p) # Show in RStudio + + # Optional: Save to PNG — uncomment this line if you want to save + ggsave( + filename = paste0("AUC_", gsub(" ", "_", rv), "_", gsub(" ", "_", sp), ".jpeg"), + plot = p, width =6, height = 8, dpi = 300 + # path = "AUC_heatmaps" # if using a subfolder + ) +} + + + +############################################# + +#########USED-PREFERRED MODELS +library(ggplot2) +library(dplyr) +library(tidyr) + +# STEP 1: Reshape to long format +auc_long <- auc_summary %>% + pivot_longer(cols = c(aucMab, aucMae, aucRmse, aucNse), + names_to = "metric", values_to = "auc_value") + +# STEP 2: Keep only models common to all species within each responseVariable +common_models <- auc_long %>% + group_by(responseVariable, name) %>% + summarise(n_species = n_distinct(species), .groups = "drop") %>% + inner_join(auc_long %>% count(responseVariable, species) %>% group_by(responseVariable) %>% summarise(n_species = n()), + by = "responseVariable") %>% + filter(n_species.x == n_species.y) %>% + select(responseVariable, name) + +auc_long_common <- auc_long %>% + semi_join(common_models, by = c("responseVariable", "name")) + +# STEP 3: Rank each metric appropriately +auc_ranked <- auc_long_common %>% + group_by(responseVariable, species, metric) %>% + mutate(rank = case_when( + metric %in% c("aucMab", "aucMae", "aucRmse") ~ rank(auc_value), # lower is better + metric == "aucNse" ~ rank(-auc_value), # higher is better + TRUE ~ NA_real_ + )) %>% + ungroup() + +# STEP 4: Calculate total rank and select top 3 models per species/response +auc_total_rank <- auc_ranked %>% + group_by(responseVariable, species, name) %>% + summarise(total_rank = sum(rank), mean_auc = mean(auc_value, na.rm = TRUE), .groups = "drop") + +top_models <- auc_total_rank %>% + group_by(responseVariable, species) %>% + slice_min(total_rank, n = 3) %>% + mutate(is_top = TRUE) %>% + ungroup() + +# STEP 5: Prepare final plot data +plot_data <- auc_ranked %>% + left_join(top_models %>% select(responseVariable, species, name, is_top), + by = c("responseVariable", "species", "name")) %>% + mutate(is_top = if_else(is.na(is_top), FALSE, is_top)) + +# Order models by average AUC for consistent y-axis +avg_auc <- plot_data %>% + group_by(name) %>% + summarise(avg_auc = mean(auc_value, na.rm = TRUE), .groups = "drop") + +plot_data <- plot_data %>% + left_join(avg_auc, by = "name") + +# STEP 6: Plot for each responseVariable +unique_vars <- unique(plot_data$responseVariable) + +for (rv in unique_vars) { + plot_subset <- plot_data %>% filter(responseVariable == rv) + + p <- ggplot(plot_subset, aes(x = species, y = reorder(name, avg_auc), fill = auc_value)) + + geom_tile(color = "white") + + geom_tile(data = plot_subset %>% filter(is_top), color = "black", size = 1.1) + + scale_fill_viridis_c(option = "C", direction = -1, na.value = "grey90") + + facet_wrap(~ metric, nrow = 1) + + labs( + title = paste("Model Performance Heatmap (Top 3) —", rv), + x = "Species", y = "Model", fill = "AUC Value" + ) + + theme_minimal(base_size = 13) + + theme( + axis.text.x = element_text(angle = 45, hjust = 1, size = 10), + axis.text.y = element_text(size = 5), + strip.text = element_text(size = 11, face = "bold"), + plot.title = element_text(size = 16, face = "bold", hjust = 0.5) + ) + + print(p) + + ggsave(filename = paste0("Top3_Models_", gsub(" ", "_", rv), ".jpeg"), + plot = p, width = 10, height = 8, dpi = 300) +} + + +################################ + + with_progress({ crossValidatedModelCount = primaryResults %>% group_by(responseVariable, species) %>% summarize(n = n_distinct(name), .groups = "drop") progressBar = progressor(steps = sum(crossValidatedModelCount$n)) heightDiameterModelAucs = primaryResults %>% + # fitResults = primaryResults %>% #added later + # filter(nse != -Inf) %>% #added later group_by(responseVariable, species, name) %>% group_split() %>% future_map_dfr(function(fitResults) #future_map_dfr applies a function to multiple data frames created from above group_by function. { + #fitResults=heightDiameterModelAucs[[1]] #added code to test line by line if ((nrow(fitResults) == 1) | all(is.na(fitResults$nse))) { # no distribution to compare to since this model has only a no fit result or wasn't cross validated progressBar(str_pad(paste(fitResults$responseVariable[1], fitResults$species[1], fitResults$name[1]), 60, "right")) - return(tibble(responseVariable = fitResults$responseVariable[1], species = fitResults$species[1], name = fitResults$name[1], - otherModelName = NA_character_, fitting = fitResults$fitting[1], isBaseForm = fitResults$isBaseForm[1], hasPhysio = fitResults$hasPhysio[1], hasStand = fitResults$hasStand[1], hasRelative = fitResults$hasRelative[1], - aucDeltaAicN = NA_real_, aucMab = NA_real_, aucMae = NA_real_, aucNse = NA_real_, aucRmse = NA_real_, - speciesFraction = fitResults$speciesFraction[1])) + # return(tibble(responseVariable = fitResults$responseVariable[1], species = fitResults$species[1], name = fitResults$name[1], + # otherModelName = NA_character_, fitting = fitResults$fitting[1], isBaseForm = fitResults$isBaseForm[1], hasPhysio = fitResults$hasPhysio[1], hasStand = fitResults$hasStand[1], hasRelative = fitResults$hasRelative[1], + # aucDeltaAicN = NA_real_, aucMab = NA_real_, aucMae = NA_real_, aucNse = NA_real_, aucRmse = NA_real_, + # speciesFraction = fitResults$speciesFraction[1])) + library(tibble) #create a tibble to see how does it look + tibble_x=tibble(responseVariable = fitResults$responseVariable[1], species = fitResults$species[1], name = fitResults$name[1], + otherModelName = NA_character_, fitting = fitResults$fitting[1], isBaseForm = fitResults$isBaseForm[1], hasPhysio = fitResults$hasPhysio[1], hasStand = fitResults$hasStand[1], hasRelative = fitResults$hasRelative[1], + aucDeltaAicN = NA_real_, aucMab = NA_real_, aucMae = NA_real_, aucNse = NA_real_, aucRmse = NA_real_, + speciesFraction = fitResults$speciesFraction[1]) } # get all other cross-validation results for this response variable and species # Assumes no names are shared across fittings in the results set. - matchingFitResults = primaryResults %>% filter(responseVariable == fitResults$responseVariable[1], species == fitResults$species[1]) + matchingFitResults = primaryResults %>% filter(responseVariable == fitResults$responseVariable[1], species == fitResults$species[1]) #for one set of species and response variable matchingModelNames = unique(matchingFitResults$name) pairwiseAucs = bind_rows(lapply(matchingModelNames, function(otherModelName) { + otherModelName=matchingFitResults$name otherFitResults = matchingFitResults %>% filter(name == otherModelName) if ((nrow(otherFitResults) == 1) | all(is.na(otherFitResults$nse))) diff --git a/trees/height-diameter/setup.R b/trees/height-diameter/setup.R index b66b20b..50a9236 100644 --- a/trees/height-diameter/setup.R +++ b/trees/height-diameter/setup.R @@ -1444,7 +1444,7 @@ plot_exploratory = function(liveUnbrokenTrees, titleLetters = plotLetters, speci #geom_path(aes(x = diameterClass, y = median, color = "median height", linetype = "median height"), dbhQuantiles %>% filter(count > 10), na.rm = TRUE) + geom_path(aes(x = mean, y = heightClass, color = "mean DBH", linetype = "mean DBH"), heightQuantiles %>% filter(count > 10), na.rm = TRUE) + #geom_path(aes(x = median, y = heightClass, color = "median DBH", linetype = "median DBH"), heightQuantiles %>% filter(count > 10), na.rm = TRUE) + - coord_cartesian(xlim = c(0, 250), ylim = c(0, 80)) + + coord_cartesian(xlim = c(0, 250), ylim = c(0, 40)) + labs(x = dbhXlabel, y = "height, m, of unbroken stem", color = NULL, fill = "trees\nmeasured", linetype = NULL, title = bquote(.(titleLetters[1])~.(speciesLabel))) + #labs(x = dbhXlabel, y = "height, m, of unbroken stem", color = NULL, fill = "trees\nmeasured", linetype = NULL, title = bquote(bold(.(titleLetters[1]))~.(speciesLabel))) + guides(color = guide_legend(order = 1), fill = guide_colorbar(order = 2), linetype = guide_legend(order = 1)) + @@ -1495,7 +1495,7 @@ plot_exploratory = function(liveUnbrokenTrees, titleLetters = plotLetters, speci geom_path(aes(x = heightClass, y = 100 * (q80 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + #geom_path(aes(x = heightClass, y = 100 * (q90 - mean) / mean^dbhPower, color = "10% contour", linetype = "10% contour"), na.rm = TRUE, linewidth = 0.3) + geom_path(aes(x = heightClass, y = 100 * (max - mean) / mean^dbhPower, color = "max or min", linetype = "max or min"), na.rm = TRUE, linewidth = 0.3) + - coord_cartesian(xlim = c(0, 80), ylim = c(-50, 150)) + + coord_cartesian(xlim = c(0, 0), ylim = c(-50, 150)) + guides(alpha = guide_legend(order = 1, override.aes = list(fill = "grey30")), color = guide_legend(order = 2), linetype = guide_legend(order = 2)) + scale_alpha_manual(breaks = c("95% probability", "80% probability", "50% probability"), values = c(0.1, 0.2, 0.3)) + scale_color_manual(breaks = c("10% contour", "max or min"), values = c("grey50", "grey70")) + @@ -2105,32 +2105,14 @@ if (htDiaOptions$includeInvestigatory) { ## Figures A1-4: species level exploratory plots plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "DF"), speciesLabel = "Douglas-fir", maxTreesMeasured = 150, omitLegends = TRUE, omitXlabels = TRUE) / - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RA"), speciesLabel = "red alder", maxTreesMeasured = 150, distributionLegendPositionY = 0.92) + + plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "SS"), speciesLabel = "sitka spruce", maxTreesMeasured = 150, distributionLegendPositionY = 0.92) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("figures/Figure A1 PSME-ALRU2.png", height = 13, width = 20, units = "cm", dpi = 250) - - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "WH"), speciesLabel = "western hemlock", maxTreesMeasured = 150, omitLegends = TRUE) / - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "BM"), speciesLabel = "bigleaf maple", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, ) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("figures/Figure A2 TSHE-ACMA3.png", height = 13, width = 20, units = "cm", dpi = 250) - - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "OM"), speciesLabel = "Oregon myrtle", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, omitXlabels = TRUE) / - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "RC"), speciesLabel = "western redcedar", maxTreesMeasured = 150, omitLegends = TRUE) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("figures/Figure A3 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) - - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "other"), speciesLabel = "other species ", distributionLegendPositionY = 0.92) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("figures/Figure A4 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + ggsave("figures/Figure A1 PSME-PISI.png", height = 13, width = 20, units = "cm", dpi = 250) plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "CB"), speciesLabel = "Cascara buckthorn", maxTreesMeasured = 150, distributionLegendPositionY = 0.92, omitXlabels = TRUE) / plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "PM"), speciesLabel = "Pacific madrone", maxTreesMeasured = 150, omitLegends = TRUE) + plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("figures/Figure A5 UMCA-THPL.png", height = 13, width = 20, units = "cm", dpi = 250) - - plot_exploratory(trees2016 %>% filter(isLiveUnbroken, speciesGroup == "SS"), speciesLabel = "sitka spruce ", distributionLegendPositionY = 0.92) + - plot_annotation(theme = theme(plot.margin = margin(1, 1, 1, 1, "pt"))) - ggsave("figures/Figure A6 other species.png", height = 1/3*(18 - 1) + 1, width = 20, units = "cm", dpi = 250) + ggsave("figures/Figure A2 RHPU-ARME.png", height = 13, width = 20, units = "cm", dpi = 250) }