#'
#'
#' [ The R Script associated with this page is available here](`r output`). Download this file and open it (or copy-paste into a new script) with RStudio so you can follow along.
#'
#'
#' ### Libraries
#'
## ----results='hide',message=FALSE, warning=F-----------------------------
library(raster)
library(rasterVis)
library(rgdal)
library(ggplot2)
library(ggmap)
library(dplyr)
library(knitr)
library(tidyr)
library(DataScienceData)
# New Packages
library(gdalUtils)
library(rts)
#'
#'
#' ## Identify (and create) download folders
#'
#' Today we'll work with:
#'
#' * Land Surface Temperature (`lst`): MOD11A2
#' * Land Cover (`lc`): MCD12Q1
#'
#' ## Land Use Land Cover
#'
#' You will need to update the DataScienceData package before the command below will work. Run `devtools::install_github("adammwilson/DataScienceData"); library(DataScienceData)`. If that doesn't work, you can download the needed files directly from [here](https://github.com/adammwilson/DataScienceData/tree/master/inst/extdata/appeears).
#'
## ------------------------------------------------------------------------
lulcf=system.file("extdata",
"appeears/MCD12Q1.051_aid0001.nc",
package = "DataScienceData")
lulcf
#IF that doesn't work
#'
## ---- warning=F, message=FALSE,results='hide'----------------------------
lulc=stack(lulcf,varname="Land_Cover_Type_1")
plot(lulc)
#'
#' We'll just pick one year to work with to keep this simple:
## ---- warning=F----------------------------------------------------------
lulc=lulc[[13]]
plot(lulc)
#'
#' ### Process landcover data
#'
#' Get cover clases from [MODIS website](https://lpdaac.usgs.gov/dataset_discovery/modis/modis_products_table/mcd12q1)
#'
## ------------------------------------------------------------------------
Land_Cover_Type_1 = c(
Water = 0,
`Evergreen Needleleaf forest` = 1,
`Evergreen Broadleaf forest` = 2,
`Deciduous Needleleaf forest` = 3,
`Deciduous Broadleaf forest` = 4,
`Mixed forest` = 5,
`Closed shrublands` = 6,
`Open shrublands` = 7,
`Woody savannas` = 8,
Savannas = 9,
Grasslands = 10,
`Permanent wetlands` = 11,
Croplands = 12,
`Urban & built-up` = 13,
`Cropland/Natural vegetation mosaic` = 14,
`Snow & ice` = 15,
`Barren/Sparsely vegetated` = 16,
Unclassified = 254,
NoDataFill = 255)
lcd=data.frame(
ID=Land_Cover_Type_1,
landcover=names(Land_Cover_Type_1),
col=c("#000080","#008000","#00FF00", "#99CC00","#99FF99", "#339966", "#993366", "#FFCC99", "#CCFFCC", "#FFCC00", "#FF9900", "#006699", "#FFFF00", "#FF0000", "#999966", "#FFFFFF", "#808080", "#000000", "#000000"),
stringsAsFactors = F)
# colors from https://lpdaac.usgs.gov/about/news_archive/modisterra_land_cover_types_yearly_l3_global_005deg_cmg_mod12c1
kable(head(lcd))
#'
#' Convert LULC raster into a 'factor' (categorical) raster. This requires building the Raster Attribute Table (RAT). Unfortunately, this is a bit of manual process as follows.
## ------------------------------------------------------------------------
# convert to raster (easy)
lulc=as.factor(lulc)
# update the RAT with a left join
levels(lulc)=left_join(levels(lulc)[[1]],lcd)
#'
## ---- fig.height=12, warning=F-------------------------------------------
# plot it
gplot(lulc)+
geom_raster(aes(fill=as.factor(value)))+
scale_fill_manual(values=levels(lulc)[[1]]$col,
labels=levels(lulc)[[1]]$landcover,
name="Landcover Type")+
coord_equal()+
theme(legend.position = "bottom")+
guides(fill=guide_legend(ncol=1,byrow=TRUE))
#'
#' ## Land Surface Temperature
## ---- warning=F, message=FALSE,results='hide'----------------------------
lstf=system.file("extdata",
"appeears/MOD11A2.006_aid0001.nc",
package = "DataScienceData")
lstf
lst=stack(lstf,varname="LST_Day_1km")
plot(lst[[1:12]])
#'
#' You may get a warning about some attributes being 8-byte converted to double precisions. You can ignore these warnings.
#'
#' ## Convert LST to Degrees C
#' You can convert LST from Degrees Kelvin (K) to Celcius (C) with `offs()`.
#'
## ------------------------------------------------------------------------
offs(lst)=-273.15
plot(lst[[1:10]])
#'
#' # MODLAND Quality control
#'
#' See a detailed explaination [here](https://lpdaac.usgs.gov/sites/default/files/public/modis/docs/MODIS_LP_QA_Tutorial-1b.pdf). Some code below from [Steven Mosher's blog](https://stevemosher.wordpress.com/2012/12/05/modis-qc-bits/).
#'
#' ## MOD11A2 (Land Surface Temperature) Quality Control
#' [MOD11A2 QC Layer table](https://lpdaac.usgs.gov/dataset_discovery/modis/modis_products_table/mod11a2)
#'
#' 
#'
## ---- warning=F, message=FALSE,results='hide'----------------------------
lstqc=stack(lstf,varname="QC_Day")
plot(lstqc[[1:2]])
#'
#' ### LST QC data
#'
#' QC data are encoded in 8-bit 'words' to compress information.
#'
## ------------------------------------------------------------------------
values(lstqc[[1:2]])%>%table()
#'
#'
#' 
#'
## ------------------------------------------------------------------------
intToBits(65)
intToBits(65)[1:8]
as.integer(intToBits(65)[1:8])
#' #### MODIS QC data are _Big Endian_
#'
#' Format Digits value sum
#' ---- ---- ---- ----
#' Little Endian 1 0 0 0 0 0 1 0 65 2^0 + 2^6
#' Big Endian 0 1 0 0 0 0 0 1 65 2^6 + 2^0
#'
#'
#' Reverse the digits with `rev()` and compare with QC table above.
#'
## ------------------------------------------------------------------------
rev(as.integer(intToBits(65)[1:8]))
#' QC for value `65`:
#'
#' * LST produced, other quality, recommend examination of more detailed QA
#' * good data quality of L1B in 7 TIR bands
#' * average emissivity error <= 0.01
#' * Average LST error <= 2K
#'
#'
#'
#' ## Your turn
#' What does a QC value of 81 represent?
#'
#'
#'
#'
#'
#'
#' ### Filter the the lst data using the QC data
#'
## ------------------------------------------------------------------------
## set up data frame to hold all combinations
QC_Data <- data.frame(Integer_Value = 0:255,
Bit7 = NA, Bit6 = NA, Bit5 = NA, Bit4 = NA,
Bit3 = NA, Bit2 = NA, Bit1 = NA, Bit0 = NA,
QA_word1 = NA, QA_word2 = NA, QA_word3 = NA,
QA_word4 = NA)
##
for(i in QC_Data$Integer_Value){
AsInt <- as.integer(intToBits(i)[1:8])
QC_Data[i+1,2:9]<- AsInt[8:1]
}
QC_Data$QA_word1[QC_Data$Bit1 == 0 & QC_Data$Bit0==0] <- "LST GOOD"
QC_Data$QA_word1[QC_Data$Bit1 == 0 & QC_Data$Bit0==1] <- "LST Produced,Other Quality"
QC_Data$QA_word1[QC_Data$Bit1 == 1 & QC_Data$Bit0==0] <- "No Pixel,clouds"
QC_Data$QA_word1[QC_Data$Bit1 == 1 & QC_Data$Bit0==1] <- "No Pixel, Other QA"
QC_Data$QA_word2[QC_Data$Bit3 == 0 & QC_Data$Bit2==0] <- "Good Data"
QC_Data$QA_word2[QC_Data$Bit3 == 0 & QC_Data$Bit2==1] <- "Other Quality"
QC_Data$QA_word2[QC_Data$Bit3 == 1 & QC_Data$Bit2==0] <- "TBD"
QC_Data$QA_word2[QC_Data$Bit3 == 1 & QC_Data$Bit2==1] <- "TBD"
QC_Data$QA_word3[QC_Data$Bit5 == 0 & QC_Data$Bit4==0] <- "Emiss Error <= .01"
QC_Data$QA_word3[QC_Data$Bit5 == 0 & QC_Data$Bit4==1] <- "Emiss Err >.01 <=.02"
QC_Data$QA_word3[QC_Data$Bit5 == 1 & QC_Data$Bit4==0] <- "Emiss Err >.02 <=.04"
QC_Data$QA_word3[QC_Data$Bit5 == 1 & QC_Data$Bit4==1] <- "Emiss Err > .04"
QC_Data$QA_word4[QC_Data$Bit7 == 0 & QC_Data$Bit6==0] <- "LST Err <= 1"
QC_Data$QA_word4[QC_Data$Bit7 == 0 & QC_Data$Bit6==1] <- "LST Err > 2 LST Err <= 3"
QC_Data$QA_word4[QC_Data$Bit7 == 1 & QC_Data$Bit6==0] <- "LST Err > 1 LST Err <= 2"
QC_Data$QA_word4[QC_Data$Bit7 == 1 & QC_Data$Bit6==1] <- "LST Err > 4"
kable(head(QC_Data))
#'
#' ### Select which QC Levels to keep
## ------------------------------------------------------------------------
keep=QC_Data[QC_Data$Bit1 == 0,]
keepvals=unique(keep$Integer_Value)
keepvals
#'
#' ### How many observations will be dropped?
#'
## ----warning=F-----------------------------------------------------------
qcvals=table(values(lstqc)) # this takes a minute or two
QC_Data%>%
dplyr::select(everything(),-contains("Bit"))%>%
mutate(Var1=as.character(Integer_Value),
keep=Integer_Value%in%keepvals)%>%
inner_join(data.frame(qcvals))%>%
kable()
#'
#' Do you want to update the values you are keeping?
#'
#' ### Filter the LST Data keeping only `keepvals`
#'
#' These steps take a couple minutes.
#'
#' Make logical flag to use for mask
## ------------------------------------------------------------------------
lstkeep=calc(lstqc,function(x) x%in%keepvals)
#'
#' Plot the mask
## ----fig.height=12-------------------------------------------------------
gplot(lstkeep[[4:8]])+
geom_raster(aes(fill=as.factor(value)))+
facet_grid(variable~.)+
scale_fill_manual(values=c("blue","red"),name="Keep")+
coord_equal()+
theme(legend.position = "bottom")
#'
#'
#' Mask the lst data using the QC data
## ------------------------------------------------------------------------
lst2=mask(lst,mask=lstkeep,maskval=0)
#'
#'
#' ## Add Dates to Z dimension
#'
## ------------------------------------------------------------------------
tdates=names(lst)%>%
sub(pattern="X",replacement="")%>%
as.Date("%Y.%m.%d")
names(lst2)=1:nlayers(lst2)
lst2=setZ(lst2,tdates)
#'
#' ## Summarize to Seasonal climatologies
#'
#' Use `stackApply()` with a seasonal index.
#'
## ------------------------------------------------------------------------
tseas=as.numeric(sub("Q","",quarters(getZ(lst2))))
tseas[1:20]
lst_seas=stackApply(lst2,
indices = tseas,
mean,na.rm=T)
names(lst_seas)=c("Q1_Winter",
"Q2_Spring",
"Q3_Summer",
"Q4_Fall")
#'
## ----fig.height=9--------------------------------------------------------
gplot(lst_seas)+geom_raster(aes(fill=value))+
facet_wrap(~variable)+
scale_fill_gradientn(colours=c("blue",mid="grey","red"))+
coord_equal()+
theme(axis.text.x=element_text(angle=60, hjust=1))
#'
#'
#'
#' ## Your turn
#' Use `stackApply()` to generate and plot monthly median lst values.
#'
#' Hints:
#'
#' 1. First make a tmonth variable by converting the dates to months using `format(getZ(lst2),"%m")`
#' 2. Use `stackApply()` to summarize the mean value per month
#' 3. Rename the layers by the number of the months with `sprintf("%02d",1:12)`
#' 4. Plot it like above.
#'
#'
#'
#'
#'
#'
#'
#'
#' ## Extract timeseries for a point
#'
## ---- warning=F----------------------------------------------------------
lw=SpatialPoints(
data.frame(
x= -78.791547,
y=43.007211))
projection(lw)="+proj=longlat"
lw=spTransform(lw,projection(lst2))
lwt=data.frame(date=getZ(lst2),
lst=t(raster::extract(
lst2,lw,
buffer=1000,
fun=mean,na.rm=T)))
ggplot(lwt,aes(x=date,y=lst))+
geom_path()
#'
#' See the `library(rts)` for more timeseries related functions.
#'
#' ## Combine Land Cover and LST data
#'
#' ### Resample `lc` to `lst` grid
#'
## ------------------------------------------------------------------------
lulc2=resample(lulc,
lst,
method="ngb")
par(mfrow=c(1,2))
plot(lulc)
plot(lulc2)
par(mfrow=c(1,1))
#'
#' ### Summarize mean monthly temperatures by Landcover
#'
## ------------------------------------------------------------------------
table(values(lulc))
#'
#' Extract values from `lst` and `lc` rasters.
#'
## ------------------------------------------------------------------------
lcds1=cbind.data.frame(
values(lst_seas),
ID=values(lulc2[[1]]))%>%
na.omit()
head(lcds1)
#'
#' Melt table and add LandCover Name
## ------------------------------------------------------------------------
lcds2=lcds1%>%
gather(key="season", value = "value", -ID)%>%
mutate(ID=as.numeric(ID))%>%
left_join(lcd)
head(lcds2)
#'
#' #### Explore LST distributions by landcover
#'
## ----fig.height=12-------------------------------------------------------
ggplot(lcds2,aes(y=value,x=landcover,group=landcover))+
facet_wrap(~season)+
geom_point(alpha=.5,position="jitter")+
geom_violin(alpha=.5,col="red",scale = "width")+
theme(axis.text.x=element_text(angle=90, hjust=1))
#'
#'
#' ### Use Zonal Statistics to calculate summaries
## ------------------------------------------------------------------------
lct.mean=raster::zonal(lst_seas,
lulc2,
'mean',na.rm=T)%>%
data.frame()
lct.sd=zonal(lst_seas,
lulc2,
'sd',na.rm=T)%>%
data.frame()
lct.count=zonal(lst_seas,
lulc2,
'count',na.rm=T)%>%
data.frame()
lct.summary=rbind(data.frame(lct.mean,var="mean"),
data.frame(lct.sd,var="sd"),
data.frame(lct.count,var="count"))
#'
#' #### Summarize seasonal values
## ------------------------------------------------------------------------
lctl=gather(lct.summary, key="season", value="value", -var, -zone)
lctl$season=factor(lctl$season,
labels=c("Winter","Spring","Summer","Fall"),
ordered=T)
lctl$zone=names(Land_Cover_Type_1)[lctl$zone+1]
lctl=spread(lctl,var,value="value")
head(lctl)%>%kable()
#'
#' ## Build summary table
## ------------------------------------------------------------------------
filter(lctl,count>=100)%>%
mutate(txt=paste0(round(mean,2),
" (±",round(sd,2),")"))%>%
dplyr::select(zone,count,txt,season)%>%
spread(season, txt)%>%
kable()
#'
#'
#' ## Your turn
#' Calculate the maximum observed seasonal average lst in each land cover type.
#' Hints:
#'
#' 1. First use `zonal()` of `lst_seas` and `lulc2` to calculate the `max()` with `na.rm=T`
#' 2. convert the output to a `data.frame()`
#' 3. use `arrange()` to sort by `desc(max)`
#' 4. use `kable()` if desired to make it print nicely.
#'
#'
#'
#'
#'
#'
#'
#'
#'
#' Things to think about:
#'
#' * What tests would you use to identify differences?
#' * Do you need to worry about unequal sample sizes?
#'