├── .Rbuildignore ├── .github └── workflows │ ├── apt.txt │ └── ubuntu.yml ├── .gitignore ├── Bayesian_LSP.Rproj ├── DESCRIPTION ├── Dockerfile ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── R ├── base.R ├── dat_dl_point_ts.R ├── data.R ├── hlp_funs.R ├── mod_fit.R ├── models.R ├── utils-pipe.R └── vis_fit.R ├── README.md ├── blsp-logo.svg ├── data └── landsatEVI2.rda ├── docker-compose.yaml ├── gee ├── getSampleData.js └── sampleData.csv ├── img ├── model_fit_more_phenos.png ├── model_fit_phenos.png └── model_fit_plot.png ├── man ├── BLSPFitted.Rd ├── FitAvgModel.Rd ├── FitBLSP.Rd ├── FitBLSP_spring.Rd ├── GetEvi2PointTs.Rd ├── GetModel.Rd ├── PlotAvg.Rd ├── PlotBLSP.Rd ├── SanityCheck.Rd ├── figures │ └── logo.png ├── landsatEVI2.Rd └── pipe.Rd ├── requirements └── requirements.R ├── scripts ├── build.sh └── test.sh ├── tests ├── testthat.R └── testthat │ ├── test-dat_cl.R │ ├── test-dat_dl.R │ └── test-mod_fit.R └── vignettes ├── .gitignore ├── geeResults.png ├── introduction.Rmd └── mpcResults.png /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^blsp\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^LICENSE\.md$ 4 | ^README\.Rmd$ 5 | ^doc$ 6 | ^Meta$ 7 | 8 | 9 | ^.github$ 10 | ^Dockerfile$ 11 | ^requirements$ 12 | ^scripts$ 13 | ^docker-compose.yaml$ 14 | ^img$ 15 | ^Bayesian_LSP.Rproj$ 16 | ^gee$ 17 | ^blsp-logo.svg$ -------------------------------------------------------------------------------- /.github/workflows/apt.txt: -------------------------------------------------------------------------------- 1 | jags 2 | gdal-bin 3 | build-essential 4 | libgdal-dev 5 | libssl-dev 6 | libxml2-dev 7 | libudunits2-dev 8 | libprotobuf-dev 9 | protobuf-compiler 10 | libjq-dev 11 | libgeos-dev 12 | libgdal-dev 13 | libv8-dev 14 | 15 | libmagick++-dev 16 | libfontconfig1-dev 17 | libharfbuzz-dev 18 | libfribidi-dev 19 | -------------------------------------------------------------------------------- /.github/workflows/ubuntu.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: Ubuntu R 4 | 5 | # Controls when the workflow will run 6 | on: 7 | # Triggers the workflow on push or pull request events but only for the main 8 | # branch 9 | push: 10 | branches: [ main ] 11 | pull_request: 12 | branches: [ main ] 13 | 14 | # Allows you to run this workflow manually from the Actions tab 15 | workflow_dispatch: 16 | 17 | # A workflow run is made up of one or more jobs that can run sequentially or in 18 | # parallel 19 | jobs: 20 | # This workflow contains a single job called "build" 21 | build: 22 | # The type of runner that the job will run on 23 | runs-on: ubuntu-latest 24 | strategy: 25 | matrix: 26 | r-version: ['4.2.1'] 27 | 28 | # Steps represent a sequence of tasks that will be executed as part of the 29 | # job 30 | steps: 31 | - uses: actions/checkout@v2 32 | - uses: conda-incubator/setup-miniconda@v2 33 | with: 34 | activate-environment: test 35 | python-version: 3.8 36 | auto-activate-base: false 37 | - name: install system dependencies 38 | shell: bash 39 | run: | 40 | sudo apt-get update -y 41 | sudo apt-get install -y wget git gawk findutils 42 | xargs -a <(awk '! /^ *(#|$)/' ".github/workflows/apt.txt") -r -- \ 43 | sudo apt-get install -y --no-install-recommends --no-install-suggests 44 | 45 | # Steps to install R dependencies 46 | - uses: actions/checkout@v3 47 | - name: Set up R ${{ matrix.r-version }} 48 | uses: r-lib/actions/setup-r@v2 49 | with: 50 | r-version: ${{ matrix.r-version }} 51 | 52 | - name: Install dependencies 53 | run: | 54 | ./requirements/requirements.R 55 | shell: bash 56 | 57 | - name: Load package and run test 58 | run: | 59 | devtools::test() 60 | shell: Rscript {0} 61 | 62 | 63 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .Rproj.user 3 | .Rhistory 4 | inst/doc 5 | /doc/ 6 | /Meta/ 7 | zzz* -------------------------------------------------------------------------------- /Bayesian_LSP.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: blsp 2 | Title: A Bayesian land surface phenology model 3 | Version: 1.0 4 | Authors@R: 5 | person(given = "First", 6 | family = "Last", 7 | role = c("aut", "cre"), 8 | email = "first.last@example.com", 9 | comment = c(ORCID = "YOUR-ORCID-ID")) 10 | Description: Acquires Landsat and Sentinel-2 surface reflectance time series data and 11 | applies the Bayesian land surface phenology model developed in Gao et al., 2021. 12 | License: MIT + file LICENSE 13 | Encoding: UTF-8 14 | LazyData: true 15 | Roxygen: list(markdown = TRUE) 16 | RoxygenNote: 7.3.1 17 | Imports: 18 | coda, 19 | data.table, 20 | httr, 21 | jsonlite, 22 | lubridate, 23 | minpack.lm, 24 | rjags, 25 | tools, 26 | viridis, 27 | magrittr, 28 | terra, 29 | rstac 30 | Suggests: 31 | knitr, 32 | rmarkdown, 33 | testthat (>= 3.0.0) 34 | Config/testthat/edition: 3 35 | Depends: 36 | R (>= 3.5.0) 37 | VignetteBuilder: knitr 38 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # Use offical r image with r version algorithm was tested on 2 | FROM r-base:3.6.2 3 | 4 | WORKDIR /Bayesian_LSP 5 | 6 | COPY . /Bayesian_LSP 7 | 8 | # Install dependencies 9 | RUN apt-get update && \ 10 | apt install -y jags && \ 11 | Rscript ./requirements/requirements.R 12 | 13 | # Make directory for data just incase tests need outputs 14 | CMD mkdir /data 15 | 16 | # tests 17 | # CMD [ "./test.sh" ] 18 | 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2022 2 | COPYRIGHT HOLDER: blsp authors 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2022 blsp authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export("%>%") 4 | export(BLSPFitted) 5 | export(FitAvgModel) 6 | export(FitBLSP) 7 | export(FitBLSP_spring) 8 | export(GetEvi2PointTs) 9 | export(PlotAvg) 10 | export(PlotBLSP) 11 | import(data.table) 12 | importFrom(magrittr,"%>%") 13 | -------------------------------------------------------------------------------- /R/base.R: -------------------------------------------------------------------------------- 1 | #******************************************************************************* 2 | # Description: Needed library and pre-defined functions 3 | # Date: 2020-11-22 4 | #******************************************************************************* 5 | 6 | .datatable.aware <- TRUE 7 | 8 | usethis::use_pipe(export = TRUE) 9 | 10 | 11 | -------------------------------------------------------------------------------- /R/dat_dl_point_ts.R: -------------------------------------------------------------------------------- 1 | #****************************************************************************** 2 | # Description: Download Landsat point time series using Microsoft Planetary 3 | # Computer with STAC API. 4 | # 5 | # Date: 2022-11-02 6 | #****************************************************************************** 7 | 8 | 9 | #' Calculate EVI2 values. 10 | #' 11 | #' @param nir_val NIR band value. 12 | #' @param red_val RED band value. 13 | #' @return EVI2 values. 14 | #' @noRd 15 | CalEVI2 <- function(nir_val, red_val) { 16 | red <- red_val * 0.0000275 - 0.2 17 | nir <- nir_val * 0.0000275 - 0.2 18 | 19 | evi2 <- 2.5 * ((nir - red) / (1 + nir + 2.4 * red)) 20 | 21 | return(as.numeric(evi2)) 22 | } 23 | 24 | 25 | #' Parse Landsat cloud and snow QA values. 26 | #' 27 | #' @param x The QA value. 28 | #' @return A list with logic values indicating `fill`, `cloud`, `cloudShadow`, 29 | #' and `snow`. 30 | #' @noRd 31 | LandsatCloudSnowQA <- function(x) { 32 | ## Bit 0 - if pixel is fill, then true 33 | fill <- ifelse(bitwAnd(x, 1), TRUE, FALSE) 34 | ## Bit 3 - if cloud, then true 35 | cloud <- ifelse(bitwAnd(bitwShiftR(x, 3), 1), TRUE, FALSE) 36 | ## Bit 4 - if cloud shadow, then true 37 | cloudShadow <- ifelse(bitwAnd(bitwShiftR(x, 4), 1), TRUE, FALSE) 38 | ## Bit 5 - if snow, then true 39 | snow <- ifelse(bitwAnd(bitwShiftR(x, 5), 1), TRUE, FALSE) 40 | 41 | return(list(fill = fill, 42 | cloud = cloud, cloudShadow = cloudShadow, 43 | snow = snow 44 | )) 45 | } 46 | 47 | #' Use Microsoft Planetary Computer with STAC API to get Landsat EVI2 time 48 | #' series for any point location specified by longitude and latitude. 49 | #' 50 | #' @param pt_coords Point location. Longitude and latitude. 51 | #' @param focalDates Temporal period. 52 | #' @param ncores Number of cores used to parallel the process. 53 | #' @return A data.table containing EVI2 time series along with QA values. 54 | #' @export 55 | #' @import data.table 56 | #' 57 | #' @examples 58 | #' \dontrun{ 59 | #' pt_coords <- data.table::data.table(x = -71.700975, y = 43.945733) 60 | #' focalDates <- "1984-01-01/1989-06-04" 61 | #' ncores <- 5 62 | #' val_dt <- GetEvi2PointTs(pt_coords, ncore = ncores) 63 | #' val_dt <- data.table::setorder(val_dt, date) 64 | #' plot(val_dt[qa == 0, .(date, evi2)], pch = 16, type = "b") 65 | #' } 66 | GetEvi2PointTs <- function(pt_coords, focalDates = "1984-01-01/2022-12-31", 67 | ncores = 1 68 | ) { 69 | # Make the bounding box for each point 70 | pt <- terra::vect(cbind(pt_coords$x, pt_coords$y), 71 | crs = "EPSG:4326" 72 | ) 73 | pt_buf <- terra::buffer(pt, width = 1) 74 | pt_ext <- terra::ext(pt_buf) 75 | 76 | # Split the entire time period 77 | start_date <- strsplit(focalDates, "/")[[1]][1] %>% as.Date() 78 | end_date <- strsplit(focalDates, "/")[[1]][2] %>% as.Date() 79 | 80 | if ((data.table::year(end_date) - data.table::year(start_date)) <= 5) { 81 | start_end_dates <- focalDates 82 | } else { 83 | yrs <- seq(data.table::year(start_date), 84 | data.table::year(end_date), 85 | by = 5 86 | ) 87 | 88 | start_end_dates <- NULL 89 | for (i in seq_along(yrs)) { 90 | if (i == 1) { 91 | sd <- start_date 92 | ed <- paste0(yrs[i + 1] - 1, "-12-31") %>% as.Date() 93 | } else if (i == length(yrs)) { 94 | sd <- paste0(yrs[i], "-01-01") %>% as.Date() 95 | ed <- end_date 96 | } else { 97 | sd <- paste0(yrs[i], "-01-01") %>% as.Date() 98 | ed <- paste0(yrs[i + 1] - 1, "-12-31") %>% as.Date() 99 | } 100 | 101 | start_end_dates <- c(start_end_dates, paste(sd, ed, sep = "/")) 102 | } 103 | } 104 | 105 | 106 | # Request images from the server 107 | 108 | # Planetary Computer API 109 | s_obj <- rstac::stac("https://planetarycomputer.microsoft.com/api/stac/v1/") 110 | 111 | it_obj <- lapply(start_end_dates, function(focal_dates) { 112 | obj <- rstac::stac_search(s_obj, 113 | collections = "landsat-c2-l2", 114 | ids = NULL, # could specify this if wanted 115 | bbox = pt_ext[c(1, 3, 2, 4)], 116 | datetime = focal_dates, 117 | limit = 1000 118 | ) %>% 119 | rstac::get_request() %>% 120 | rstac::items_sign(sign_fn = rstac::sign_planetary_computer()) %>% 121 | suppressWarnings() 122 | return(obj) 123 | }) 124 | 125 | 126 | # Iterate temporal periods 127 | res_dt <- lapply(it_obj, function(it) { 128 | # Parallel processing 129 | ncores <- ifelse(ncores > parallel::detectCores() - 1, 130 | parallel::detectCores() - 1, 131 | ncores 132 | ) 133 | cl <- parallel::makeCluster(ncores) 134 | calls <- parallel::clusterCall(cl, function() {}) 135 | parallel::clusterExport(cl, 136 | c("CalEVI2", "pt_coords"), 137 | envir = environment() 138 | ) 139 | 140 | # Iterate features 141 | val_dt <- parallel::parLapply(cl, X = it$features, function(img) { 142 | # val_dt <- lapply(it$features, function(img) { browser() # For debug 143 | img_id <- img$id 144 | date <- as.Date(gsub("T.*", "", img$properties$datetime)) 145 | epsg <- img$properties$`proj:epsg` 146 | 147 | # Project the point buffer to the epsg 148 | # Has to create the points again as terra doesn't serielize spatial 149 | # objects. 150 | pt <- terra::vect(cbind(pt_coords$x, pt_coords$y), 151 | crs = "EPSG:4326" 152 | ) %>% 153 | terra::project(paste0("EPSG:", epsg)) 154 | 155 | row <- tryCatch({ 156 | # Red 157 | red_band <- paste0("/vsicurl/", img$assets$red$href) %>% 158 | terra::rast() 159 | red_val <- terra::extract(red_band, pt)[, -1] 160 | rm(red_band) 161 | 162 | # Nir 163 | nir_band <- paste0("/vsicurl/", img$assets$nir08$href) %>% 164 | terra::rast() 165 | nir_val <- terra::extract(nir_band, pt)[, -1] 166 | rm(nir_band) 167 | 168 | # QA 169 | qa_band <- paste0("/vsicurl/", img$assets$qa_pixel$href) %>% 170 | terra::rast() 171 | qa_val <- terra::extract(qa_band, pt)[, -1] 172 | rm(qa_band) 173 | 174 | # Calculate EVI2 175 | evi2 <- CalEVI2(nir_val, red_val) 176 | 177 | return(data.table::data.table( 178 | img_id = img_id, 179 | lon = pt_coords$x, 180 | lat = pt_coords$y, 181 | evi2 = evi2, 182 | date = date, 183 | qa = qa_val 184 | )) 185 | 186 | }, error = function(e) { 187 | return(NULL) 188 | }) 189 | 190 | return(row) 191 | 192 | }) %>% 193 | do.call(rbind, .) 194 | 195 | parallel::stopCluster(cl) 196 | 197 | return(val_dt) 198 | }) %>% 199 | do.call(rbind, .) 200 | 201 | # Parse the QA band 202 | qa_parse <- LandsatCloudSnowQA(res_dt$qa) 203 | res_dt$snow <- qa_parse$snow 204 | res_dt <- res_dt[ 205 | qa_parse$fill == FALSE & 206 | qa_parse$cloud == FALSE & 207 | qa_parse$cloudShadow == FALSE, 208 | ] 209 | 210 | res_dt <- data.table::setorder(res_dt, date) 211 | 212 | return(res_dt) 213 | } 214 | 215 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' Landsat EVI2 time series. 2 | #' 3 | #' An Example EVI2 time series from Landsat observations. 4 | #' 5 | #' @format A data frame with 802 rows and 3 variables: 6 | #' \describe{ 7 | #' \item{date}{Observation dates} 8 | #' \item{evi2}{The two-band enhanced vegetation index value} 9 | #' \item{snow}{Logical, indicates whether the observation contains snow} 10 | #' } 11 | "landsatEVI2" -------------------------------------------------------------------------------- /R/hlp_funs.R: -------------------------------------------------------------------------------- 1 | # ****************************************************************************** 2 | # Helper functions that are not exposed to users. 3 | # Date: 2024-04-16 4 | # ****************************************************************************** 5 | 6 | 7 | #' Format input date and VI vectors to the structure needed for fitting averaged 8 | #' phenology models such as Fisher et al 2006, Elmore et al 2012. 9 | #' 10 | #' @param date_vec the date vector, be sure to convert the vector to "Date" 11 | #' format or use "yyyy-mm-dd" format string. 12 | #' @param vi_vec The vegetation index vector. 13 | #' @return A list that contains formated data. 14 | #' @import data.table 15 | #' 16 | #' @noRd 17 | FormatAvgData <- function(date_vec, vi_vec) { 18 | # Check if date_vec is in Date format 19 | if (sum(!is.na(lubridate::parse_date_time(date_vec, orders = "ymd"))) != 20 | length(date_vec)) { 21 | stop("There're invalid Date values in the `date_vec`! 22 | Be sure to use `yyyy-mm-dd` format.") 23 | } 24 | 25 | # Make it a data table 26 | vi_dt <- data.table::data.table( 27 | date = as.Date(date_vec), 28 | evi2 = vi_vec, 29 | avg_date = "" 30 | ) 31 | vi_dt[, avg_date := as.Date(paste0("1970", substr(vi_dt$date, 5, 10)))] 32 | vi_dt <- stats::na.omit(vi_dt) 33 | data.table::setorder(vi_dt, date) 34 | 35 | # Find unique dates in the averaged year 36 | unique_dates <- unique(vi_dt$avg_date) 37 | 38 | # Deal with multiple observations on the same date in the averaged year. 39 | # When that happens, we choose the one whose EVI2 value is the highest. 40 | merge_dt <- sapply(unique_dates, function(x) { 41 | # find how many records this day has 42 | evi2 <- NA 43 | find_idx <- which(x == vi_dt$avg_date) 44 | if (length(find_idx) == 1) { 45 | evi2 <- vi_dt[find_idx]$evi2 46 | } else if (length(find_idx) > 1) { # we have multiple values for this date 47 | # compute the max 48 | evi2 <- max(vi_dt[avg_date == x]$evi2, na.rm = TRUE) 49 | } 50 | return(list(date = x, evi2 = evi2)) 51 | }) 52 | merge_dt <- data.table::as.data.table(t(merge_dt)) 53 | 54 | return(merge_dt) 55 | } 56 | 57 | 58 | #' Format empty BLSP output to return 59 | #' 60 | #' @param years The years vector 61 | #' @param date_vec The date vector, be sure to convert the vector to "Date" 62 | #' format or use "yyyy-mm-dd" format string. 63 | #' @param vi_vec The vegetation index vector. 64 | #' @param weights_vec A numeric vector of same length as vi_vec specifying the 65 | #' weights for the supplied observations. Must be between 0 and 1, inclusive. 66 | #' @param cred_int_level A scalar value from 0 to 1 (exclusive) that specifies 67 | #' the level for equal-tailed credible intervals of the estimated phenometrics. 68 | #' The default level is 0.9, generating `90%` credible intervals. The end 69 | #' points of these intervals define the upper and lower bounds for the estimated 70 | #' phenometrics. 71 | #' @param mod The model object returned by the `GetModel()` function. 72 | #' @param method Method used for the phenometric output. For now, only support 73 | #' "default" and "threshold". The "default" method will return `midgup` and 74 | #' `midgdown`, while the "threshold" method will return 7 phenometrics including 75 | #' Greenup, MidGreenup, Maturity, Peak, Senescence, MidGreendown, and Dormancy. 76 | #' 77 | #' @return An empty BLSP class object. 78 | #' 79 | #' @noRd 80 | EmptyBlspOutput <- function( 81 | years, date_vec, vi_vec, weights_vec, 82 | cred_int_level, mod, method = "default" 83 | ) { 84 | if (method == "default") { 85 | bf_phenos <- data.table::data.table( 86 | Year = years, 87 | midgup_lwr = NA, midgup = NA, midgup_upr = NA, 88 | midgdown_lwr = NA, midgdown = NA, midgdown_upr = NA 89 | ) 90 | } else if (method == "threshold") { 91 | bf_phenos <- data.table::data.table( 92 | Year = years, 93 | Greenup = NA, Greenup_lwr = NA, Greenup_upr = NA, 94 | MidGreenup = NA, MidGreenup_lwr = NA, MidGreenup_upr = NA, 95 | Maturity = NA, Maturity_lwr = NA, Maturity_upr = NA, 96 | Peak = NA, Peak_lwr = NA, Peak_upr = NA, 97 | Senescence = NA, Senescence_lwr = NA, Senescence_upr = NA, 98 | MidGreendown = NA, MidGreendown_lwr = NA, MidGreendown_upr = NA, 99 | Dormancy = NA, Dormancy_lwr = NA, Dormancy_upr = NA 100 | ) 101 | } 102 | 103 | bf_phenos[, 104 | colnames(bf_phenos) := lapply(.SD, as.numeric), 105 | .SDcols = colnames(bf_phenos) 106 | ] 107 | 108 | blsp_fit <- list( 109 | phenos = bf_phenos, 110 | model = list( 111 | model_str = mod$model_str, 112 | model_param = mod$out_param 113 | ), 114 | params = NULL, 115 | data = data.table::data.table( 116 | date = date_vec, 117 | vi = vi_vec, 118 | weights = weights_vec 119 | ), 120 | cred_int_level = cred_int_level 121 | ) 122 | class(blsp_fit) <- "BlspFit" 123 | 124 | return(blsp_fit) 125 | } 126 | 127 | 128 | #' Check if user inputs are reasonable 129 | #' 130 | #' @param date_vec The date vector, be sure to convert the vector to "Date" 131 | #' format or use "yyyy-mm-dd" format string. 132 | #' @param vi_vec The vegetation index vector. 133 | #' @param weights_vec A numeric vector of same length as vi_vec specifying the 134 | #' weights for the supplied observations. Must be between 0 and 1, inclusive. 135 | #' @param model The model string. 136 | #' @param cred_int_level A scalar value from 0 to 1 (exclusive) that specifies 137 | #' the level for equal-tailed credible intervals of the estimated phenometrics. 138 | #' The default level is 0.9, generating `90%` credible intervals. The end 139 | #' points of these intervals define the upper and lower bounds for the estimated 140 | #' phenometrics. 141 | #' @param init_values Initial values for MCMC sampling. By default, it is 142 | #' assgined `NULL`. It could also be an object returned from the `FitAvgModel()` 143 | #' function that fits an averaged model or a numeric vector provided by the 144 | #' user. 145 | #' 146 | #' @import data.table 147 | SanityCheck <- function( 148 | date_vec, vi_vec, weights_vec, 149 | model, cred_int_level, init_values 150 | ) { 151 | # Check if date_vec is in Date format 152 | if (sum(!is.na(lubridate::parse_date_time(date_vec, orders = "ymd"))) != 153 | length(date_vec)) { 154 | stop("There're invalid Date values in the `date_vec`! 155 | Be sure to use `yyyy-mm-dd` format.") 156 | } 157 | 158 | # Check weights to be in the range of [0, 1] 159 | if (!is.null(weights_vec)) { 160 | if (min(weights_vec) < 0 | max(weights_vec) > 1) { 161 | stop("Weights must be within [0, 1].") 162 | } 163 | 164 | # Check the length of dates, vis, and weights 165 | if (length(weights_vec) != length(date_vec) | 166 | length(vi_vec) != length(date_vec)) { 167 | stop("date_vec, vi_vec, and weights_vec have different lengths.") 168 | } 169 | } 170 | 171 | # Check NAs 172 | if (any(is.na(date_vec)) | any(is.na(vi_vec))) { 173 | stop("Please remove NAs in the input data.") 174 | } 175 | 176 | # Check the jags model string 177 | if (!model %in% c("dblog7", "dblog6")) { 178 | warning("The specified model does not exist, dblog7 will be used.") 179 | model <- "dblog7" 180 | } 181 | 182 | # Check init value 183 | if (!is.null(init_values)) { 184 | # Check if the length matches w/ model 185 | model_init_vals <- GetModel(model)$init_val 186 | if (class(init_values) == "nls") { 187 | if (length(stats::coef(init_values)) != length(model_init_vals)) { 188 | stop("Init values does not match w/ the model!") 189 | } 190 | } else if (class(init_values) == "numeric") { 191 | if (length(init_values) != length(model_init_vals)) { 192 | stop("Init values does not match w/ the model!") 193 | } 194 | } 195 | } 196 | 197 | if (cred_int_level >= 1 || cred_int_level <= 0) { 198 | warning("`cred_int_level` is not in (0, 1), 0.9 will be used.") 199 | cred_int_level <- 0.9 200 | } 201 | 202 | return(list( 203 | model = model, cred_int_level = cred_int_level 204 | )) 205 | } 206 | 207 | 208 | #' Calculate phenometrics based on the model parameters 209 | #' 210 | #' @param p_li A list containing the model parameters. 211 | #' @param mod The model object returned by the `GetModel()` function. 212 | #' @param years The years vector 213 | #' @param numYears Number of years. 214 | #' @param date_vec The date vector, be sure to convert the vector to "Date" 215 | #' format or use "yyyy-mm-dd" format string. 216 | #' @param vi_vec The vegetation index vector. 217 | #' @param weights_vec A numeric vector of same length as vi_vec specifying the 218 | #' weights for the supplied observations. Must be between 0 and 1, inclusive. 219 | #' @param cred_int_level A scalar value from 0 to 1 (exclusive) that specifies 220 | #' the level for equal-tailed credible intervals of the estimated phenometrics. 221 | #' The default level is 0.9, generating `90%` credible intervals. The end 222 | #' points of these intervals define the upper and lower bounds for the estimated 223 | #' phenometrics. 224 | #' 225 | #' @return An "BlspFit" object filled with retrieved phenology and parameters. 226 | #' 227 | #' @import data.table 228 | #' @noRd 229 | CalPhenoParam <- function( 230 | p_li, mod, 231 | years, numYears, 232 | date_vec, vi_vec, weights_vec, 233 | cred_int_level 234 | ) { 235 | blsp_fit <- EmptyBlspOutput( 236 | years, 237 | date_vec, 238 | vi_vec, 239 | weights_vec, 240 | cred_int_level, 241 | mod, 242 | method = "default" 243 | ) 244 | p_qt <- lapply(p_li, function(li) { 245 | apply(li, 2, stats::quantile, c(0.05, 0.5, 0.95)) 246 | }) 247 | 248 | phenos <- lapply(1:numYears, function(i) { 249 | # suppress some amplitude-too-low year 250 | amp <- p_qt[[2]][2, i] 251 | if (mod$model_name == "dblog7" & amp > 0.4) { 252 | c( 253 | years[i], 254 | p_qt[[3]][1, i], p_qt[[3]][2, i], p_qt[[3]][3, i], 255 | p_qt[[5]][1, i], p_qt[[5]][2, i], p_qt[[5]][3, i] 256 | ) 257 | } else if (mod$model_name == "dblog6" & amp > 0.1) { 258 | c( 259 | years[i], 260 | p_qt[[3]][1, i], p_qt[[3]][2, i], p_qt[[3]][3, i], 261 | p_qt[[5]][1, i], p_qt[[5]][2, i], p_qt[[5]][3, i] 262 | ) 263 | } else { 264 | c(years[i], rep(NA, 6)) 265 | } 266 | }) %>% 267 | do.call(rbind, .) %>% 268 | data.table::as.data.table() %>% 269 | setnames(c( 270 | "Year", 271 | "midgup_lwr", "midgup", "midgup_upr", 272 | "midgdown_lwr", "midgdown", "midgdown_upr" 273 | )) 274 | 275 | blsp_fit$phenos <- phenos 276 | blsp_fit$params <- p_li 277 | 278 | return(blsp_fit) 279 | } 280 | 281 | 282 | #' Find point to line distance 283 | #' 284 | #' @param x1,y1,x2,y2 The coordinates of the two points that define the line. 285 | #' @param x0,y0 The point coordinates to calculate the distance. 286 | #' 287 | #' @return Distance from the point to the line. 288 | #' @noRd 289 | CalPointToLineDistance <- function(x1, y1, x2, y2, x0, y0) { 290 | m <- (y2 - y1) / (x2 - x1) 291 | A <- - m 292 | B <- 1 293 | C <- m * x1 - y1 294 | 295 | distance <- abs(A * x0 + B * y0 + C) / sqrt(A^2 + B^2) 296 | 297 | return(distance) 298 | } 299 | 300 | 301 | #' Calculate phenometrics using the threshold-based method 302 | #' 303 | #' @param p_li A list containing the model parameters. 304 | #' @param mod The model object returned by the `GetModel()` function. 305 | #' @param years The years vector 306 | #' @param numYears Number of years. 307 | #' @param date_vec The date vector, be sure to convert the vector to "Date" 308 | #' format or use "yyyy-mm-dd" format string. 309 | #' @param vi_vec The vegetation index vector. 310 | #' @param weights_vec A numeric vector of same length as vi_vec specifying the 311 | #' weights for the supplied observations. Must be between 0 and 1, inclusive. 312 | #' @param cred_int_level A scalar value from 0 to 1 (exclusive) that specifies 313 | #' the level for equal-tailed credible intervals of the estimated phenometrics. 314 | #' The default level is 0.9, generating `90%` credible intervals. The end 315 | #' points of these intervals define the upper and lower bounds for the estimated 316 | #' phenometrics. 317 | #' @param greendown_aware Default is `FALSE`. If `TRUE`, Senescence will be 318 | #' retrieved as the end of summer greendown date, and MidGreendown as the 319 | #' transition point of the first derivative of the autumn EVI2 curve. 320 | #' 321 | #' @return An "BlspFit" object filled with retrieved phenology and parameters. 322 | #' 323 | #' @import data.table 324 | #' @noRd 325 | CalPhenoThresh <- function( 326 | p_li, mod, 327 | years, numYears, 328 | date_vec, vi_vec, weights_vec, 329 | cred_int_level, 330 | greendown_aware = FALSE 331 | ) { 332 | # Format MCD12Q2-like phenometrics 333 | blsp_fit <- EmptyBlspOutput( 334 | years, 335 | date_vec, 336 | vi_vec, 337 | weights_vec, 338 | cred_int_level, 339 | mod, 340 | method = "threshold" 341 | ) 342 | blsp_fit$params <- p_li 343 | 344 | bf_pred <- BLSPFitted(blsp_fit) 345 | 346 | yrs <- names(bf_pred) 347 | phenos_dt <- NULL 348 | for (yr in yrs) { 349 | pred <- bf_pred[eval(yr)][[1]] 350 | phenos <- lapply(1:ncol(pred), function(i) { 351 | p <- pred[, i] 352 | peakdate <- which.max(p) 353 | peak <- max(p) 354 | 355 | # Spring amp 356 | spring_min <- min(p[1:peakdate]) 357 | spring_amp <- peak - spring_min 358 | 359 | gup <- which( 360 | p[1:peakdate] > (spring_amp * 0.15 + min(p[1:peakdate])) 361 | )[1] 362 | midgup <- which( 363 | p[1:peakdate] > (spring_amp * 0.5 + min(p[1:peakdate])) 364 | )[1] 365 | mat <- which( 366 | p[1:peakdate] > (spring_amp * 0.90 + min(p[1:peakdate])) 367 | )[1] 368 | 369 | if (isTRUE(greendown_aware)) { 370 | # If greendown aware, autumn amp is calculated as the EVI2 371 | # between the EVI2 of the end of greendown to the EVI2 of 372 | # dormancy 373 | 374 | # Draw a line between peak and min, find the point w/ the max 375 | # distance to the line, which is senescence 376 | autumn_p <- p[peakdate:length(p)] 377 | autumn_min <- min(autumn_p) 378 | autumn_amp <- peak - autumn_min 379 | autumn_min_doy <- which( 380 | autumn_p < autumn_amp * 0.1 + autumn_min 381 | )[1] + peakdate 382 | 383 | dis <- sapply(peakdate + seq_along(autumn_p) - 1, function(x0) { 384 | CalPointToLineDistance( 385 | peakdate, peak, 386 | autumn_min_doy, autumn_min, 387 | x0, autumn_p[x0 - peakdate + 1] 388 | ) 389 | }) 390 | sens <- peakdate + which(diff(sign(diff(dis))) == -2) + 2 391 | 392 | # Now, the autumn amplitude is from sens to min 393 | autumn_amp <- p[sens] - autumn_min 394 | 395 | # MidGreendown is from the first derivative 396 | midgdown <- which.min( 397 | diff(autumn_p[(sens - peakdate + 1):length(autumn_p)]) 398 | ) + sens 399 | dorm <- which( 400 | autumn_p[(sens - peakdate + 1):length(autumn_p)] < 401 | autumn_amp * 0.15 + autumn_min 402 | )[1] + sens 403 | } else { 404 | # Autumn amp 405 | autumn_min <- min(p[peakdate:length(p)]) 406 | autumn_amp <- peak - autumn_min 407 | 408 | if (spring_amp < 0.2 | autumn_amp < 0.2) { 409 | return(rep(NA, 7)) 410 | } 411 | 412 | sens <- which( 413 | p[peakdate:length(p)] < autumn_amp * 0.90 + autumn_min 414 | )[1] + peakdate 415 | midgdown <- which( 416 | p[peakdate:length(p)] < autumn_amp * 0.5 + autumn_min 417 | )[1] + peakdate 418 | dorm <- which( 419 | p[peakdate:length(p)] < autumn_amp * 0.15 + autumn_min 420 | )[1] + peakdate 421 | } 422 | 423 | return(c(gup, midgup, mat, peakdate, sens, midgdown, dorm)) 424 | }) 425 | phenos <- do.call(cbind, phenos) 426 | 427 | # Get CIs 428 | phenos <- apply(phenos, 1, quantile, 429 | c(0.025, 0.5, 0.975), 430 | na.rm = TRUE 431 | ) 432 | colnames(phenos) <- c( 433 | "gup", "midgup", "mat", "peakdate", "sens", "midgdown", "dorm" 434 | ) 435 | 436 | therow <- data.table( 437 | Year = yr, 438 | Greenup = round(phenos[2, "gup"]), 439 | Greenup_lwr = round(phenos[1, "gup"]), 440 | Greenup_upr = round(phenos[3, "gup"]), 441 | MidGreenup = round(phenos[2, "midgup"]), 442 | MidGreenup_lwr = round(phenos[1, "midgup"]), 443 | MidGreenup_upr = round(phenos[3, "midgup"]), 444 | Maturity = round(phenos[2, "mat"]), 445 | Maturity_lwr = round(phenos[1, "mat"]), 446 | Maturity_upr = round(phenos[3, "mat"]), 447 | Peak = round(phenos[2, "peakdate"]), 448 | Peak_lwr = round(phenos[1, "peakdate"]), 449 | Peak_upr = round(phenos[3, "peakdate"]), 450 | Senescence = round(phenos[2, "sens"]), 451 | Senescence_lwr = round(phenos[1, "sens"]), 452 | Senescence_upr = round(phenos[3, "sens"]), 453 | MidGreendown = round(phenos[2, "midgdown"]), 454 | MidGreendown_lwr = round(phenos[1, "midgdown"]), 455 | MidGreendown_upr = round(phenos[3, "midgdown"]), 456 | Dormancy = round(phenos[2, "dorm"]), 457 | Dormancy_lwr = round(phenos[1, "dorm"]), 458 | Dormancy_upr = round(phenos[3, "dorm"]) 459 | ) 460 | 461 | phenos_dt <- rbind(phenos_dt, therow) 462 | } 463 | 464 | blsp_fit$phenos <- phenos_dt 465 | blsp_fit$params <- p_li 466 | 467 | return(blsp_fit) 468 | } 469 | -------------------------------------------------------------------------------- /R/mod_fit.R: -------------------------------------------------------------------------------- 1 | #******************************************************************************* 2 | # Description: Model fit functions. 3 | # Date: 2022-03-29 4 | #******************************************************************************* 5 | 6 | 7 | #' Get the BLSP fitted curves 8 | #' 9 | #' The funciton uses the "BlspFit" object returned by the "FitBLSP" function to 10 | #' predict the fitted daily VI curves. 11 | #' 12 | #' @param blsp_fit The "BlspFit" object. 13 | #' @param asCI Logical. Default is `TRUE`, which means the fitted curves will be 14 | #' summarized as median and 95% credibel interval. 15 | #' 16 | #' @return The fitted curves, or the summary, for each year. 17 | #' 18 | #' @export 19 | #' @import data.table 20 | BLSPFitted <- function(blsp_fit, asCI = FALSE) { 21 | if (class(blsp_fit) != "BlspFit") { 22 | stop("Please provide a BlspFit object!") 23 | } 24 | 25 | # Unpack data from the object 26 | date_vec <- blsp_fit$data$date 27 | vi_vec <- blsp_fit$data$vi 28 | weights_vec <- blsp_fit$weights 29 | if (is.null(weights_vec)) { 30 | weights_vec <- rep(1, length(vi_vec)) 31 | } 32 | bf_phenos <- blsp_fit$phenos 33 | yr <- lubridate::year(date_vec) - lubridate::year(date_vec)[1] + 1 34 | numYears <- length(unique(yr)) 35 | model_str <- blsp_fit$model$model_str 36 | 37 | # ~ Predict fitted value for full dates ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 38 | bf_pred <- list() 39 | years <- sort(unique(lubridate::year(date_vec))) 40 | for (i in 1:numYears) { 41 | date <- seq(as.Date(paste0(years[i], "-01-01")), 42 | as.Date(paste0(years[i], "-12-31")), 43 | by = "day" 44 | ) 45 | bf_params <- lapply(1:length(blsp_fit$params), function(m) { 46 | blsp_fit$params[[m]][, i] 47 | }) %>% 48 | do.call(cbind, .) 49 | 50 | pred <- matrix(NA, nrow = length(date), ncol = nrow(bf_params)) 51 | for (j in 1:nrow(bf_params)) { 52 | # pred based on current parameter samples 53 | envlist <- lapply(1:ncol(bf_params), function(m) { 54 | as.numeric(bf_params[j, m]) 55 | }) 56 | names(envlist) <- blsp_fit$model$model_param 57 | envlist$t <- 1:length(date) 58 | pred[, j] <- eval(str2expression(model_str), envir = envlist) 59 | } 60 | thelist <- list(pred) 61 | names(thelist) <- years[i] 62 | bf_pred <- append(bf_pred, thelist) 63 | } 64 | 65 | # If summarize as CI, the result will just be median, lower, and upper 66 | if (asCI == TRUE) { 67 | alpha <- (1 - blsp_fit$cred_int_level) / 2 68 | 69 | bf_pred <- lapply(seq_along(years), function(i) { 70 | date <- seq(as.Date(paste0(years[i], "-01-01")), 71 | as.Date(paste0(years[i], "-12-31")), 72 | by = "day" 73 | ) 74 | theyr <- bf_pred[[as.character(years[i])]] 75 | predCI <- t(data.table::data.table( 76 | apply(theyr, 1, function(x) { 77 | stats::quantile(x, c(alpha, 1 - alpha)) 78 | }) 79 | )) 80 | 81 | pred <- data.table::data.table( 82 | apply(theyr, 1, function(x) stats::quantile(x, 0.5)) 83 | ) 84 | return(cbind(date, pred, predCI)) 85 | }) 86 | bf_pred <- do.call(rbind, bf_pred) 87 | # Make it a data.table 88 | bf_pred <- data.table::as.data.table(bf_pred) 89 | colnames(bf_pred) <- c("Date", "Fitted", "Fitted_lower", "Fitted_upper") 90 | bf_pred$Date <- as.Date(bf_pred$Date, origin = "1970-01-01") 91 | } 92 | 93 | return(bf_pred) 94 | } 95 | 96 | 97 | 98 | #' Fit a Bayesian mixed hierarchical land urface phenology model. 99 | #' 100 | #' This function fits a Bayesian mixed hierarchical land surface phenology model 101 | #' to the supplied data (can be sparse), and returns phenometrics for the 102 | #' entire time frame. For further explanation, please see the vignette. 103 | #' 104 | #' @param date_vec The date vector, be sure to convert the vector to "Date" 105 | #' format or use "yyyy-mm-dd" format string. 106 | #' @param vi_vec The vegetation index vector. 107 | #' @param weights_vec A numeric vector of same length as vi_vec specifying the 108 | #' weights for the supplied observations. Must be between 0 and 1, inclusive. 109 | #' @param model A string indicating the model name. For now, only support 110 | #' "dblog7" and "dblog6" for the 7- and 6-parameter double-logistic functions. 111 | #' @param init_values Initial values for MCMC sampling. By default, it is 112 | #' assgined `NULL`. It could also be an object returned from the `FitAvgModel()` 113 | #' function that fits an averaged model or a numeric vector provided by the user. 114 | #' @param start_yr The start year of the result. Default is NULL, which means 115 | #' determined by data. 116 | #' @param end_yr The end year of the result. Default is NULL, which means 117 | #' determined by data. 118 | #' @param cred_int_level A scalar value from 0 to 1 (exclusive) that specifies 119 | #' the level for equal-tailed credible intervals of the estimated phenometrics. 120 | #' The default level is 0.9, generating `90%` credible intervals. The end points 121 | #' of these intervals define the upper and lower bounds for the estimated 122 | #' phenometrics. 123 | #' @param opt An option list that contains additional configurations. It 124 | #' supports `list(method = "threshold")` to indicate that use the 125 | #' threshold-based method to retrive phenometrics instead of the default SOS 126 | #' and EOS. The threshold-based method will produce 7 phenometrics including 127 | #' Greenup, MidGreenup, Maturity, Peak, Senescence, MidGreendown, and Dormancy 128 | #' using VI amplitude thresholds of 15%, 50%, 90%, and 100%, respectively. If 129 | #' including `greendown_aware = TRUE`, Senescence will be retrieved as the end 130 | #' of summer greendown date, and MidGreendown as the transition point of the 131 | #' first derivative of the autumn EVI2 curve. 132 | #' @param verbose logical. If `TRUE`, the progress will be reported. 133 | #' 134 | #' @return An object of class `BlspFit` will be returned. The object contains the 135 | #' estimated spring and autumn phenometrics for each year, the generated model 136 | #' parameter samples, and the input data. 137 | #' @examples 138 | #' \dontrun{ 139 | #' data(landsatEVI2) 140 | #' blsp_fit <- FitBLSP(date_vec = landsatEVI2$date, vi_vec = landsatEVI2$evi2) 141 | #' } 142 | #' @export 143 | #' @import data.table 144 | FitBLSP <- function(date_vec, vi_vec, 145 | weights_vec = NULL, 146 | model = "dblog7", 147 | init_values = NULL, 148 | start_yr = NULL, 149 | end_yr = NULL, 150 | cred_int_level = 0.9, 151 | opt = NULL, 152 | verbose = FALSE 153 | ) { 154 | sc_li <- SanityCheck(date_vec, vi_vec, weights_vec, 155 | model, cred_int_level, init_values 156 | ) 157 | model <- sc_li$model 158 | cred_int_level <- sc_li$cred_int_level 159 | 160 | # Reorder data to make sure they are sorted by time 161 | od <- order(date_vec) 162 | date_vec <- date_vec[od] 163 | vi_vec <- vi_vec[od] 164 | weights_vec <- weights_vec[od] 165 | 166 | # Convert data to jags format 167 | y <- vi_vec 168 | t <- lubridate::yday(date_vec) 169 | n <- length(y) # total num of observations 170 | # year id vector 171 | if (is.null(start_yr) || is.null(end_yr)) { 172 | yr <- lubridate::year(date_vec) - lubridate::year(date_vec)[1] + 1 173 | tmp <- sort(unique(year(date_vec))) 174 | years <- tmp[1]:tmp[length(tmp)] 175 | numYears <- length(1:yr[length(yr)]) 176 | } else { 177 | yr <- lubridate::year(date_vec) - lubridate::year(date_vec)[1] + 1 178 | years <- start_yr:end_yr 179 | numYears <- length(years) 180 | } 181 | # If user specified weights 182 | if (is.null(weights_vec)) { 183 | weights_vec <- rep(1, n) 184 | } 185 | 186 | # Get model structure 187 | mod <- GetModel(model) 188 | 189 | # Set initial values 190 | if (!is.null(init_values) && class(init_values) == "nls") { 191 | p_pars <- stats::coef(init_values) 192 | } else if (!is.null(init_values) && class(init_values) == "numeric") { 193 | p_pars <- init_values 194 | } else { 195 | p_pars <- mod$init_val 196 | } 197 | 198 | data <- list( 199 | Y = y, t = t, n = n, yr = yr, N = numYears, weights = weights_vec 200 | ) 201 | 202 | 203 | inits <- lapply(seq_along(mod$init_param), function(i) { 204 | rep(p_pars[i], numYears) 205 | }) 206 | names(inits) <- mod$init_param 207 | 208 | blsp_fit <- tryCatch( 209 | { 210 | if (verbose) { 211 | message("Initialize model...") 212 | } 213 | pb_type <- ifelse(verbose, "text", "none") 214 | 215 | model <- rjags::jags.model(textConnection(mod$jags_str), 216 | data = data, inits = inits, 217 | n.chains = 3, quiet = TRUE 218 | ) 219 | stats::update(model, 2000, progress.bar = pb_type) 220 | 221 | if (verbose) { 222 | message("Sampling (could have multiple chains)...") 223 | } 224 | 225 | iteration_times <- 0 226 | repeat { 227 | samp <- rjags::coda.samples(model, 228 | variable.names = mod$out_param, 229 | n.iter = 5000, 230 | thin = 10, 231 | progress.bar = pb_type 232 | ) 233 | iteration_times <- iteration_times + 5000 234 | 235 | # Try to make it converge 236 | if (coda::gelman.diag(samp)$mpsrf <= 1.3 | 237 | iteration_times > 50000) { 238 | break 239 | } 240 | } 241 | 242 | if (verbose) { 243 | message("total interation times:", iteration_times) 244 | } 245 | 246 | # ~ Retrieve parameter estimates 247 | if (verbose) { 248 | message("Estimate phenometrics...") 249 | } 250 | p_li <- lapply(seq_along(mod$out_param), function(p) { 251 | p_mat <- lapply(1:numYears, function(i) { 252 | c( 253 | samp[[1]][, paste0(mod$out_param[p], "[", i, "]")], 254 | samp[[2]][, paste0(mod$out_param[p], "[", i, "]")], 255 | samp[[3]][, paste0(mod$out_param[p], "[", i, "]")] 256 | ) 257 | }) %>% 258 | do.call(cbind, .) 259 | 260 | return(p_mat) 261 | }) 262 | 263 | # Construct `blsp_fit` object to return 264 | if (!is.null(opt) && tolower(opt$method) == "threshold") { 265 | blsp_fit <- CalPhenoThresh( 266 | p_li, mod, 267 | years, numYears, 268 | date_vec, vi_vec, weights_vec, 269 | cred_int_level, 270 | greendown_aware = opt$greendown_aware 271 | ) 272 | } else { 273 | blsp_fit <- CalPhenoParam( 274 | p_li, mod, 275 | years, numYears, 276 | date_vec, vi_vec, weights_vec, 277 | cred_int_level 278 | ) 279 | } 280 | 281 | if (verbose) { 282 | message("Done!") 283 | } 284 | 285 | blsp_fit 286 | }, 287 | error = function(e) { 288 | if (verbose) { 289 | message("Something went wrong!") 290 | } 291 | blsp_fit <- EmptyBlspOutput( 292 | years, 293 | date_vec, 294 | vi_vec, 295 | weights_vec, 296 | cred_int_level, 297 | mod, 298 | method = tolower(opt$method) 299 | ) 300 | 301 | return(blsp_fit) 302 | } 303 | ) 304 | 305 | return(blsp_fit) 306 | } 307 | 308 | 309 | #' Fit a Bayesian mixed hierarchical land surface phenology model. Spring only! 310 | #' Note that the result CANNOT be used to plot the fit. 311 | #' 312 | #' This function fits a Bayesian mixed hierarchical land surface phenology model 313 | #' to the supplied data (can be sparse), and returns phenometrics for the 314 | #' entire time frame. For further explanation, please see the vignette. 315 | #' 316 | #' @param date_vec The date vector, be sure to convert the vector to "Date" 317 | #' format or use "yyyy-mm-dd" format string. 318 | #' @param vi_vec The vegetation index vector. 319 | #' @param weights_vec A numeric vector of same length as vi_vec specifying the 320 | #' weights for the supplied observations. Must be between 0 and 1, inclusive. 321 | #' @param initValues Initial values for MCMC sampling. By default, it is 322 | #' assgined `NULL`. It could also be an object returned from the `FitAvgModel()` 323 | #' function that fits an averaged model or a numeric vector provided by the user. 324 | #' @param cred_int_level A scalar value from 0 to 1 (exclusive) that specifies 325 | #' the level for equal-tailed credible intervals of the estimated phenometrics. 326 | #' The default level is 0.9, generating `90%` credible intervals. The end 327 | #' points of these intervals define the upper and lower bounds for the estimated 328 | #' phenometrics. 329 | #' @param verbose logical. If `TRUE`, the progress will be reported. 330 | #' @return An object of class `BlspFit` will be returned. The object contains the 331 | #' estimated spring and autumn phenometrics for each year, the generated model 332 | #' parameter samples, and the input data. 333 | #' @examples 334 | #' \dontrun{ 335 | #' data(landsatEVI2) 336 | #' blsp_fit <- FitBLSP(date_vec = landsatEVI2$date, vi_vec = landsatEVI2$evi2) 337 | #' } 338 | #' @export 339 | #' @import data.table 340 | FitBLSP_spring <- function(date_vec, vi_vec, 341 | weights_vec = NULL, 342 | initValues = NULL, 343 | cred_int_level = 0.9, 344 | verbose = FALSE 345 | ) { 346 | # Check if date_vec is in Date format 347 | if (sum(!is.na(lubridate::parse_date_time(date_vec, orders = "ymd"))) != 348 | length(date_vec)) { 349 | stop("There're invalid Date values in the `date_vec`! 350 | Be sure to use `yyyy-mm-dd` format.") 351 | } 352 | 353 | # Check weights to be in the range of [0, 1] 354 | if (!is.null(weights_vec)) { 355 | if (min(weights_vec) < 0 | max(weights_vec) > 1) { 356 | stop("Weights must be within [0, 1].") 357 | } 358 | 359 | # Check the length of dates, vis, and weights 360 | if (length(weights_vec) != length(date_vec) | 361 | length(vi_vec) != length(date_vec)) { 362 | stop("date_vec, vi_vec, and weights_vec have different lengths.") 363 | } 364 | } 365 | 366 | # Check NAs 367 | if (any(is.na(date_vec)) | any(is.na(vi_vec))) { 368 | stop("Please remove NAs in the input data.") 369 | } 370 | 371 | # Check if credible interval level is valid 372 | if (cred_int_level <= 0 | cred_int_level >= 1) { 373 | stop("Credible interval level must be a value between 0 and 1 (exclusive).") 374 | } 375 | # Reorder data to make sure they are sorted by time 376 | od <- order(date_vec) 377 | date_vec <- date_vec[od] 378 | vi_vec <- vi_vec[od] 379 | weights_vec <- weights_vec[od] 380 | 381 | # Convert data to jags format 382 | y <- vi_vec 383 | t <- lubridate::yday(date_vec) 384 | n <- length(y) # total num of observations 385 | # year id vector 386 | yr <- lubridate::year(date_vec) - lubridate::year(date_vec)[1] + 1 387 | numYears <- length(unique(yr)) 388 | 389 | # If user specified weights 390 | if (is.null(weights_vec)) { 391 | weights_vec <- rep(1, n) 392 | } 393 | 394 | # ~ Format data, inits, and model 395 | model_string <- "model { 396 | # Likelihood 397 | for (i in 1:n) { 398 | Y[i] ~ dnorm(mu[i], tau_y) 399 | mu[i] <- weights[i] * (m1[yr[i]] + (m2[yr[i]] - m7[yr[i]] * t[i]) * 400 | ((1 / (1 + exp((m3[yr[i]] - t[i]) / m4[yr[i]]))) - 401 | (1 / (1 + exp((m5[yr[i]] - t[i]) / m6[yr[i]]))))) 402 | } 403 | 404 | # Priors 405 | for (j in 1:N) { 406 | M1[j] ~ dnorm(mu_m1, tau[1]) 407 | logit(m1[j]) <- M1[j] 408 | m2[j] ~ dnorm(mu_m2, tau[2]) 409 | m3[j] ~ dnorm(mu_m3, tau[3]) 410 | m4[j] ~ dnorm(mu_m4, tau[4]) 411 | m5[j] ~ dnorm(mu_m5, tau[5]) 412 | m6[j] ~ dnorm(mu_m6, tau[6]) 413 | M7[j] ~ dbeta(4, 4 * (1 - mu_m7 * 100) / (mu_m7 * 100)) 414 | m7[j] <- M7[j] / 100 415 | } 416 | 417 | mu_m1 ~ dunif(0, 0.3) 418 | mu_m2 ~ dunif(0.5, 2) 419 | mu_m3 ~ dunif(0, 185) 420 | mu_m4 ~ dunif(1, 15) 421 | mu_m5 ~ dunif(185, 366) 422 | mu_m6 ~ dunif(1, 15) 423 | mu_m7 ~ dunif(0, 0.01) 424 | 425 | for (k in 1:7) { 426 | tau[k] ~ dgamma(0.1, 0.1) 427 | } 428 | tau_y ~ dgamma(0.1, 0.1) 429 | }" 430 | 431 | if (!is.null(initValues) && class(initValues) == "nls") { 432 | p_m1 <- stats::coef(initValues)["m1"] 433 | p_m2 <- stats::coef(initValues)["m2"] 434 | p_m3 <- stats::coef(initValues)["m3"] 435 | p_m4 <- stats::coef(initValues)["m4"] 436 | p_m5 <- stats::coef(initValues)["m5"] 437 | p_m6 <- stats::coef(initValues)["m6"] 438 | p_m7 <- stats::coef(initValues)["m7"] 439 | } else if (!is.null(initValues) && class(initValues) == "numeric") { 440 | if (length(initValues) != 7) { 441 | stop("The length of the initial values does not match", 442 | "the number of model parameters." 443 | ) 444 | } 445 | p_m1 <- initValues[1] 446 | p_m2 <- initValues[2] 447 | p_m3 <- initValues[3] 448 | p_m4 <- initValues[4] 449 | p_m5 <- initValues[5] 450 | p_m6 <- initValues[6] 451 | p_m7 <- initValues[7] 452 | } else { 453 | p_m1 <- 0.05 454 | p_m2 <- 1 455 | p_m3 <- 120 456 | p_m4 <- 8 457 | p_m5 <- 290 458 | p_m6 <- 8 459 | p_m7 <- 0.001 460 | } 461 | 462 | data <- list( 463 | Y = y, t = t, n = n, yr = yr, N = numYears, weights = weights_vec 464 | ) 465 | 466 | inits <- list( 467 | M1 = rep(p_m1, numYears), 468 | m2 = rep(p_m2, numYears), m3 = rep(p_m3, numYears), 469 | m4 = rep(p_m4, numYears), m5 = rep(p_m5, numYears), 470 | m6 = rep(p_m6, numYears) 471 | ) 472 | 473 | tryCatch( 474 | { 475 | if (verbose) { 476 | message("Initialize model...") 477 | } 478 | pb_type <- ifelse(verbose, "text", "none") 479 | 480 | model <- rjags::jags.model(textConnection(model_string), 481 | data = data, inits = inits, 482 | n.chains = 3, quiet = TRUE 483 | ) 484 | stats::update(model, 2000, progress.bar = pb_type) 485 | 486 | if (verbose) { 487 | message("Sampling (could have multiple chains)...") 488 | } 489 | 490 | iteration_times <- 0 491 | repeat { 492 | samp <- rjags::coda.samples(model, 493 | variable.names = c("m2", "m3"), 494 | n.iter = 5000, 495 | thin = 10, 496 | progress.bar = pb_type 497 | ) 498 | iteration_times <- iteration_times + 5000 499 | 500 | # Try to make it converge 501 | if(coda::gelman.diag(samp)$mpsrf <= 1.3 | 502 | iteration_times > 100000) { 503 | break 504 | } 505 | } 506 | if (verbose) { 507 | message("total interation times:", iteration_times) 508 | } 509 | }, 510 | error = function(e) { 511 | years <- sort(unique(year(date_vec))) 512 | bf_phenos <- NULL 513 | for (i in 1:numYears) { 514 | bf_phenos <- rbind(bf_phenos, list( 515 | Id = NA, Year = years[i], 516 | midgup_lower = NA, midgup = NA, midgup_upper = NA, 517 | midgdown_lower = NA, midgdown = NA, midgdown_upper = NA 518 | )) 519 | } 520 | return(list(fitted = NA, phenos = bf_phenos)) 521 | } 522 | ) 523 | 524 | # ~ Retrieve parameter estimates 525 | if (verbose) { 526 | message("Estimate phenometrics...") 527 | } 528 | m1 <- m2 <- m3 <- m4 <- m5 <- m6 <- m7 <- NULL 529 | for (i in 1:numYears) { 530 | m2 <- cbind(m2, c(samp[[1]][, paste0("m2", "[", i, "]")], 531 | samp[[2]][, paste0("m2", "[", i, "]")])) 532 | m3 <- cbind(m3, c(samp[[1]][, paste0("m3", "[", i, "]")], 533 | samp[[2]][, paste0("m3", "[", i, "]")])) 534 | } 535 | 536 | alpha <- (1-cred_int_level)/2 537 | m2_quan <- data.table::data.table( 538 | apply(m2, 2, stats::quantile, c(alpha, 0.5, 1-alpha)) 539 | ) 540 | m3_quan <- data.table::data.table( 541 | apply(m3, 2, stats::quantile, c(alpha, 0.5, 1-alpha)) 542 | ) 543 | 544 | years <- sort(unique(lubridate::year(date_vec))) 545 | bf_phenos <- NULL 546 | for (i in 1:numYears) { 547 | if (m2_quan[2, ][[i]] > 0.4) { # suppress some amplitude-too-low year 548 | bf_phenos <- rbind(bf_phenos, data.table::data.table( 549 | Year = years[i], 550 | midgup_lower = m3_quan[1, ][[i]], 551 | midgup = m3_quan[2, ][[i]], 552 | midgup_upper = m3_quan[3, ][[i]] 553 | )) 554 | } else { 555 | bf_phenos <- rbind(bf_phenos, data.table::data.table( 556 | Year = years[i], 557 | midgup_lower = NA, 558 | midgup = NA, 559 | midgup_upper = NA 560 | )) 561 | } 562 | } 563 | 564 | # Construct `blsp_fit` object to return 565 | blsp_fit <- list( 566 | phenos = bf_phenos, 567 | params = list(m2 = m2, m3 = m3), 568 | data = data.table::data.table( 569 | date = date_vec, 570 | vi = vi_vec, 571 | weights = weights_vec 572 | ), 573 | cred_int_level = cred_int_level 574 | ) 575 | class(blsp_fit) <- "BlspFit" 576 | 577 | if (verbose) { 578 | message("Done!") 579 | } 580 | return(blsp_fit) 581 | } 582 | 583 | 584 | #' Generate pheno from the predicted curve. 585 | #' 586 | #' Only supports Elmore model (The double-logistic model used in BLSP). 587 | #' This function is used inside the FitBLSP function. 588 | #' 589 | #' @param equation The model equation. 590 | #' @param params The Parameter list. 591 | #' @param t Date vector. 592 | #' @return The phenological timing in day of year (DOY) 593 | #' 594 | #' @noRd 595 | GetPhenosIdx <- function(equation, params, t) { 596 | y <- eval(equation, envir = list( 597 | m1 = params[[1]], m2 = params[[2]], m3 = params[[3]], m4 = params[[4]], 598 | m5 = params[[5]], m6 = params[[6]], m7 = params[[7]], t = t 599 | )) 600 | 601 | d1 <- stats::D(equation, "t") 602 | d2 <- stats::D(d1, "t") 603 | 604 | y1 <- eval(d1, envir = list( 605 | m1 = params[[1]], m2 = params[[2]], m3 = params[[3]], m4 = params[[4]], 606 | m5 = params[[5]], m6 = params[[6]], m7 = params[[7]], t = t 607 | )) 608 | y2 <- eval(d2, envir = list( 609 | m1 = params[[1]], m2 = params[[2]], m3 = params[[3]], m4 = params[[4]], 610 | m5 = params[[5]], m6 = params[[6]], m7 = params[[7]], t = t 611 | )) 612 | k <- abs(y2^2) / ((1 + y1^2)^(3 / 2)) 613 | 614 | d <- diff(y) 615 | d_code <- (d > 0) + (2 * (d < 0)) # 0=no change, 1=inc, 2=dec 616 | 617 | # Find the MidGreenup and MidGreeendown 618 | midgup <- round(params[[3]]) 619 | midgdown <- round(params[[5]]) 620 | 621 | # find peak 622 | peak <- NULL 623 | peaks <- unlist(gregexpr("12", paste(d_code, collapse = ""))) # no match is -1 624 | if (peaks[1] == -1) peaks <- NULL 625 | # no match is -1 626 | flat_peaks <- unlist(gregexpr("10+2", paste(d_code, collapse = ""))) 627 | if (flat_peaks[1] == -1) flat_peaks <- NULL 628 | 629 | if (is.null(peaks) & is.null(flat_peaks)) { 630 | print("no peaks found in in GetPhenoIdx function!") 631 | return(NULL) 632 | } else { 633 | peak <- ifelse (!is.null(peaks), peaks[1], flat_peaks[1]) 634 | } 635 | 636 | # the derivative of curvature 637 | d_k <- c(0, 0, diff(k * 1000, differences = 2)) 638 | # local extremes 639 | localextr <- which(diff(sign(diff(d_k * 1000))) == -2) + 1 640 | 641 | maturity <- localextr[which(localextr < peak & localextr > midgup)] 642 | maturity <- maturity[length(maturity)] 643 | 644 | sene <- localextr[which(localextr > peak & localextr < midgdown)][1] 645 | 646 | gup <- localextr[which(localextr < midgup)] 647 | gup <- gup[length(gup)] 648 | 649 | dormancy <- localextr[which(localextr > (midgdown + 7))][1] 650 | 651 | return(c(gup = gup, midgup = midgup, maturity = maturity, peak = peak, 652 | sene = sene, midgdown = midgdown, dormancy = dormancy)) 653 | } 654 | 655 | 656 | #' Fit the averaged model and get the model parameters. 657 | #' 658 | #' @param date_vec the date vector, be sure to convert the vector to "Date" 659 | #' format or use "yyyy-mm-dd" format string. 660 | #' @param vi_vec The vegetation index vector. 661 | #' @param model A string indicating the model name. For now, only support 662 | #' "dblog7" and "dblog6" for the 7- and 6-parameter double-logistic functions. 663 | #' @return Model parameters to be used as MCMC initial parameters in 664 | #' the FitBLSP function. 665 | #' @export 666 | FitAvgModel <- function(date_vec, vi_vec, model = "dblog7") { 667 | # Check the jags model string 668 | if (!model %in% c("dblog7", "dblog6")) { 669 | warning("The specified model does not exist, dblog7 will be used.") 670 | model <- "dblog7" 671 | } 672 | 673 | # Format data 674 | avg_dt <- FormatAvgData(date_vec, vi_vec) 675 | 676 | # Unpack data 677 | y <- unlist(avg_dt$evi2) 678 | t <- unlist(avg_dt$date) 679 | 680 | # Fake year information for the averaged year 681 | cur_start_date <- as.Date("1970-01-01") 682 | cur_end_date <- as.Date("1970-12-31") 683 | full_date <- seq(cur_start_date, cur_end_date, by = "day") 684 | full_t <- as.integer(full_date - cur_start_date + 1) 685 | 686 | # Fit model to get the prior 687 | avg_fit <- tryCatch( 688 | { 689 | mod <- GetModel(model) 690 | model_str <- mod$model_str 691 | model_equ <- stats::as.formula(paste("VI", "~", model_str)) 692 | 693 | start_li <- as.list(mod$init_val) 694 | names(start_li) <- mod$out_param 695 | 696 | minpack.lm::nlsLM(model_equ, 697 | data = list( 698 | VI = y, 699 | t = as.integer(t) 700 | ), 701 | start = start_li, 702 | lower = mod$init_lwr, 703 | upper = mod$init_upr, 704 | control = list(warnOnly = TRUE) 705 | ) 706 | }, 707 | error = function(e) { 708 | print(paste("Average fit failed", sep = ":")) 709 | return(NULL) 710 | } 711 | ) 712 | 713 | return(avg_fit) 714 | } 715 | 716 | -------------------------------------------------------------------------------- /R/models.R: -------------------------------------------------------------------------------- 1 | # ****************************************************************************** 2 | # This file defines functions to fit the VI curves. 3 | # Date: 2024-04-15 4 | # ****************************************************************************** 5 | 6 | 7 | 8 | #' Get the user selected model structure and parameters 9 | #' 10 | #' @param model_name The name of the model. For now only support `dblog7` and 11 | #' `dblog6` corresponding to the 7- and 6-parameter double-logistic functions. 12 | #' 13 | #' @return A list containing model structure and parameters. 14 | GetModel <- function(model_name) { 15 | switch(tolower(model_name), 16 | "dblog7" = dblog7, 17 | "dblog6" = dblog6, 18 | dblog7 19 | ) 20 | } 21 | 22 | 23 | # Double logistic function w/ the "greendown" parameter 24 | dblog7 <- list( 25 | model_name = "dblog7", 26 | 27 | model_str = "m1 + (m2 - m7 * t) * ((1 / (1 + exp((m3 - t) / m4))) - 28 | (1 / (1 + exp((m5 - t) / m6))))", 29 | 30 | jags_str = "model { 31 | # Likelihood 32 | for (i in 1:n) { 33 | Y[i] ~ dnorm(mu[i], tau_y) 34 | mu[i] <- weights[i] * (m1[yr[i]] + (m2[yr[i]] - m7[yr[i]] * t[i]) * 35 | ((1 / (1 + exp((m3[yr[i]] - t[i]) / m4[yr[i]]))) - 36 | (1 / (1 + exp((m5[yr[i]] - t[i]) / m6[yr[i]]))))) 37 | } 38 | 39 | # Priors 40 | for (j in 1:N) { 41 | M1[j] ~ dnorm(mu_m1, tau[1]) 42 | logit(m1[j]) <- M1[j] 43 | m2[j] ~ dnorm(mu_m2, tau[2]) 44 | m3[j] ~ dnorm(mu_m3, tau[3]) 45 | m4[j] ~ dnorm(mu_m4, tau[4]) 46 | m5[j] ~ dnorm(mu_m5, tau[5]) 47 | m6[j] ~ dnorm(mu_m6, tau[6]) 48 | M7[j] ~ dbeta(4, 4 * (1 - mu_m7 * 100) / (mu_m7 * 100)) 49 | m7[j] <- M7[j] / 100 50 | } 51 | 52 | mu_m1 ~ dunif(0, 0.3) 53 | mu_m2 ~ dunif(0.5, 2) 54 | mu_m3 ~ dunif(0, 185) 55 | mu_m4 ~ dunif(1, 15) 56 | mu_m5 ~ dunif(185, 366) 57 | mu_m6 ~ dunif(1, 15) 58 | mu_m7 ~ dunif(0, 0.01) 59 | 60 | for (k in 1:7) { 61 | tau[k] ~ dgamma(0.1, 0.1) 62 | } 63 | tau_y ~ dgamma(0.1, 0.1) 64 | }", 65 | 66 | out_param = paste0("m", 1:7), 67 | init_param = c("M1", paste0("m", 2:6)), 68 | init_val = c(0.05, 1, 120, 8, 290, 8, 0.001), 69 | init_lwr = c(0, 0.1, 1, 0, 1, 0, 0.00001), 70 | init_upr = c(1, 100, 185, 100, 370, 100, 0.01) 71 | ) 72 | 73 | 74 | # Double logistic function w/o the "greendown" parameter 75 | dblog6 <- list( 76 | model_name = "dblog6", 77 | 78 | model_str = "m1 + m2 * ((1 / (1 + exp((m3 - t) / m4))) - 79 | (1 / (1 + exp((m5 - t) / m6))))", 80 | 81 | jags_str = "model { 82 | # Likelihood 83 | for (i in 1:n) { 84 | Y[i] ~ dnorm(mu[i], tau_y) 85 | mu[i] <- weights[i] * (m1[yr[i]] + m2[yr[i]] * 86 | ((1 / (1 + exp((m3[yr[i]] - t[i]) / m4[yr[i]]))) - 87 | (1 / (1 + exp((m5[yr[i]] - t[i]) / m6[yr[i]]))))) 88 | } 89 | 90 | # Priors 91 | for (j in 1:N) { 92 | M1[j] ~ dnorm(mu_m1, tau[1]) 93 | logit(m1[j]) <- M1[j] 94 | m2[j] ~ dnorm(mu_m2, tau[2]) 95 | m3[j] ~ dnorm(mu_m3, tau[3]) 96 | m4[j] ~ dnorm(mu_m4, tau[4]) 97 | m5[j] ~ dnorm(mu_m5, tau[5]) 98 | m6[j] ~ dnorm(mu_m6, tau[6]) 99 | } 100 | 101 | mu_m1 ~ dunif(0, 0.3) 102 | mu_m2 ~ dunif(0.5, 2) 103 | mu_m3 ~ dunif(0, 185) 104 | mu_m4 ~ dunif(1, 15) 105 | mu_m5 ~ dunif(185, 366) 106 | mu_m6 ~ dunif(1, 15) 107 | 108 | for (k in 1:6) { 109 | tau[k] ~ dgamma(0.1, 0.1) 110 | } 111 | tau_y ~ dgamma(0.1, 0.1) 112 | }", 113 | 114 | out_param = paste0("m", 1:6), 115 | init_param = c("M1", paste0("m", 2:6)), 116 | init_val = c(0.05, 1, 120, 8, 290, 8), 117 | lwr = c(0, 0.1, 1, 0, 1, 0), 118 | upr = c(1, 100, 185, 100, 370, 100) 119 | ) 120 | -------------------------------------------------------------------------------- /R/utils-pipe.R: -------------------------------------------------------------------------------- 1 | #' Pipe operator 2 | #' 3 | #' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 4 | #' 5 | #' @name %>% 6 | #' @rdname pipe 7 | #' @keywords internal 8 | #' @export 9 | #' @importFrom magrittr %>% 10 | #' @usage lhs \%>\% rhs 11 | #' @param lhs A value or the magrittr placeholder. 12 | #' @param rhs A function call using the magrittr semantics. 13 | #' @return The result of calling `rhs(lhs)`. 14 | NULL 15 | -------------------------------------------------------------------------------- /R/vis_fit.R: -------------------------------------------------------------------------------- 1 | #************************************************************************************ 2 | # Description: Visualize model fit results. 3 | # Date: 2022-05-28 4 | #************************************************************************************ 5 | 6 | 7 | #' Visualize the average model fit result. It will show all points as well as the 8 | #' averaged model fit curve. 9 | #' 10 | #' @param date_vec the date vector, be sure to convert the vector to "Date" 11 | #' format or use "yyyy-mm-dd" format string. 12 | #' @param vi_vec The vegetation index vector. 13 | #' @param avg_fit The model fit object returned by `FitAvgModel()`. 14 | #' @param model A string indicating the model name. For now, only support 15 | #' "dblog7" and "dblog6" for the 7- and 6-parameter double-logistic functions. 16 | #' 17 | #' @return A plot showing the average model fit result. 18 | #' 19 | #' @export 20 | #' 21 | #' @examples 22 | #' \dontrun{ 23 | #' avg_dt <- FormatAvgData(landsatEVI2$date, landsatEVI2$evi2) 24 | #' avg_fit <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2) 25 | #' PlotAvg(landsatEVI2$date, landsatEVI2$evi2, avg_fit) 26 | #' } 27 | #' @import data.table 28 | PlotAvg <- function(date_vec, vi_vec, avg_fit, model = "dblog7") { 29 | if (!model %in% c("dblog7", "dblog6")) { 30 | warning("The specified model does not exist, dblog7 will be used.") 31 | model <- "dblog7" 32 | } 33 | mod <- GetModel(model) 34 | 35 | # Format data 36 | avg_dt <- FormatAvgData(date_vec, vi_vec) 37 | 38 | # Fake year information for the averaged year 39 | cur_start_date <- as.Date("1970-01-01") 40 | cur_end_date <- as.Date("1970-12-31") 41 | full_date <- seq(cur_start_date, cur_end_date, by = "day") 42 | full_t <- as.integer(full_date - cur_start_date + 1) 43 | 44 | # Predict from the avg model fit 45 | pred <- NULL 46 | phenos_idx <- NULL 47 | phenos <- NULL 48 | if (!is.null(avg_fit)) { 49 | pred <- stats::predict(avg_fit, newdata = list(t = full_t)) 50 | phenos_idx <- GetPhenosIdx(str2expression(mod$model_str), 51 | params = list( 52 | m1 = stats::coef(avg_fit)["m1"], 53 | m2 = stats::coef(avg_fit)["m2"], 54 | m3 = stats::coef(avg_fit)["m3"], 55 | m4 = stats::coef(avg_fit)["m4"], 56 | m5 = stats::coef(avg_fit)["m5"], 57 | m6 = stats::coef(avg_fit)["m6"], 58 | m7 = stats::coef(avg_fit)["m7"] 59 | ), 60 | t = full_t 61 | ) 62 | phenos <- full_date[unlist(phenos_idx)] 63 | } 64 | 65 | # Plot the figure 66 | plot(avg_dt[, .(date, evi2)], 67 | pch = 16, col = "seagreen", 68 | xlab = "", ylab = "" 69 | ) 70 | graphics::mtext(text = "DOY", side = 1, line = 2) 71 | graphics::mtext(text = "EVI2", side = 2, line = 2) 72 | 73 | graphics::lines(full_date, pred, col = "orange", lwd = 2) 74 | 75 | for (i in 1:length(phenos_idx)) { 76 | graphics::points(full_date[phenos_idx[i]], pred[phenos_idx[i]], 77 | pch = 21, lwd = 2, cex = 1.5, bg = "red" 78 | ) 79 | } 80 | } 81 | 82 | 83 | 84 | #' Plot BLSP model fitting result. 85 | #' 86 | #' @param blsp_fit The object of `BlspFit` class returned by `FitBLSP()` function. 87 | #' @param if_return_fit Logic. Determine whether return the fitted values. Default 88 | #' is `FALSE`. 89 | #' @return A plot showing the BLSP model fitting result. If `if_return_fit` is true, 90 | #' the model fitted time series as well as the 95% credible interval will also be 91 | #' returned. 92 | #' @export 93 | #' 94 | #' @examples 95 | #' \dontrun{ 96 | #' blsp_fit <- FitBLSP(landsatEVI2$date, landsatEVI2$evi2, verbose = TRUE) 97 | #' fitted_dt <- PlotBLSP(blsp_fit, if_return_fit = TRUE) 98 | #' } 99 | #' @import data.table 100 | PlotBLSP <- function(blsp_fit, if_return_fit = FALSE) { 101 | if (class(blsp_fit) != "BlspFit") { 102 | stop("The input should be the output object of `FitBLSP()` function!") 103 | } 104 | 105 | # Unpack data from the object 106 | date_vec <- blsp_fit$data$date 107 | vi_vec <- blsp_fit$data$vi 108 | weights_vec <- blsp_fit$data$weights 109 | if (is.null(weights_vec)) { 110 | weights_vec <- rep(1, length(vi_vec)) 111 | } 112 | bf_phenos <- blsp_fit$phenos 113 | yr <- lubridate::year(date_vec) - lubridate::year(date_vec)[1] + 1 114 | numYears <- length(unique(yr)) 115 | disp_cred_int_level <- round(blsp_fit$cred_int_level*100) 116 | 117 | #~ Predict fitted value for full dates ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 118 | bf_pred <- BLSPFitted(blsp_fit, asCI = TRUE) 119 | years <- sort(unique(lubridate::year(date_vec))) 120 | 121 | 122 | # ~ Do the plot ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 123 | plot(bf_pred$Date, bf_pred$Fitted, 124 | cex = 0, ylim = c(-0.1, 1), 125 | xlab = "Date", ylab = "EVI2", 126 | bty = "L" 127 | ) 128 | graphics::polygon(c(bf_pred$Date, rev(bf_pred$Date)), 129 | c(bf_pred$Fitted_upper, rev(bf_pred$Fitted_lower)), 130 | col = adjustcolor("red", 0.2), 131 | border = NA 132 | ) 133 | graphics::points(date_vec, vi_vec, 134 | pch = 16, 135 | col = sapply(weights_vec, function(i) { 136 | adjustcolor("black", weights_vec[i]) 137 | }), 138 | cex = 0.5 139 | ) 140 | graphics::lines(bf_pred$Date, bf_pred$Fitted, 141 | type = "l", ylim = c(0, 1), 142 | col = "red", lwd = 2 143 | ) 144 | 145 | pheno_names <- colnames(blsp_fit$phenos)[-1] 146 | pheno_names <- pheno_names[-grep("_", pheno_names)] 147 | pheno_colors <- rev(viridis::viridis(9)) 148 | for (k in 1:length(pheno_names)) { 149 | pheno <- pheno_names[k] 150 | phn_dates <- bf_phenos[!is.na(get(pheno)), ][[pheno]] 151 | phn_dates <- as.Date(paste0(years, "-01-01")) + unlist(phn_dates) 152 | 153 | phn_val <- bf_pred[Date %in% as.Date(as.character(phn_dates)), Fitted] 154 | 155 | graphics::points(phn_dates, phn_val, pch = 16, col = pheno_colors[k]) 156 | phn_dates_lower <- as.Date(paste0(years, "-01-01")) + 157 | unlist(bf_phenos[!is.na(get(pheno)), ][[paste0(pheno, "_lwr")]]) 158 | phn_dates_upper <- as.Date(paste0(years, "-01-01")) + 159 | unlist(bf_phenos[!is.na(get(pheno)), ][[paste0(pheno, "_upr")]]) 160 | graphics::segments(phn_dates_lower, phn_val, phn_dates_upper, phn_val) 161 | } 162 | graphics::legend( 163 | graphics::grconvertX(0.5, "ndc"), graphics::grconvertY(0.95, "ndc"), 164 | xjust = 0.5, bty = "n", 165 | ncol = ifelse(length(pheno_names) == 2, 3, 4), 166 | legend = c("Observations", "Median Fit", 167 | paste0(disp_cred_int_level, "% C.I. of fit"), 168 | paste0(disp_cred_int_level, "% C.I. of phenometrics"), 169 | pheno_names 170 | ), 171 | lty = c(NA, 1, NA, 1, NA, rep(NA, length(pheno_names))), 172 | pch = c(16, NA, 15, NA, 16, rep(16, length(pheno_names))), 173 | col = c("black", "red", 174 | adjustcolor("red", 0.2), 175 | "black", 176 | pheno_colors[1:length(pheno_names)] 177 | ), 178 | xpd = NA 179 | ) 180 | graphics::legend("bottomright", bty = "n", 181 | legend = expression(italic( 182 | "*Observation transparency depends on weight" 183 | )), 184 | cex = 0.8 185 | ) 186 | 187 | if (if_return_fit == TRUE) { 188 | return(bf_pred) 189 | } 190 | } 191 | 192 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # blsp: Bayesian land surface phenology model 4 | Welcome to the `blsp` R package for creating a Bayesian land surface phenology model. This is a hierarchical model that quantifies long-term annual land surface phenology from temporally sparse optical remote sensing time series (originally developed for 30 m Landsat time series). 5 | 6 | For a more in-depth description, please read the paper: [Long-term, medium spatial resolution annual land surface phenology with a Bayesian hierarchical model](https://doi.org/10.1016/j.rse.2021.112484), with the citation: 7 | > Gao, X., Gray, J. M., & Reich, B. J. (2021). Long-term, medium spatial resolution annual land surface phenology with a Bayesian hierarchical model. Remote Sensing of Environment, 261, 112484. https://doi.org/10.1016/j.rse.2021.112484 8 | 9 | > **Note** 10 | > 11 | > For the exact version in the paper, please go to the `release/reproduce_paper` branch. 12 | 13 | To cite the package, please use: 14 | 15 | > Xiaojie Gao, Ian R. McGregor, Owen Smith, Isabella Hinks, & Matt Shisler. (2022). The blsp R package with a Bayesian land surface phenology model (1.0). Zenodo. https://doi.org/10.5281/zenodo.6824017 16 | 17 | ## How to install blsp package in R 18 | 19 | We use JAGS (Just Another Gibbs Sampler) software to conduct Markov Chain Monte Carlo (MCMC) sampling for the Bayesian model. Please install JAGS software before installing the `blsp` package. Please visit the [JAGS website](http://mcmc-jags.sourceforge.net/) for installation. Don't worry if you know nothing about JAGS, you don't even need to open it after installing. We use R to communicate with it. 20 | 21 | Next, in the R terminal, run: 22 | ```r 23 | devtools::install_github("ncsuSEAL/Bayesian_LSP", build_vignettes = TRUE) 24 | ``` 25 | Afterwards, you can call the package using `library(blsp)`. Run `help(package = "blsp")` to see the vignette and functions available in the package. 26 | 27 | ## Note 28 | We are currently (as of June 2022) improving the computing speed of the BLSP algorithm, thanks to Matt Shisler and Dr. Brian Reich's help. Be sure to watch or star this repo to keep up with our updates. 29 | 30 | ## The package functionality 31 | The package takes sparse vegetation index observations from the entirety of the Landsat time series (for example), and create a continuous estimate of annual land surface phenology. In addition to calculating start of season (SOS) and end of season (EOS) dates, the model also calculated pixel-wise uncertainty estimates for each of these phenometrics. 32 | 33 | The model fit is shown in the below figure: 34 | 35 | ![](img/model_fit_plot.png) 36 | 37 | And, the estimated phenometrics and their 95% credible intervals are stored in a table returned by the `FitBLSP()` function of the `blsp` package: 38 | 39 | | Year | midgup_lwr | midgup | midgup_upr | midgdown_lwr | midgdown | midgdown_upr | 40 | | :--: | :--------: | :----: | :--------: | :----------: | :------: | :----------: | 41 | | 1984 | 130 | 139 | 146 | 277 | 284 | 291 | 42 | | 1985 | 132 | 138 | 140 | 272 | 281 | 288 | 43 | | ... | ... | ... | ... | ... | ... | ... | 44 | | 2023 | ... | ... | ... | ... | ... | .. | 45 | 46 | Starting from v1.5, in addition to `midgup` (SOS) and `midgdown` (EOS), we also support getting more detailed phenometrics using a threshold-based method. The method can be configured when using `FitBLSP(.., opt = list(method = "threshold"))`. The detailed phenometrics and their amplitude threshold are shown in the following table and figure: 47 | 48 | | Phenometric | Threshold | 49 | | :----------: | ----------------------- | 50 | | Greenup | 15% amplitude in spring | 51 | | MidGreenup | 50% amplitude in spring | 52 | | Maturity | 90% amplitude in spring | 53 | | Peak | 100% amplitude | 54 | | Senescence | 90% amplitude in autumn | 55 | | MidGreendown | 50% amplitude in autumn | 56 | | Dormancy | 15% amplitude in autumn | 57 | 58 | ![](img/model_fit_more_phenos.png) 59 | 60 | Also from v1.5, we support both 6- and 7-parameter double-logistic functions. To specify which function to use, pass a `model` string to the `FitBLSP()` function, e.g., `FitBLSP(..., model = "dblog6")`. To use the 6-parameter model, do `model = "dblog6"`; while `model = "dblog7"` will use the 7-parameter model, which is the default value. 61 | 62 | Starting from v1.7, we added a `greendown_aware` parameter to account for the summer EVI2 greendown phenomenon when using the threshold-based phenometrics. Specifically, when the greendown phenomenon is substantial (e.g., in PhenoCam data), the `Senescence` metric, which is defined as 90% amplitude in autumn, can be biased early. However, this EVI2 decrease is not necessarily `Senescence` (the exact mechanisms that induced this summer greendown are still unclear. Some previous studies have attributed it to shadow and/or leaf angle). So, by using `FitBLSP(.., opt = list(method = "threshold", greendown_aware = TRUE))`, the `Senescence` metric will be retrieved as the end date of summer greendown (or, the edge of the curve), and the `MidGreendown` will be the date with the mininum first derivative of the autumn EVI2 curve after `Senescence`. 63 | 64 | For detailed introduction of the package usage, please use `help(package = "blsp")` to see the vignettes. We also provide Google Earth Engine javascript script and Microsoft Planetary Computer R functions to help users get Landsat time series for any latitude and longitude points so that users can try the `blsp` package with minimal effort in preparing data (see the vignettes). 65 | 66 | > **Note** 67 | > 68 | > Unlike other land surface phenology products, we don't have QA/QC flags. The reason is, from our current experience, that the quality of the retrieved phenometrics can be indicated from the uncertainty. For example, if the uncertainty for a phenometric is very large, it indicates that the phenometric might be of low quality; otherwise, the pheometirc is trustable. This strategy may be changed based on future experience with the BLSP model, though. 69 | > 70 | > Some data pre-processing such as filling in the extremly low values in the winter period using 2th percentile and removing abnormal low values in the summer period can help fitting the model better. Those abnormal observations should be captured by cloud detection but sometimes it fails. 71 | 72 | # Known limitations 73 | Here are some limitations users frequently asked, we appreciate the feedback and want to notify future users to be aware of them. 74 | 75 | - **Computing speed**. As the method uses Markov Chain Monte Carlo (MCMC) sampling to estimate model parameters, it requires some computing power and can be time consuming. This is the reason we do not provide functions for image processing in the package. For image processing, users need to run `blsp` on a super computer using parallel processing. 76 | - **Interannual variability**. As the algorithm computes a particular year's LSP by considering data available within the current year and using information from other years as prior, when data in the current year are very limited, especially for the seasonal transition periods, the prior information would get more weight in the final LSP calculation and thus the overall LSP time series may lack interannual variability. We encourage users to check the uncertainty of phenometrics in the `blsp` result as well as the fitted time series. 77 | 78 | 79 | # Docker 80 | The BLSP docker container installs the required R packages and JAGS. 81 | Assuming that both docker and docker-compose are installed, the container can 82 | be built and started from the CLI by running 83 | ```bash 84 | cd scripts && ./build.sh 85 | ``` 86 | You can enter the container directly by running 87 | ```bash 88 | docker exec -ti blsp bash 89 | ``` 90 | 91 | # Acknowledgments 92 | We thank the following people for their assistance with the creation of this package: 93 | - [Matt Shisler](https://github.com/mattshisler): optimization of the MCMC code 94 | - [Isabella Hinks](https://github.com/iHinks): translation of MCMC code to C++ (the work hasn't been merged to this package, but will come soon.) 95 | - [Owen Smith](https://github.com/ocsmit): development of Docker container 96 | - [Ian McGregor](https://github.com/mcgregorian1): package development, documentation, and vignette 97 | 98 | --- 99 | 100 | _Graphs used in the icon are created by Freepik - Flaticon_ 101 | -------------------------------------------------------------------------------- /blsp-logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 23 | 25 | 45 | 47 | 48 | 50 | image/svg+xml 51 | 53 | 54 | 55 | 56 | 57 | 63 | 79 | 95 | 96 | 101 | 110 | 111 | 117 | 126 | 138 | 139 | 144 | blsp 155 | Bayesian Land Surface Phenology 171 | 194 | 195 | -------------------------------------------------------------------------------- /data/landsatEVI2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/data/landsatEVI2.rda -------------------------------------------------------------------------------- /docker-compose.yaml: -------------------------------------------------------------------------------- 1 | version: '3.4' 2 | services: 3 | blsp: 4 | image: blsp:latest 5 | container_name: blsp 6 | build: ./ 7 | tty: true 8 | stdin_open: true 9 | entrypoint: "/bin/bash" 10 | 11 | -------------------------------------------------------------------------------- /gee/getSampleData.js: -------------------------------------------------------------------------------- 1 | // **************************************************************************************** 2 | // Description: Extract EVI2 time series from Landsat 5, 7, 8, and 9 products for 3 | // point locations. This is to supplement the blsp package in R 4 | // Author: Ian McGregor, Xiaojie Gao, 5 | // Last updated: June 2022 6 | // **************************************************************************************** 7 | 8 | //////////////////////////////////////////////////////////////////////// 9 | // STEP 1: DEFINE VARIABLES AND YOUR DESIRED POINTS 10 | //////////////////////////////////////////////////////////////////////// 11 | 12 | // *************** Define Variables ************************ 13 | // Please adjust this as you need. Note L9 has no data prior to 2021 14 | var startDate = "1984-01-01"; 15 | var endDate = "2022-06-01"; 16 | 17 | var sensor = 18 | ["LANDSAT/LT05/C02/T1_L2", //L5 Collection 2 SR 19 | "LANDSAT/LE07/C02/T1_L2", //L7 Collection 2 SR 20 | "LANDSAT/LC08/C02/T1_L2", //L8 Collection 2 SR 21 | "LANDSAT/LC09/C02/T1_L2" //L9 Collection 2 SR 22 | ]; 23 | 24 | // columns for the output csv 25 | var bandNames = ['satellite', 'date', 'lon', 'lat', 'id', 'evi2', 'QA_PIXEL']; 26 | 27 | // Labels for exporting the csv to google drive 28 | var taskDescription = "exportEVI2"; //description of task in GEE 29 | var folder = "Bayesian_LSP"; //folder to export to, single string 30 | var fileName = "sampleData"; //name of file, e.g. this will be sampleData.csv 31 | 32 | // *************** Define study locations ************************ 33 | // site locations can be either be specified by coordinates... 34 | 35 | // A sample list of coordinates 36 | var points = ee.List([ 37 | [-71.700975, 43.945733], // HQ 38 | [-71.725558, 43.952022], // 1B. 39 | [-71.728739, 43.950917], // 4B. 40 | [-71.731661, 43.958947], // 4T. 41 | [-71.731831, 43.949128], // 5B. 42 | [-71.736869, 43.957400], // 5T. 43 | [-71.742178, 43.955547], // 6T. 44 | [-71.765647, 43.928928], // 7B. 45 | [-71.769733, 43.918358] // 7T. 46 | ]); 47 | 48 | // Create feature collection from points 49 | var samp_pts = ee.FeatureCollection(points.map(function(p){ 50 | var point = ee.Feature( 51 | ee.Geometry.Point(p), { 52 | id: points.indexOf(p) 53 | } 54 | ); 55 | return point; 56 | })); 57 | 58 | // ...Or, upload a csv file with columns "id", "longitude", "latitude" columns, 59 | // and add it to this code as an asset 60 | //var samp_pts = ee.FeatureCollection(table); 61 | 62 | print("Sample Points", samp_pts); 63 | 64 | //////////////////////////////////////////////////////////////////////// 65 | // STEP 2: DEFINE FUNCTIONS 66 | //////////////////////////////////////////////////////////////////////// 67 | 68 | // *************** Define Individual Functions ************************ 69 | /** 70 | * Function to mask clouds based on the pixel_qa band of Landsat data. 71 | * @param {ee.Image} image Input Landsat SR image 72 | * @return {ee.Image} Cloudmasked Landsat SR image 73 | */ 74 | function mask_landsat_sr(image) { 75 | // Bits 3 and 5 are cloud shadow and cloud, respectively. 76 | var cloudShadowBitMask = (1 << 4); 77 | var cloudsBitMask = (1 << 3); 78 | // Get the pixel QA band. 79 | var qa = image.select('QA_PIXEL'); 80 | // Both flags should be set to zero, indicating clear conditions. 81 | var mask = qa.bitwiseAnd(cloudShadowBitMask).eq(0) 82 | .and(qa.bitwiseAnd(cloudsBitMask).eq(0)); 83 | return image.updateMask(mask); 84 | } 85 | 86 | /** 87 | * Function to calculate EVI2. 88 | * @param {nirBand} string NIR band 89 | * @param {redBand} string Red band 90 | * @param {image} a Landsat image 91 | * @return {ee.Image} Landsat SR image with EVI2 band 92 | */ 93 | function calcEVI2(nirBand, redBand){ 94 | var calc = function(image){ 95 | var nir = image.select([nirBand]).multiply(0.0000275).add(-0.2); 96 | var red = image.select([redBand]).multiply(0.0000275).add(-0.2); 97 | var evi2 = image.expression( 98 | '2.5 * ((nir - red) / (1 + nir + 2.4 * red))', { 99 | 'nir': nir, 100 | 'red': red 101 | }); 102 | // ignore anomalous evi2 values < 0 and > 1 103 | var evi2_mask = evi2.lt(1).and(evi2.gt(0)); 104 | evi2 = evi2.updateMask(evi2_mask); 105 | return image.addBands(evi2.rename("evi2")); 106 | }; 107 | return(calc); 108 | } 109 | 110 | /** 111 | * Wrapper function for all steps of the code: for each sensor, load data, 112 | * filter by date and points, cloudmask, get evi2, then identify wanted values 113 | * @param {sensorName} a Landsat image with evi2 band 114 | * @return {ee.FeatureCollection} a collection of features 115 | */ 116 | function wrapper(sensorName){ 117 | // Make sure the name is a string 118 | var sens = ee.String(sensorName); 119 | 120 | // Identify which Landsat it is (matters for NIR and Red band selection below) 121 | var landsatType = sens.match('[8-9]'); 122 | 123 | var evi2Bands = ee.Algorithms.If(landsatType.size().eq(0), 124 | ee.List(["SR_B3", "SR_B4", "QA_PIXEL"]), 125 | ee.List(["SR_B4", "SR_B5", "QA_PIXEL"])); 126 | var nir = ee.List(evi2Bands).get(1); 127 | var red = ee.List(evi2Bands).get(0); 128 | 129 | // Create the image collection, then filter by date and points, then 130 | // apply cloudmask and evi2 calculation 131 | var IC = ee.ImageCollection(sens); 132 | 133 | var fullTS = IC.filterDate(startDate, endDate) 134 | .filterBounds(samp_pts) 135 | .select(evi2Bands) 136 | .map(mask_landsat_sr) 137 | .map(calcEVI2(nir, red)); 138 | 139 | // Get the wanted values for each point for each image 140 | function getValsEachImage(img){ 141 | 142 | // Now we get the wanted values per point. Specifically, we make 143 | // a feature for each point, whose properties are the values we 144 | // want to export. This returns a feature collection 145 | var getVals = samp_pts.map(function(pt){ 146 | var ID = pt.get('id'); 147 | var thispoint = pt.geometry(); 148 | var thiscoord = thispoint.coordinates(); 149 | 150 | var date = img.date().format('yyyy-MM-dd'); 151 | var value = img.select(['evi2', 'QA_PIXEL']) 152 | .reduceRegion(ee.Reducer.first(), thispoint); 153 | 154 | var output = ee.Feature(thispoint, 155 | {date: date, satellite: sens, id: ID, 156 | lat: thiscoord.get(0), lon: thiscoord.get(1) 157 | }) 158 | .set(value); 159 | 160 | return(output); 161 | }); 162 | return(getVals); 163 | } 164 | 165 | var out = fullTS.map(getValsEachImage); 166 | return(ee.FeatureCollection(out.flatten())); 167 | } 168 | 169 | //////////////////////////////////////////////////////////////////////// 170 | // STEP 3: RUN THE MAIN CODE AND EXPORT 171 | //////////////////////////////////////////////////////////////////////// 172 | 173 | // *************** Run the main code ************************ 174 | var loop = sensor.map(wrapper); 175 | print("Main output", loop); 176 | 177 | // Here, loop is a list because 'sensor' is a list, so we need to merge 178 | var combined = loop[0].merge(loop[1]).merge(loop[2]).merge(loop[3]); 179 | print("First element example", combined.first()); 180 | 181 | // Export to csv 182 | Export.table.toDrive( 183 | {collection: combined, 184 | description: taskDescription, 185 | folder: folder, 186 | fileNamePrefix: fileName, 187 | selectors: bandNames 188 | } 189 | ); 190 | -------------------------------------------------------------------------------- /img/model_fit_more_phenos.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/img/model_fit_more_phenos.png -------------------------------------------------------------------------------- /img/model_fit_phenos.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/img/model_fit_phenos.png -------------------------------------------------------------------------------- /img/model_fit_plot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/img/model_fit_plot.png -------------------------------------------------------------------------------- /man/BLSPFitted.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod_fit.R 3 | \name{BLSPFitted} 4 | \alias{BLSPFitted} 5 | \title{Get the BLSP fitted curves} 6 | \usage{ 7 | BLSPFitted(blsp_fit, asCI = FALSE) 8 | } 9 | \arguments{ 10 | \item{blsp_fit}{The "BlspFit" object.} 11 | 12 | \item{asCI}{Logical. Default is \code{TRUE}, which means the fitted curves will be 13 | summarized as median and 95\% credibel interval.} 14 | } 15 | \value{ 16 | The fitted curves, or the summary, for each year. 17 | } 18 | \description{ 19 | The funciton uses the "BlspFit" object returned by the "FitBLSP" function to 20 | predict the fitted daily VI curves. 21 | } 22 | -------------------------------------------------------------------------------- /man/FitAvgModel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod_fit.R 3 | \name{FitAvgModel} 4 | \alias{FitAvgModel} 5 | \title{Fit the averaged model and get the model parameters.} 6 | \usage{ 7 | FitAvgModel(date_vec, vi_vec, model = "dblog7") 8 | } 9 | \arguments{ 10 | \item{date_vec}{the date vector, be sure to convert the vector to "Date" 11 | format or use "yyyy-mm-dd" format string.} 12 | 13 | \item{vi_vec}{The vegetation index vector.} 14 | 15 | \item{model}{A string indicating the model name. For now, only support 16 | "dblog7" and "dblog6" for the 7- and 6-parameter double-logistic functions.} 17 | } 18 | \value{ 19 | Model parameters to be used as MCMC initial parameters in 20 | the FitBLSP function. 21 | } 22 | \description{ 23 | Fit the averaged model and get the model parameters. 24 | } 25 | -------------------------------------------------------------------------------- /man/FitBLSP.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod_fit.R 3 | \name{FitBLSP} 4 | \alias{FitBLSP} 5 | \title{Fit a Bayesian mixed hierarchical land urface phenology model.} 6 | \usage{ 7 | FitBLSP( 8 | date_vec, 9 | vi_vec, 10 | weights_vec = NULL, 11 | model = "dblog7", 12 | init_values = NULL, 13 | start_yr = NULL, 14 | end_yr = NULL, 15 | cred_int_level = 0.9, 16 | opt = NULL, 17 | verbose = FALSE 18 | ) 19 | } 20 | \arguments{ 21 | \item{date_vec}{The date vector, be sure to convert the vector to "Date" 22 | format or use "yyyy-mm-dd" format string.} 23 | 24 | \item{vi_vec}{The vegetation index vector.} 25 | 26 | \item{weights_vec}{A numeric vector of same length as vi_vec specifying the 27 | weights for the supplied observations. Must be between 0 and 1, inclusive.} 28 | 29 | \item{model}{A string indicating the model name. For now, only support 30 | "dblog7" and "dblog6" for the 7- and 6-parameter double-logistic functions.} 31 | 32 | \item{init_values}{Initial values for MCMC sampling. By default, it is 33 | assgined \code{NULL}. It could also be an object returned from the \code{FitAvgModel()} 34 | function that fits an averaged model or a numeric vector provided by the user.} 35 | 36 | \item{start_yr}{The start year of the result. Default is NULL, which means 37 | determined by data.} 38 | 39 | \item{end_yr}{The end year of the result. Default is NULL, which means 40 | determined by data.} 41 | 42 | \item{cred_int_level}{A scalar value from 0 to 1 (exclusive) that specifies 43 | the level for equal-tailed credible intervals of the estimated phenometrics. 44 | The default level is 0.9, generating \verb{90\%} credible intervals. The end 45 | points of these intervals define the upper and lower bounds for the estimated 46 | phenometrics.} 47 | 48 | \item{opt}{An option list that contains additional configurations. For now, 49 | only support \code{list(method = "threshold")} to indicate that use the 50 | threshold-based method to retrive phenometrics instead of the default SOS and 51 | EOS. The threshold-based method will produce 7 phenometrics including 52 | Greenup, MidGreenup, Maturity, Peak, Senescence, MidGreendown, and Dormancy 53 | using VI amplitude thresholds of 15\%, 50\%, 90\%, and 100\%, respectively.} 54 | 55 | \item{verbose}{logical. If \code{TRUE}, the progress will be reported.} 56 | } 57 | \value{ 58 | An object of class \code{BlspFit} will be returned. The object contains the 59 | estimated spring and autumn phenometrics for each year, the generated model 60 | parameter samples, and the input data. 61 | } 62 | \description{ 63 | This function fits a Bayesian mixed hierarchical land surface phenology model 64 | to the supplied data (can be sparse), and returns phenometrics for the 65 | entire time frame. For further explanation, please see the vignette. 66 | } 67 | \examples{ 68 | \dontrun{ 69 | data(landsatEVI2) 70 | blsp_fit <- FitBLSP(date_vec = landsatEVI2$date, vi_vec = landsatEVI2$evi2) 71 | } 72 | } 73 | -------------------------------------------------------------------------------- /man/FitBLSP_spring.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mod_fit.R 3 | \name{FitBLSP_spring} 4 | \alias{FitBLSP_spring} 5 | \title{Fit a Bayesian mixed hierarchical land surface phenology model. Spring only! 6 | Note that the result CANNOT be used to plot the fit.} 7 | \usage{ 8 | FitBLSP_spring( 9 | date_vec, 10 | vi_vec, 11 | weights_vec = NULL, 12 | initValues = NULL, 13 | cred_int_level = 0.9, 14 | verbose = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{date_vec}{The date vector, be sure to convert the vector to "Date" 19 | format or use "yyyy-mm-dd" format string.} 20 | 21 | \item{vi_vec}{The vegetation index vector.} 22 | 23 | \item{weights_vec}{A numeric vector of same length as vi_vec specifying the 24 | weights for the supplied observations. Must be between 0 and 1, inclusive.} 25 | 26 | \item{initValues}{Initial values for MCMC sampling. By default, it is 27 | assgined \code{NULL}. It could also be an object returned from the \code{FitAvgModel()} 28 | function that fits an averaged model or a numeric vector provided by the user.} 29 | 30 | \item{cred_int_level}{A scalar value from 0 to 1 (exclusive) that specifies 31 | the level for equal-tailed credible intervals of the estimated phenometrics. 32 | The default level is 0.9, generating \verb{90\%} credible intervals. The end 33 | points of these intervals define the upper and lower bounds for the estimated 34 | phenometrics.} 35 | 36 | \item{verbose}{logical. If \code{TRUE}, the progress will be reported.} 37 | } 38 | \value{ 39 | An object of class \code{BlspFit} will be returned. The object contains the 40 | estimated spring and autumn phenometrics for each year, the generated model 41 | parameter samples, and the input data. 42 | } 43 | \description{ 44 | This function fits a Bayesian mixed hierarchical land surface phenology model 45 | to the supplied data (can be sparse), and returns phenometrics for the 46 | entire time frame. For further explanation, please see the vignette. 47 | } 48 | \examples{ 49 | \dontrun{ 50 | data(landsatEVI2) 51 | blsp_fit <- FitBLSP(date_vec = landsatEVI2$date, vi_vec = landsatEVI2$evi2) 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /man/GetEvi2PointTs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dat_dl_point_ts.R 3 | \name{GetEvi2PointTs} 4 | \alias{GetEvi2PointTs} 5 | \title{Use Microsoft Planetary Computer with STAC API to get Landsat EVI2 time 6 | series for any point location specified by longitude and latitude.} 7 | \usage{ 8 | GetEvi2PointTs(pt_coords, focalDates = "1984-01-01/2022-12-31", ncores = 1) 9 | } 10 | \arguments{ 11 | \item{pt_coords}{Point location. Longitude and latitude.} 12 | 13 | \item{focalDates}{Temporal period.} 14 | 15 | \item{ncores}{Number of cores used to parallel the process.} 16 | } 17 | \value{ 18 | A data.table containing EVI2 time series along with QA values. 19 | } 20 | \description{ 21 | Use Microsoft Planetary Computer with STAC API to get Landsat EVI2 time 22 | series for any point location specified by longitude and latitude. 23 | } 24 | \examples{ 25 | \dontrun{ 26 | pt_coords <- data.table::data.table(x = -71.700975, y = 43.945733) 27 | focalDates <- "1984-01-01/1989-06-04" 28 | ncores <- 5 29 | val_dt <- GetEvi2PointTs(pt_coords, ncore = ncores) 30 | val_dt <- data.table::setorder(val_dt, date) 31 | plot(val_dt[qa == 0, .(date, evi2)], pch = 16, type = "b") 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /man/GetModel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/models.R 3 | \name{GetModel} 4 | \alias{GetModel} 5 | \title{Get the user selected model structure and parameters} 6 | \usage{ 7 | GetModel(model_name) 8 | } 9 | \arguments{ 10 | \item{model_name}{The name of the model. For now only support \code{dblog7} and 11 | \code{dblog6} corresponding to the 7- and 6-parameter double-logistic functions.} 12 | } 13 | \value{ 14 | A list containing model structure and parameters. 15 | } 16 | \description{ 17 | Get the user selected model structure and parameters 18 | } 19 | -------------------------------------------------------------------------------- /man/PlotAvg.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vis_fit.R 3 | \name{PlotAvg} 4 | \alias{PlotAvg} 5 | \title{Visualize the average model fit result. It will show all points as well as the 6 | averaged model fit curve.} 7 | \usage{ 8 | PlotAvg(date_vec, vi_vec, avg_fit, model = "dblog7") 9 | } 10 | \arguments{ 11 | \item{date_vec}{the date vector, be sure to convert the vector to "Date" 12 | format or use "yyyy-mm-dd" format string.} 13 | 14 | \item{vi_vec}{The vegetation index vector.} 15 | 16 | \item{avg_fit}{The model fit object returned by \code{FitAvgModel()}.} 17 | 18 | \item{model}{A string indicating the model name. For now, only support 19 | "dblog7" and "dblog6" for the 7- and 6-parameter double-logistic functions.} 20 | } 21 | \value{ 22 | A plot showing the average model fit result. 23 | } 24 | \description{ 25 | Visualize the average model fit result. It will show all points as well as the 26 | averaged model fit curve. 27 | } 28 | \examples{ 29 | \dontrun{ 30 | avg_dt <- FormatAvgData(landsatEVI2$date, landsatEVI2$evi2) 31 | avg_fit <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2) 32 | PlotAvg(landsatEVI2$date, landsatEVI2$evi2, avg_fit) 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /man/PlotBLSP.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vis_fit.R 3 | \name{PlotBLSP} 4 | \alias{PlotBLSP} 5 | \title{Plot BLSP model fitting result.} 6 | \usage{ 7 | PlotBLSP(blsp_fit, if_return_fit = FALSE) 8 | } 9 | \arguments{ 10 | \item{blsp_fit}{The object of \code{BlspFit} class returned by \code{FitBLSP()} function.} 11 | 12 | \item{if_return_fit}{Logic. Determine whether return the fitted values. Default 13 | is \code{FALSE}.} 14 | } 15 | \value{ 16 | A plot showing the BLSP model fitting result. If \code{if_return_fit} is true, 17 | the model fitted time series as well as the 95\% credible interval will also be 18 | returned. 19 | } 20 | \description{ 21 | Plot BLSP model fitting result. 22 | } 23 | \examples{ 24 | \dontrun{ 25 | blsp_fit <- FitBLSP(landsatEVI2$date, landsatEVI2$evi2, verbose = TRUE) 26 | fitted_dt <- PlotBLSP(blsp_fit, if_return_fit = TRUE) 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /man/SanityCheck.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hlp_funs.R 3 | \name{SanityCheck} 4 | \alias{SanityCheck} 5 | \title{Check if user inputs are reasonable} 6 | \usage{ 7 | SanityCheck(date_vec, vi_vec, weights_vec, model, cred_int_level, init_values) 8 | } 9 | \arguments{ 10 | \item{date_vec}{The date vector, be sure to convert the vector to "Date" 11 | format or use "yyyy-mm-dd" format string.} 12 | 13 | \item{vi_vec}{The vegetation index vector.} 14 | 15 | \item{weights_vec}{A numeric vector of same length as vi_vec specifying the 16 | weights for the supplied observations. Must be between 0 and 1, inclusive.} 17 | 18 | \item{model}{The model string.} 19 | 20 | \item{cred_int_level}{A scalar value from 0 to 1 (exclusive) that specifies 21 | the level for equal-tailed credible intervals of the estimated phenometrics. 22 | The default level is 0.9, generating \verb{90\%} credible intervals. The end 23 | points of these intervals define the upper and lower bounds for the estimated 24 | phenometrics.} 25 | 26 | \item{init_values}{Initial values for MCMC sampling. By default, it is 27 | assgined \code{NULL}. It could also be an object returned from the \code{FitAvgModel()} 28 | function that fits an averaged model or a numeric vector provided by the 29 | user.} 30 | } 31 | \description{ 32 | Check if user inputs are reasonable 33 | } 34 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/man/figures/logo.png -------------------------------------------------------------------------------- /man/landsatEVI2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{landsatEVI2} 5 | \alias{landsatEVI2} 6 | \title{Landsat EVI2 time series.} 7 | \format{ 8 | A data frame with 802 rows and 3 variables: 9 | \describe{ 10 | \item{date}{Observation dates} 11 | \item{evi2}{The two-band enhanced vegetation index value} 12 | \item{snow}{Logical, indicates whether the observation contains snow} 13 | } 14 | } 15 | \usage{ 16 | landsatEVI2 17 | } 18 | \description{ 19 | An Example EVI2 time series from Landsat observations. 20 | } 21 | \keyword{datasets} 22 | -------------------------------------------------------------------------------- /man/pipe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-pipe.R 3 | \name{\%>\%} 4 | \alias{\%>\%} 5 | \title{Pipe operator} 6 | \usage{ 7 | lhs \%>\% rhs 8 | } 9 | \arguments{ 10 | \item{lhs}{A value or the magrittr placeholder.} 11 | 12 | \item{rhs}{A function call using the magrittr semantics.} 13 | } 14 | \value{ 15 | The result of calling \code{rhs(lhs)}. 16 | } 17 | \description{ 18 | See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /requirements/requirements.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | pkgs <- c( 4 | "data.table", 5 | "rjags", 6 | "minpack.lm", 7 | "RColorBrewer", 8 | "viridis", 9 | "lubridate", 10 | "profvis", 11 | "bench", 12 | "miniUI", 13 | "pkgdown", 14 | "devtools", 15 | "minpack.lm", 16 | "rstac", 17 | "terra" 18 | ) 19 | 20 | install.packages(pkgs, repos='http://cran.us.r-project.org', dependencies=TRUE) 21 | -------------------------------------------------------------------------------- /scripts/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cd .. 4 | 5 | docker-compose build 6 | 7 | docker-compose up -d blsp 8 | -------------------------------------------------------------------------------- /scripts/test.sh: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/scripts/test.sh -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(blsp) 3 | 4 | test_check("blsp") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-dat_cl.R: -------------------------------------------------------------------------------- 1 | #************************************************************************************ 2 | # Description: Test data cleaning functions. 3 | # Date: 2022-04-08 4 | #************************************************************************************ 5 | 6 | 7 | test_that("multiplication works", { 8 | expect_equal(2 * 2, 4) 9 | }) -------------------------------------------------------------------------------- /tests/testthat/test-dat_dl.R: -------------------------------------------------------------------------------- 1 | #************************************************************************************ 2 | # Description: Test data downloading functions. 3 | # Date: 2022-04-08 4 | #************************************************************************************ 5 | 6 | test_that("multiplication works", { 7 | expect_equal(2 * 2, 4) 8 | }) 9 | -------------------------------------------------------------------------------- /tests/testthat/test-mod_fit.R: -------------------------------------------------------------------------------- 1 | #******************************************************************************* 2 | # Description: Test model fitting related functions 3 | # Date: 2022-04-08 4 | #******************************************************************************* 5 | 6 | # Test `FitAvgModel` 7 | test_that("Fitting the average model works", { 8 | data(landsatEVI2) 9 | avg_mod <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2) 10 | expect_type(avg_mod, "list") 11 | 12 | est_coef <- coef(avg_mod) 13 | 14 | # to allow some tolerance 15 | est_coef <- round(est_coef, 3) 16 | ept_coef <- c( 17 | m1 = 1.74e-01, 18 | m2 = 7.26e-01, 19 | m3 = 1.35672e+02, 20 | m4 = 8.403e+00, 21 | m5 = 2.93534e+02, 22 | m6 = 1.1898e+01, 23 | m7 = 1.0e-03 24 | ) 25 | expect_equal(est_coef, ept_coef) 26 | }) 27 | 28 | 29 | # Test `FitAvgModel` for both 6- and 7- parameter models 30 | test_that("Fit the average models 6- and 7-parameter models", { 31 | skip_on_cran() 32 | 33 | data(landsatEVI2) 34 | avg_mod <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2, model = "dblog7") 35 | expect_equal( 36 | as.numeric(coef(avg_mod)), 37 | c(0.174, 0.725, 135.672, 8.403, 293.533, 11.898, 0.001), 38 | tolerance = 0.001 39 | ) 40 | 41 | avg_mod <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2, 42 | model = "dblog6" 43 | ) 44 | expect_equal( 45 | as.numeric(coef(avg_mod)), 46 | c(0.172, 0.524, 133.280, 7.245, 286.919, 15.829), 47 | tolerance = 0.001 48 | ) 49 | }) 50 | 51 | 52 | # Test `FitBLSP` 53 | test_that("BLSP model w/ default options works", { 54 | skip_on_cran() 55 | 56 | data(landsatEVI2) 57 | model_init <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2) 58 | blsp_fit <- FitBLSP( 59 | date_vec = landsatEVI2$date, 60 | vi_vec = landsatEVI2$evi2, 61 | weights_vec = ifelse(landsatEVI2$snow == TRUE, 0.1, 1), 62 | init_values = model_init, 63 | verbose = FALSE 64 | ) 65 | 66 | expect_s3_class(blsp_fit, "BlspFit") 67 | expect_equal(blsp_fit$data, data.table::data.table( 68 | date = landsatEVI2$date, 69 | vi = landsatEVI2$evi2, 70 | weights = ifelse(landsatEVI2$snow == TRUE, 0.1, 1) 71 | )) 72 | 73 | # The output of FitBLSP function is a bit weird, should revise it and chagne 74 | # here later. 75 | est_lsp <- data.frame(blsp_fit$phenos) 76 | est_lsp <- round(est_lsp, 0) 77 | 78 | # Check the values 79 | expect_equal(est_lsp$Year, 1984:2019) 80 | 81 | # Allow 5 days deviance 82 | CheckDeviance <- function(val, ept) { 83 | if (all(abs(val - ept) < 5)) { 84 | return(TRUE) 85 | } else { 86 | return(FALSE) 87 | } 88 | } 89 | 90 | expect_true(CheckDeviance(est_lsp$midgup_lwr, c( 91 | 132, 133, 133, 137, 136, 134, 133, 131, 137, 133, 138, 136, 133, 137, 92 | 132, 135, 135, 131, 135, 134, 132, 137, 136, 135, 136, 132, 126, 138, 93 | 133, 131, 137, 134, 138, 134, 135, 137 94 | ))) 95 | expect_true(CheckDeviance(est_lsp$midgup, c( 96 | 139, 139, 139, 141, 140, 140, 140, 135, 141, 138, 142, 141, 140, 144, 97 | 137, 140, 139, 136, 140, 140, 136, 142, 141, 139, 140, 136, 132, 143, 98 | 139, 136, 141, 139, 142, 139, 139, 141 99 | ))) 100 | expect_true(CheckDeviance(est_lsp$midgup_upr, c( 101 | 146, 147, 144, 147, 145, 147, 146, 140, 147, 144, 148, 148, 145, 151, 102 | 142, 145, 145, 142, 146, 147, 141, 147, 145, 143, 144, 140, 139, 148, 103 | 146, 141, 144, 143, 146, 144, 142, 145 104 | ))) 105 | expect_true(CheckDeviance(est_lsp$midgdown_lwr, c( 106 | 279, 276, 277, 280, 276, 278, 279, 277, 283, 280, 279, 279, 281, 279, 107 | 278, 279, 279, 279, 281, 280, 281, 282, 279, 282, 282, 279, 281, 277, 108 | 275, 275, 282, 284, 283, 283, 282, 281 109 | ))) 110 | expect_true(CheckDeviance(est_lsp$midgdown, c( 111 | 285, 284, 285, 285, 284, 285, 285, 284, 287, 285, 285, 285, 286, 285, 112 | 285, 285, 285, 285, 286, 285, 286, 286, 285, 286, 286, 285, 286, 285, 113 | 284, 283, 286, 288, 287, 287, 286, 286 114 | ))) 115 | expect_true(CheckDeviance(est_lsp$midgdown_upr, c( 116 | 290, 289, 290, 291, 289, 289, 290, 288, 295, 290, 290, 291, 292, 291, 117 | 291, 290, 291, 290, 295, 291, 292, 292, 289, 294, 292, 289, 291, 290, 118 | 288, 288, 293, 298, 298, 295, 295, 293 119 | ))) 120 | 121 | 122 | }) 123 | 124 | 125 | test_that("BLSP using 6-parameter double-logistic w/ default options works", { 126 | skip_on_cran() 127 | 128 | data(landsatEVI2) 129 | model_init <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2, 130 | model = "dblog6" 131 | ) 132 | 133 | blsp_fit <- FitBLSP( 134 | date_vec = landsatEVI2$date, 135 | vi_vec = landsatEVI2$evi2, 136 | model = "dblog6", 137 | init_values = model_init, 138 | weights_vec = ifelse(landsatEVI2$snow == TRUE, 0.1, 1), 139 | verbose = FALSE 140 | ) 141 | 142 | expect_true(!is.null(blsp_fit$phenos)) 143 | expect_true(!is.null(blsp_fit$params)) 144 | }) 145 | 146 | 147 | test_that("BLSP using the 6-parameter model w/ threshold phenometrics works", { 148 | skip_on_cran() 149 | 150 | data(landsatEVI2) 151 | model_init <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2, 152 | model = "dblog6" 153 | ) 154 | 155 | blsp_fit <- FitBLSP( 156 | date_vec = landsatEVI2$date, 157 | vi_vec = landsatEVI2$evi2, 158 | model = "dblog6", 159 | init_values = model_init, 160 | weights_vec = ifelse(landsatEVI2$snow == TRUE, 0.1, 1), 161 | opt = list(method = "threshold"), 162 | verbose = FALSE 163 | ) 164 | 165 | expect_true(!is.null(blsp_fit$phenos)) 166 | expect_true(ncol(blsp_fit$phenos) == 22) 167 | expect_true(!is.null(blsp_fit$params)) 168 | }) 169 | 170 | 171 | test_that("BLSP using the 7-parameter model w/ threshold phenometrics works", { 172 | skip_on_cran() 173 | 174 | data(landsatEVI2) 175 | model_init <- FitAvgModel(landsatEVI2$date, landsatEVI2$evi2, 176 | model = "dblog7" 177 | ) 178 | 179 | blsp_fit <- FitBLSP( 180 | date_vec = landsatEVI2$date, 181 | vi_vec = landsatEVI2$evi2, 182 | model = "dblog7", 183 | init_values = model_init, 184 | weights_vec = ifelse(landsatEVI2$snow == TRUE, 0.1, 1), 185 | opt = list(method = "threshold"), 186 | verbose = TRUE 187 | ) 188 | 189 | expect_true(!is.null(blsp_fit$phenos)) 190 | expect_true(ncol(blsp_fit$phenos) == 22) 191 | expect_true(!is.null(blsp_fit$params)) 192 | }) 193 | 194 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /vignettes/geeResults.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/vignettes/geeResults.png -------------------------------------------------------------------------------- /vignettes/introduction.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Introduction to blsp" 3 | author: "Xiaojie Gao, Ian R. McGregor, Owen Smith, Izzi Hinks, Matt Shisler" 4 | output: rmarkdown::html_vignette 5 | vignette: > 6 | %\VignetteIndexEntry{Introduction to blsp} 7 | %\VignetteEngine{knitr::rmarkdown} 8 | %\VignetteEncoding{UTF-8} 9 | --- 10 | 11 | ```{r, include = FALSE} 12 | knitr::opts_chunk$set( 13 | eval=TRUE, 14 | collapse = TRUE, 15 | comment = "#>" 16 | ) 17 | ``` 18 | 19 | 20 | 21 | # Background 22 | The code was originally developed by [Gao et al 2021](https://www.sciencedirect.com/science/article/pii/S0034425721002029?via%3Dihub), whose paper detailed a Bayesian hierarchical model to quantify land surface phenology from disparate, optical remote sensing time series. In other words, the model is able to take sparse vegetation index observations from the entirety of the Landsat time series (for example), and create a continuous estimate of annual land surface phenology. In addition to calculating start of season (SOS) and end of season (EOS) dates, the model also calculated pixel-wise uncertainty estimates for each of these phenometrics. 23 | 24 | This vignette will walk you through the `blsp` package and how to use it. For the source code, please visit the [Github repository](https://github.com/ncsuSEAL/Bayesian_LSP). 25 | 26 | # Running the code 27 | ## Set-up 28 | As an example dataset, we will use the `landsatEVI2` dataset, which has EVI2 (two-band enhanced vegetation index, for more details, see [here](https://en.wikipedia.org/wiki/Enhanced_vegetation_index)) data calculated from Landsats 5-8 from 1984-2019. For each measurement, there is a corresponding, boolean snow flag (to be used for assigning weights). 29 | ```{r laod-data} 30 | library(blsp) 31 | data(landsatEVI2) 32 | ``` 33 | 34 | ## Fitting the model 35 | At its core, all you need to run the main function (`FitBLSP`) is a vector of vegetation index data that follows a [double logistic function](https://www.desmos.com/calculator/rftz67g7eb) (e.g. NDVI, EVI, EVI2), and the corresponding dates of the individual data points. With these, running the code is simple. 36 | 37 | Here to save some computing time but show the power of the BLSP algorithm in handling data sparsity, we only use data from 1984 to 1994 to fit the model. 38 | ```{r fit-blsp} 39 | sub_dt <- landsatEVI2[lubridate::year(date) %in% 1984:1994, ] 40 | results <- FitBLSP( 41 | date_vec = sub_dt$date, 42 | vi_vec = sub_dt$evi2, 43 | opt = list(method = "threshold"), 44 | verbose = TRUE 45 | ) 46 | ``` 47 | 48 | The results are stored in an object with three elements. First, "phenos" is a table containing the estimated day of year (DOY) of "midgreenup"(or SOS) and "midgreendown" (or EOS) for each year contained in the sample data, along with upper and lower bounds. Second, "params" is a table containing the generated model parameter samples by the [Markov chain Monte Carlo (MCMC) sampling](https://en.wikipedia.org/wiki/Markov_chain_Monte_Carlo). Third, "data" is the input data table used to fit the BLSP algorithm. 49 | ```{r blsp-result-structure} 50 | str(results) 51 | ``` 52 | 53 | Let's plot the reconstruction of the EVI2 time series using the supplied data. This will take a little time to run as the function will try each combination of the MCMC-generated parameters to predict the best fit curve. 54 | ```{r blsp-fit-figure, fig.width=7.5, fig.height=4} 55 | fitted_dt <- PlotBLSP(results, if_return_fit = TRUE) 56 | ``` 57 | 58 | We see that "fitted_dt" is a data table with the information used to construct the plot. 59 | ```{r blsp-fitted-table} 60 | head(fitted_dt) 61 | ``` 62 | 63 | ### Changing weights 64 | Some users may want to assign different weights to certain observations. For example, perhaps the QA for several days is bad and we want to downweight those observations such that they contribute less to the posterior distribution. To do so, we supply a vector of equal length to `vi_vec` in the range [0,1]. In the sample data, the `snow` column indicates the presence of snow for the corresponding dates. Here, we will assign weights of 0.1 to those observations. (Again, we only use data from 1984 to 1994 as an example) 65 | ```{r assign-weights} 66 | sub_dt <- landsatEVI2[lubridate::year(date) %in% 1984:1994, 67 | .(date, evi2, weights = ifelse(snow, 0.1, 1), snow) 68 | ] 69 | head(sub_dt) 70 | ``` 71 | 72 | Adding in weights will make the code run longer. The reason is that the downweighted observations can make the data more sparse than it already is (e.g., if some points have weight near 0, they would contribute little information), thus the Bayesian model may need more time to converge. 73 | 74 | Compare the first few rows of "phenos" below with the previous results above. 75 | ```{r blsp-with-weights} 76 | results <- FitBLSP( 77 | date_vec = sub_dt$date, 78 | vi_vec = sub_dt$evi2, 79 | weights_vec = sub_dt$weights, 80 | verbose = TRUE 81 | ) 82 | head(results$phenos) 83 | ``` 84 | 85 | 86 | ### Assigning initial values 87 | As documented in [Gao et al 2021](https://www.sciencedirect.com/science/article/pii/S0034425721002029?via%3Dihub), good initial values can save some time for the model to converge. By default, the `initValues` of the `FitBLSP()` function are determined by the BLSP model so the users don't have to provide them. But if you want, we *can* get initial values from fitting an average model in which all years of data are pooled together. However, there is some risk with this, as the average model inherently can't successfully fit all time series data (that's one of the reasons that we need the BLSP model!). If you try obtaining initial values using `FitAvgModel` with your data and it fails, then we suggest simply running `FitBLSP()` with the default `initValues` argument of `NULL`. 88 | 89 | ```{r fit-avg-model} 90 | avg_fit <- FitAvgModel(sub_dt$date, sub_dt$evi2) 91 | print(avg_fit) 92 | ``` 93 | 94 | The average model can also be plotted out: 95 | ```{r avg-fit-figure, fig.width=7, fig.height=5} 96 | par(mar = c(3, 3, 1, 1)) 97 | PlotAvg( 98 | date_vec = sub_dt$date, 99 | vi_vec = sub_dt$evi2, 100 | avg_fit = avg_fit 101 | ) 102 | ``` 103 | 104 | Returning to `FitBLSP()`, the `iniValues` argument can either be a numeric vector or an object returned by the `FitAvgModel()` function. Here we will use the latter. 105 | ```{r blsp-with-initVal} 106 | results <- FitBLSP( 107 | date_vec = sub_dt$date, 108 | vi_vec = sub_dt$evi2, 109 | init_values = avg_fit, 110 | verbose = TRUE 111 | ) 112 | ``` 113 | 114 | We can then see the result of the fit: 115 | ```{r blsp-result} 116 | str(results) 117 | ``` 118 | 119 | 120 | ## Processing BLSP for your own data 121 | If you have your own data you want to use this package for, that's great! Otherwise, we've provided a simple way for users to obtain EVI2 time series data for their area(s) of interest via Google Earth Engine (GEE) and Microsoft Planetary Computer (MPC). Here we are using Landsats 5,7,8,9 Collection 2 Surface Reflectance data. **Note this method requires you have a Google account**. 122 | 123 | 124 | ### Get data from Microsoft Planetary Computer 125 | Getting EVI2 time series using Microsoft Planetary Computer (MPC) is easy by using the functions we provide, you don't need to register an account, and you can do it in the R environment so it's good for keeping you code consistent. But, keep in mind that since PC is relatively new, the API may change which would make our functions throw errors in the future. Also, note that running the code in this section is going to take a while, so in the vignette, we only put the example code and the corresponding results rather than running the code each time you install the library. It will save some time, but the result may be different from what you get. 126 | 127 | To get EVI2 time series from MPC, you need to have point locations specified by longitude and latitude. Although our functions only do one point location at a time, you can do multiple points in a loop. 128 | 129 | ```{r mpc-point-loc, eval = FALSE} 130 | # A point location specified by long/lat format 131 | # You MUST name the coordinates with `x` and `y` and put them into a data.frame 132 | pt_coords <- data.frame(x = -71.700975, y = 43.945733) 133 | ``` 134 | 135 | Then, you can specify the temporal period by a character string. And, since we use parallel procesing to process the data, you may specify the number of cores you want to use for parallel. **Note that for processing speed, here in the example we are getting data for 6 years, as we know the BLSP model borrows information from other years, doing 6 years could yield relatively large uncertainty on the estimate depending on the data sparsity. So, once you are sure the code runs well on your machine, do multiple tests on the data side.** 136 | 137 | ```{r mpc-focal-dates, eval = FALSE} 138 | # Use the format of "start_date/end_date" 139 | focalDates <- "2011-01-01/2016-12-31" 140 | 141 | # Number of cores 142 | ncores <- 10 143 | ``` 144 | 145 | To get the data, you can use `GetEvi2PointTs()` function (it's going to take around 5 minutes for the function to prepare the data, depending on how long the requested temperal period is and the internet speed). 146 | 147 | ```{r mpc-get-data, eval = FALSE} 148 | evi2_dt <- GetEvi2PointTs( 149 | pt_coords = pt_coords, 150 | focalDates = focalDates, 151 | ncores = ncores 152 | ) 153 | ``` 154 | 155 | After the code is done, you can see the result in the `evi2_dt` object (note that we did not remove values with snow): 156 | ```{r mpc-evi2-ts, eval = FALSE} 157 | head(evi2_dt) 158 | ``` 159 | 160 | ``` 161 | img_id lon lat evi2 date qa snow 162 | 1: LT05_L2SP_013029_20100109_02_T1 -71.70097 43.94573 0.1000716 2010-01-09 13600 TRUE 163 | 2: LT05_L2SP_012030_20100307_02_T1 -71.70097 43.94573 0.1410364 2010-03-07 5440 FALSE 164 | 3: LT05_L2SP_013029_20100415_02_T1 -71.70097 43.94573 0.1754859 2010-04-15 5440 FALSE 165 | 4: LE07_L2SP_013029_20100423_02_T1 -71.70097 43.94573 0.2231386 2010-04-23 5440 FALSE 166 | 5: LT05_L2SP_012030_20100424_02_T1 -71.70097 43.94573 0.2273574 2010-04-24 5440 FALSE 167 | 6: LT05_L2SP_012030_20100510_02_T1 -71.70097 43.94573 0.5618129 2010-05-10 5440 FALSE 168 | ``` 169 | 170 | Once you get the EVI2 time series, you can process BLSP from the data as usual. The code might run for several minutes depending on the number of years in the time series. 171 | 172 | ```{r mpc-blsp, eval=FALSE} 173 | # Remove snow 174 | evi2_dt <- evi2_dt[snow == FALSE, ] 175 | 176 | # Fit the average model 177 | avg_fit <- FitAvgModel( 178 | date_vec = evi2_dt$date, 179 | vi_vec = evi2_dt$evi2 180 | ) 181 | 182 | # Fit the BLSP model 183 | results <- FitBLSP( 184 | date_vec = evi2_dt$date, 185 | vi_vec = evi2_dt$evi2, 186 | init_values = avg_fit, 187 | verbose = TRUE 188 | ) 189 | ``` 190 | 191 | And plot out the model fit: 192 | ```{r mpc-plot-blsp, eval=FALSE} 193 | png("mpcResults.png", width=1200, height=400) 194 | fitted_dt <- PlotBLSP(results, if_return_fit = TRUE) 195 | dev.off() 196 | ``` 197 | 198 | Output model fit for GEE data 199 | 200 | 201 | 202 | 203 | ### Get data from GEE 204 | First, please go to [this link](https://code.earthengine.google.com/7e2cdb594772506e296bda8411b05d20) for the GEE script. If the link does not work, please open a new [code browser](https://code.earthengine.googlecom) and copy/paste the script found [here](https://github.com/ncsuSEAL/Bayesian_LSP/blob/main/gee/getSampleData.js). 205 | 206 | Second, change the start and end dates (*Section 1: Define variables*) and the point coordinates (*Section 1: Define study locations*) as you need, and run the script by clicking the "Run" button. 207 | 208 | Third, go to "Tasks" panel, and click the "RUN" button in the row of the "exportEVI2" task. It will open a window with the detailed information including task name, export directory (has to be a Google Drive folder), export file name, and file type. We will use the default setting for this vignette. Click the "RUN" button of the window. 209 | 210 | It might take several minutes for GEE to process the time series depending on the current availability of their cloud computing resource. After it's done, the exported time series data file should be in your Google Drive folder. 211 | 212 | ### Apply BLSP to GEE data 213 | 214 | Note: we don't have this GEE data included in our package as standalone data. Instead, here we are showing the code as if we are loading from a local directory after downloading from GEE. Because of this, any outputs shown here are from us running the code then manually adding the results to each section. 215 | 216 | In R, load in the time series data file by: 217 | ```{r gee-data, eval=FALSE} 218 | library(data.table) 219 | sample_data <- fread("sampleData.csv") 220 | ``` 221 | Using `head(sample_data)`, you will see it has 7 columns containing information of sensor type, date, longitude, latitude, point id, EVI2 value, and pixel QA value. 222 | ```{r, ex1} 223 | # satellite date lon lat id evi2 QA_PIXEL 224 | # 1: LANDSAT/LT05/C02/T1_L2 1991-10-29 43.94573 -71.70097 0 NA NA 225 | # 2: LANDSAT/LT05/C02/T1_L2 1991-10-29 43.95202 -71.72556 1 NA NA 226 | # 3: LANDSAT/LT05/C02/T1_L2 1991-10-29 43.95092 -71.72874 2 NA NA 227 | # 4: LANDSAT/LT05/C02/T1_L2 1991-10-29 43.95895 -71.73166 3 0.1578591 5440 228 | # 5: LANDSAT/LT05/C02/T1_L2 1991-10-29 43.94913 -71.73183 4 NA NA 229 | # 6: LANDSAT/LT05/C02/T1_L2 1991-10-29 43.95740 -71.73687 5 NA NA 230 | ``` 231 | 232 | To run the BLSP model, let's select a single time series and omit all `NA` rows (important!). 233 | ```{r single-ts, eval=FALSE} 234 | # Select one single time series 235 | single_ts <- sample_data[id == 1, .(date, evi2)] 236 | 237 | # Remember to remove NA rows before running the `blsp` package 238 | single_ts <- na.omit(single_ts) 239 | head(single_ts) 240 | 241 | # date evi2 242 | # 1: 1984-06-19 0.7871580 243 | # 2: 1984-09-23 0.5792558 244 | # 3: 1985-06-22 0.7871400 245 | # 4: 1985-08-09 0.7356111 246 | # 5: 1985-10-12 0.4650306 247 | # 6: 1986-06-09 0.7066563 248 | ``` 249 | 250 | Now, we can use the `blsp` package as usual. This code chunk might run for several minutes depending on how many years are in the time series. 251 | ```{r fit-gee-data, eval=FALSE} 252 | # Fit the average model 253 | avg_fit <- FitAvgModel( 254 | date_vec = single_ts$date, 255 | vi_vec = single_ts$evi2 256 | ) 257 | 258 | # Fit the BLSP model 259 | results <- FitBLSP( 260 | date_vec = single_ts$date, 261 | vi_vec = single_ts$evi2, 262 | init_values = avg_fit, 263 | verbose = TRUE 264 | ) 265 | ``` 266 | 267 | Plot out the model fit: 268 | ```{r plot-blsp-gee-data, eval=FALSE} 269 | png("geeResults.png", width=1200, height=400) 270 | fitted_dt <- PlotBLSP(results, if_return_fit = TRUE) 271 | dev.off() 272 | ``` 273 | 274 | Output model fit for GEE data 275 | 276 | If you encounter any issues while using the package, please feel free to [leave us an issue on Github](https://github.com/ncsuSEAL/Bayesian_LSP). 277 | 278 | 279 | 280 | -------------------------------------------------------------------------------- /vignettes/mpcResults.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ncsuSEAL/Bayesian_LSP/bb342da87127491e0214a75c8cc049218b4ef63a/vignettes/mpcResults.png --------------------------------------------------------------------------------