inst/application/server.R
In chrisvwn/Rnightlights: Satellite Nightlight Data Extraction
missingPkgs <- NULL
#wgs84 <- "+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"
wgs84 <- Rnightlights:::getCRS()
if (!requireNamespace("Rnightlights", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "Rnightlights")
}
if (!requireNamespace("shiny", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "shiny")
}
if (!requireNamespace("shinyjs", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "shinyjs")
}
if (!requireNamespace("dendextend", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "dendextend")
}
if (!requireNamespace("ggdendro", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "ggdendro")
}
if (!requireNamespace("leaflet", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "rstudio/leaflet")
}
if (!requireNamespace("plotly", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "plotly")
}
if (!requireNamespace("RColorBrewer", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "RColorBrewer")
}
if (!requireNamespace("reshape2", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "reshape2")
}
if (!requireNamespace("rgdal", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "rgdal")
}
if (!is.null(missingPkgs))
stop(
Sys.time(),
": Missing packages needed for this function to work.
Please install missing packages: '",
paste0(missingPkgs, collapse = ", "),
"'",
call. = FALSE
)
#stats to be
defaultStats <- c("mean()", "sum()", "var()", "sd()")
#options(shiny.trace=T)
options(shiny.reactlog = TRUE)
shiny::shinyServer(function(input, output, session) {
#Since renderUI does not like selectAdmLevel returning NULL we init with an
# empty renderUI, set suspendWhenHidden = FALSE to force it to recheck
# selectAdmLevel even if null
output$selectAdmLevel <- shiny::renderUI({
})
shiny::outputOptions(output, "selectAdmLevel", suspendWhenHidden = FALSE)
#shinyjs::useShinyjs()
################## reactive ctryCodesWithData #######################
ctryCodesWithData <- shiny::reactive({
Rnightlights:::getCtryCodesWithData()
})
######################## update countries ###################################
observe({
print(paste0("observe: countries"))
#c("Ashm", "CYN", "Gaza", "IDN", "IOA", "KAS", "KOS"))
allCtryCodes <- Rnightlights::getAllNlCtryCodes()
allCtryNames <- Rnightlights::ctryCodeToName(allCtryCodes)
allCtryCodes <- setNames(allCtryCodes, allCtryNames)
ctryCodesWithData <- ctryCodesWithData()
diffCtryCodes <-
allCtryCodes[!(allCtryCodes %in% ctryCodesWithData)]
ctryCodes <- if(is.null(ctryCodesWithData))
list("Without Data" = as.list(diffCtryCodes))
else
list("Have Data" = as.list(ctryCodesWithData), "Without Data" = as.list(diffCtryCodes))
shiny::updateSelectizeInput(
session = session,
inputId = "countries",
label = "Select Country(ies)",
choices = ctryCodes,
server = TRUE
)
})
######################## actionButton btnGo ###########################
output$btnGo <- shiny::renderUI({
print("output: btnGo")
if (values$needsDataUpdate || values$needsDataProcessing)
{
if (values$needsDataUpdate)
btn <-
shiny::actionButton(inputId = "btnGo", label = "LOAD",
style = "background-color:orange")
#give precedence to process. if both set let process override load
if (values$needsDataProcessing)
btn <-
shiny::actionButton(inputId = "btnGo", label = "PROCESS",
style = "background-color:orange")
} else
{
btn <-
shiny::actionButton(inputId = "btnGo", label = "LOAD",
style = "background-color:lightblue")
}
btn
})
######################## observe btnGo ###########################
# observe({
# print("update: btnGo")
#
# if (values$needsDataUpdate || values$needsDataProcessing)
# {
# if (values$needsDataUpdate)
# shiny::updateActionButton(session = session, inputId = "btnGo", label = "LOAD",
# icon = shiny::icon("play"))
#
# #give precedence to process. if both set let process override load
# if (values$needsDataProcessing)
# btn <-
# shiny::updateActionButton(session = session, inputId = "btnGo", label = "PROCESS",
# icon = shiny::icon("play"))
# } else
# btn <-
# shiny::updateActionButton(session = session, inputId = "btnGo", label = "LOAD",
# icon = character(0))
# })
######################## reactive getInputCountries ###########################
getInputCountries <- reactive({
print("reactive: getInputCountries")
countries <- input$countries
if (length(countries) == 0)
return(NULL)
countries[countries == "---" | countries == " "] <- ""
countries
})
######################## reactive ctryAdmLevels ######################
ctryAdmLevels <- shiny::reactive({
print(paste0("reactive:ctryAdmLevels"))
countries <- getInputCountries()
if (length(countries) == 0 || length(countries) > 1)
return()
admLevelNames <-
Rnightlights:::getCtryStructAdmLevelNames(ctryCode = countries)
admLevelNames
})
######################## reactive ctryAdmLevelNames #########################
ctryAdmLevelNames <- shiny::reactive({
print(paste0("reactive:ctryAdmLevelNames"))
countries <- getInputCountries()
if (length(countries) != 1)
return()
Rnightlights:::readCtryStruct(ctryCode = countries)
})
######################## reactive ctryNlTypes ###############################
ctryNlTypes <- shiny::reactive({
print(paste0("reactive: ctryNlTypes"))
countries <- getInputCountries()
if (length(countries) == 0)
return()
admLevel <- selectedAdmLevel3()
if (is.null(admLevel))
return()
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
getCtryNlTypes(countries = countries, admLevel = admLevel, polySrc = polySrc, polyVer = polyVer, polyType = polyType)
})
######################## reactive ctryNlDataLvl2 ############################
ctryNlDataLvl2 <- shiny::reactive({
print(paste0("reactive: ctryNlDataLvl2"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
nlType <- shiny::isolate(input$nlType)
#strict <- shiny::isolate(input$strict)
if (is.null(polySrc) ||
polySrc == "" ||
is.null(polyVer) ||
polyVer == "" || is.null(polyType) || polyType == "")
return(NULL)
if (is.null(nlType))
return(NULL)
ctryData <- NULL
custPolyPath <- if (polySrc == "CUST")
polyVer
else
NULL
getCtrysDataDirect(countries = countries, polySrc = polySrc, polyVer = polyVer, polyType = polyType, nlType = nlType)
})
######################## reactive ctryNlData ################################
ctryNlData <- shiny::reactive({
print(paste0("reactive: ctryNlData"))
input$btnGo
countries <- shiny::isolate(input$countries)
if (is.null(countries) ||
length(countries) == 0 || countries == "")
return()
nlType <- shiny::isolate(input$nlType)
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
#strict <- shiny::isolate(input$strict)
if (input$tabs == "Map" &&
is.null(nlPeriod <- shiny::isolate(input$nlPeriod)))
nlPeriod <- shiny::isolate(input$nlPeriodRange)
if (input$tabs != "Map" &&
is.null(nlPeriod <- shiny::isolate(input$nlPeriodRange)))
nlPeriod <- shiny::isolate(input$nlPeriod)
if (is.null(nlPeriod))
return()
nlPeriod <-
Rnightlights::dateToNlPeriod(dt = nlPeriod, nlType = nlType)
if (length(nlPeriod) == 2)
nlPeriod <-
Rnightlights::nlRange(
startNlPeriod = nlPeriod[1],
endNlPeriod = nlPeriod[2],
nlType = nlType
)
nlStats <- shiny::isolate(input$ctryStat)
if (!is.null(nlStats))
{
if (nlStats == "Add New")
{
nlStats <- values$newStatFuncName
}
nlStats <-
Rnightlights:::nlSignatureAddArg(nlStatSigs = nlStats,
addArg = "na.rm=T")
nlStats <-
Rnightlights:::nlSignatureStat(nlStatSignature = nlStats)
} else
{
return()
}
configName <- shiny::isolate(input$configName)
multiTileStrategy <-
shiny::isolate(input$multiTileMergeStrategy)
multiTileMergeFun <- shiny::isolate(input$multiTileMergeFun)
removeGasFlares <- shiny::isolate(input$removeGasFlares)
if (is.null(polySrc) ||
polySrc == "" ||
is.null(polyVer) ||
polyVer == "" || is.null(polyType) || polyType == "")
return(NULL)
if (is.null(nlType))
return(NULL)
ctryData <- NULL
custPolyPath <- if (polySrc == "CUST")
polyVer
else
NULL
cropMaskMethod <- shiny::isolate(input$cropMaskMethod)
extractMethod <- shiny::isolate(input$extractMethod)
# shiny::showModal(ui = modalDialog(title = "PROCESSING",
# "Retrieving data. Please wait ...",
# size = "s"),
# session = session)
dt <- if (length(countries) == 1)
{
if (is.null(admLevel <- shiny::isolate(input$radioAdmLevel)))
return()
lyrNum <-
which(unlist(ctryAdmLevels()) == shiny::isolate(admLevel)) - 1
admLevel <-
unlist(
Rnightlights:::getCtryShpLyrNames(
ctryCodes = countries,
lyrNums = lyrNum,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath
)
)
data.table::data.table(
Rnightlights::getCtryNlData(
ctryCode = countries,
admLevel = admLevel,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath,
nlTypes = nlType,
nlPeriods = nlPeriod,
nlStats = nlStats,
extractMethod = "gdal",
configNames = configName,
multiTileStrategy = multiTileStrategy,
multiTileMergeFun = multiTileMergeFun,
removeGasFlares = removeGasFlares
)
)
} else if (length(countries) > 1) #remove subcountry admin levels
{
for (ctryCode in countries)
{
admLevel <- paste0(ctryCode, "_adm0")
#print(ctryCode)
temp <- Rnightlights:::getCtryNlData(
ctryCode = ctryCode,
admLevel = admLevel,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath,
nlTypes = nlType,
nlPeriods = nlPeriod,
nlStats = nlStats,
cropMaskMethod = cropMaskMethod,
extractMethod = extractMethod,
configNames = configName,
multiTileStrategy = multiTileStrategy,
multiTileMergeFun = multiTileMergeFun,
removeGasFlares = removeGasFlares
)
temp <- data.table::as.data.table(temp)
ctryCols <-
grep(paste0("country|area|NL_", nlType), names(temp))
temp <- temp[, ctryCols, with = F]
if (is.null(ctryData))
{
ctryData <- temp
} else
{
ctryData <- merge(ctryData, temp, all = TRUE)
}
}
ctryData
}
#removeModal()
dt
})
######################## reactive ctryNlDataMelted ##########################
ctryNlDataMelted <- shiny::reactive({
print(paste0("reactive: ctryNlDataMelted"))
input$btnGo
ctryData <- ctryNlData()
if (is.null(ctryData))
return()
ctryStat <- input$ctryStat
if (is.null(ctryStat))
return()
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
if (is.null(configName) ||
is.null(multiTileMergeStrategy) ||
is.null(multiTileMergeFun) || is.null(removeGasFlares))
return()
shiny::isolate({
#the nightlight cols
nlCols <- names(ctryData)[grep("NL_", names(ctryData))]
#the cols with the stats we want
statCols <-
grep(
pattern = gsub("(", "\\(", paste0("NL_.*_", ctryStat), fixed = T),
x = names(ctryData),
value = TRUE
)
statCols <-
grep(pattern = configName,
x = statCols,
value = TRUE)
statCols <-
grep(pattern = paste0("GF", substr(removeGasFlares, 1, 1)),
x = statCols,
value = TRUE)
statCols <-
grep(
pattern = paste0("MTS", multiTileMergeStrategy),
x = statCols,
value = TRUE
)
statCols <-
grep(pattern = multiTileMergeFun,
x = statCols,
value = TRUE)
#the non nightlight cols
ctryDataCols <- setdiff(names(ctryData), nlCols)
#the cols to melt by
meltMeasureVars <- statCols
nlType <- shiny::isolate(input$nlType)
#combine the non-nightlight cols and the cols with the stats we want
#ctryData <- subset(ctryData, select=c(ctryDataCols, meltMeasureVars))
#remove non-digits to get only stat cols
#meltVarNames <- gsub("[^[:digit:]]", "", meltMeasureVars)
ctryData <-
data.table::data.table(
reshape2::melt(ctryData, measure.vars = meltMeasureVars)
)
ctryData$variable <-
Rnightlights::nlPeriodToDate(gsub(pattern = "[^[:digit:]]",
replacement = "",
x = ctryData$variable),
nlType)
return(ctryData)
})
})
######################## reactive ctryNlDataMeltedLvl2 ######################
ctryNlDataMeltedLvl2 <- shiny::reactive({
print(paste0("reactive: ctryNlDataMeltedLvl2"))
countries <- input$countries
if (is.null(countries) || length(countries) == 0)
return()
admLevel <- input$radioAdmLevel
if (is.null(admLevel))
return()
ctryData <- ctryNlDataLvl2()
if (is.null(ctryData))
return()
ctryStat <- input$ctryStat
if (is.null(ctryStat))
return()
shiny::isolate({
#the nightlight cols
nlCols <- names(ctryData)[grep("NL_", names(ctryData))]
#the cols with the stats we want
statCols <-
names(ctryData)[grep(paste0("NL_.*", ctryStat), names(ctryData))]
#the non nightlight cols
ctryDataCols <- setdiff(names(ctryData), nlCols)
#the cols to melt by
meltMeasureVars <- statCols
#combine the non-nightlight cols and the cols with the stats we want
ctryData <-
subset(ctryData, select = c(ctryDataCols, meltMeasureVars))
#remove non-digits to get only stat cols
meltVarNames <- gsub("[^[:digit:]]", "", meltMeasureVars)
ctryData <-
data.table::data.table(
reshape2::melt(ctryData, measure.vars = meltMeasureVars)
)
if (stringr::str_detect(input$nlType, "OLS"))
{
ctryData$variable <-
paste0(gsub("[^[:digit:]]", "", ctryData$variable))
ctryData$variable <- as.numeric(ctryData$variable)
}
else if (stringr::str_detect(input$nlType, "VIIRS"))
{
if (stringr::str_detect(input$nlType, "M"))
ctryData$variable <-
paste0(gsub("[^[:digit:]]", "", ctryData$variable), "01")
else if (stringr::str_detect(input$nlType, "Y"))
ctryData$variable <-
paste0(gsub("[^[:digit:]]", "", ctryData$variable), "0101")
ctryData$variable <-
as.Date(ctryData$variable, format = "%Y%m%d")
}
return(ctryData)
})
})
######################## renderUI polySrc ###################################
observe({
print(paste0("output: polySrc"))
countries <- getInputCountries()
allPolySrcs <- c("GADM", "CUST")
existingPolySrcs <- unique(ctryNlDataList())
if (!is.null(countries))
existingPolySrcs <-
existingPolySrcs[existingPolySrcs$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingPolySrcs <-
existingPolySrcs[existingPolySrcs$admLevel == admLevel, "polySrc"]
else
existingPolySrcs <- unique(existingPolySrcs[, "polySrc"])
polySrcs <- allPolySrcs[!(allPolySrcs %in% existingPolySrcs)]
if (length(existingPolySrcs) == 1)
existingPolySrcs <- list(existingPolySrcs)
if (length(polySrcs) == 1)
polySrcs <- list(polySrcs)
polySrcs <-
list("Existing" = existingPolySrcs, "Process" = polySrcs)
if (length(existingPolySrcs) == 0)
selectedPolySrc <- "GADM"
else
selectedPolySrc <- existingPolySrcs[1]
shiny::updateSelectInput(
session = session,
inputId = "polySrc",
label = "polySrc",
choices = polySrcs,
selected = selectedPolySrc
)
})
######################## renderUI polyVer ###################################
observe({
print(paste0("output: polyVer"))
allPolyVers <- Rnightlights::getAllGadmVersions()
existingPolyVers <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries))
existingPolyVers <-
existingPolyVers[existingPolyVers$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingPolyVers <-
existingPolyVers[existingPolyVers$admLevel == admLevel, "polyVer"]
else
existingPolyVers <- unique(existingPolyVers[, "polyVer"])
polyVers <- allPolyVers[!(allPolyVers %in% existingPolyVers)]
if (length(existingPolyVers) == 1)
existingPolyVers <- list(existingPolyVers)
if (length(polyVers) == 1)
polyVers <- list(polyVers)
polyVers <-
list("Existing" = existingPolyVers, "Process" = polyVers)
if (length(existingPolyVers) == 0)
selectedPolyVer <- Rnightlights::pkgOptions("gadmVersion")
else
selectedPolyVer <- existingPolyVers[1]
shiny::updateSelectInput(
session = session,
inputId = "polyVer",
label = "polyVer",
choices = polyVers,
selected = selectedPolyVer
)
})
######################## renderUI polySrc ############################
observe({
print(paste0("output: polyType"))
allPolyTypes <- Rnightlights::getAllGadmPolyTypes()
existingPolyTypes <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries))
existingPolyTypes <-
existingPolyTypes[existingPolyTypes$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingPolyTypes <-
unique(existingPolyTypes[existingPolyTypes$admLevel == admLevel,
"polyType"])
else
existingPolyTypes <- unique(existingPolyTypes[, "polyType"])
polyTypes <-
allPolyTypes[!(allPolyTypes %in% existingPolyTypes)]
if (length(existingPolyTypes) == 1)
existingPolyTypes <- list(existingPolyTypes)
if (length(polyTypes) == 1)
polyTypes <- list(polyTypes)
polyTypes <-
list("Existing" = existingPolyTypes, "Process" = polyTypes)
if (length(existingPolyTypes) == 0)
selectedPolyType <- Rnightlights::pkgOptions("gadmPolyType")
else
selectedPolyType <- "shpZip" #default
shiny::updateSelectInput(
session = session,
inputId = "polyType",
label = "polyType",
choices = polyTypes,
selected = selectedPolyType
)
})
######################## renderUI ctryStats #########################
observe({
print(paste0("output: ctryStats"))
# if(is.null(getInputCountries()))
# return()
ctryStat <- input$ctryStat
optionNaRm <- input$optionNaRm
ctryDtStats <- ctryNlDataListStats()
#if(length(ctryDtStats) == 0)
# return()
existingStats <- trimws(ctryDtStats)
existingStats <-
unname(unlist(lapply(existingStats, function(x) {
xStat <- Rnightlights:::nlSignatureStat(nlStatSignature = x)
xHash <- Rnightlights:::hashNlStat(nlStatName = xStat)
isFun <-
suppressMessages(Rnightlights:::validNlStats(xStat)) ||
Rnightlights:::existsSavedNlStat(nlStatSig = x, nlStatHash = )
if (isFun)
{
if (optionNaRm)
Rnightlights:::nlSignatureAddArg(nlStatSigs = x,
addArg = "na.rm=T")
else
x
}
})))
existingStats <- sort(unique(existingStats))
savedStats <- Rnightlights:::listSavedNlStats()
for (savedStat in savedStats)
{
if (!exists(Rnightlights:::nlSignatureStatName(savedStat),
envir = .GlobalEnv))
Rnightlights:::loadSavedNlStat(savedStat)
}
defaultStats <-
unname(unlist(lapply(defaultStats, function(x) {
isValidNlStat <-
Rnightlights:::validNlStats(Rnightlights:::nlSignatureStat(x))
xStat <- Rnightlights:::nlSignatureStat(nlStatSignature = x)
xHash <- Rnightlights:::hashNlStat(nlStatName = xStat)
existsSavedNlStatName <-
Rnightlights:::existsSavedNlStat(nlStatSig = x, nlStatHash = xHash)
isFun <-
suppressMessages(isValidNlStat || existsSavedNlStatName)
if (isFun && optionNaRm)
Rnightlights:::nlSignatureAddArg(nlStatSigs = x, addArg = "na.rm=T")
else
x
})))
#defaultStats from global environment coz ctryNlData refs it
otherStats <- unique(c(savedStats, defaultStats))
otherStats <- sort(unique(setdiff(otherStats, existingStats)))
if (length(existingStats) == 1)
existingStats <- list(existingStats)
if (length(otherStats) == 1)
otherStats <- list(otherStats)
statChoices <-
list(
"Add New" = list("Add New"),
"With Data" = existingStats,
"Without Data" = otherStats
)
#memory
if (!is.null(ctryStat) && ctryStat != "")
{
selectedStat <- input$ctryStat
} else
{
if (length(existingStats) > 0)
selectedStat <- existingStats[1]
else if (length(otherStats) > 0)
selectedStat <- otherStats[1]
else
selectedStat <- "Add new"
}
# shiny::radioButtons(inputId = "ctryStat",
# label = "Stats",
# choices = statChoices,
# inline = TRUE,
# selected = selectedStat
# )
shiny::updateSelectInput(
session = session,
inputId = "ctryStat",
label = "Stats",
choices = statChoices,
selected = selectedStat
)
})
######################## renderUI newStatStatus #######################
output$newStatStatus <- shiny::renderUI({
print(paste0("output: newStatStatus"))
ctryStat <- input$ctryStat
if (is.null(ctryStat) ||
(!is.null(ctryStat) && ctryStat != "Add New"))
return()
shiny::textInput(inputId = "newStatStatus", label = NULL)
})
######################## renderUI newStat ############################
output$newStat <- shiny::renderUI({
print(paste0("output: newStat"))
ctryStat <- input$ctryStat
if (is.null(ctryStat) ||
(!is.null(ctryStat) && ctryStat != "Add New"))
return()
shiny::textAreaInput(inputId = "newStat",
label = "Function Name/Def",
placeholder =
"mySum <- function(x)\n sum(x, na.rm=TRUE)")
})
######################## renderUI btnNewStat ##########################
output$btnNewStat <- shiny::renderUI({
print(paste0("output: btnNewStat"))
ctryStat <- input$ctryStat
if (is.null(ctryStat) ||
(!is.null(ctryStat) && ctryStat != "Add New"))
return()
shiny::actionButton(inputId = "btnNewStat", label = "Add Function")
})
######################## renderUI nlType #############################
observe({
print(paste0("output: nlType"))
existingNlTypes <- unique(ctryNlTypes())
allNlTypes <- Rnightlights::getAllNlTypes()
if (length(existingNlTypes) == 0)
selectedNlType <- allNlTypes[1]
else
selectedNlType <- existingNlTypes[1]
#for memory
if (!is.null(input$nlType))
selectedNlType <- input$nlType
else
selectedNlType <- "VIIRS.M"
shiny::updateRadioButtons(
session = session,
inputId = "nlType",
label = "NL Type",
choices = allNlTypes,
selected = selectedNlType,
inline = TRUE
)
})
######################## reactive ctryNlDataList ############################
reactListCtryNlData <- shiny::reactive({
print(paste0("reactive: reactListCtryNlData"))
ctryCodes <- getInputCountries()
#if(is.null(ctryCodes))
# return()
if (is.null(ctryCodes))
return(Rnightlights::listCtryNlData())
dummy <- values$needsDataProcessing
Rnightlights::listCtryNlData(ctryCodes = ctryCodes)
})
######################## reactive ctryNlDataList ##########################
ctryNlDataList <- shiny::reactive({
print(paste0("reactive: ctryNlDataList"))
ctryCodes <- getInputCountries()
admLevel <- selectedAdmLevel3()
#if no country selected or one country selected but admLevel is NULL exit
# if(is.null(ctryCodes) ||
# (!is.null(ctryCodes) && length(ctryCodes)==1 && is.null(admLevel)))
# return()
availData <- reactListCtryNlData()
#always return a data.frame even zero row
availData[availData$ctryCode %in% ctryCodes &
availData$admLevel == admLevel,]
availData
})
######################## reactive ctryNlDataList ##########################
ctryNlDataListConfigName <- shiny::reactive({
print(paste0("reactive: ctryNlDataListConfigName"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
if (!is.null(input$nlType))
dat <- dta[dta$nlType == input$nlType,]
dta$configName
})
############### reactive ctryNlDataMultiTileMergeStrategy ################
ctryNlDataMultiTileMergeStrategy <- shiny::reactive({
print(paste0("reactive: ctryNlDataMultiTileMergeStrategy"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$multiTileMergeStrategy
})
############## reactive ctryNlDataMultiTileMergeFun ################
ctryNlDataMultiTileMergeFun <- shiny::reactive({
print(paste0("reactive: ctryNlDataMultiTileMergeFun"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$multiTileMergeFun
})
############# reactive ctryNlDataRemoveGasFlares #################
ctryNlDataRemoveGasFlares <- shiny::reactive({
print(paste0("reactive: ctryNlDataRemoveGasFlares"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$removeGasFlares
})
#################### reactive ctryNlDataListStats ##################
ctryNlDataListStats <- shiny::reactive({
print(paste0("reactive: ctryNlDataListStats"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
xStats <- lapply(unique(dta$ctryCode), function(ctryCode) {
trimws(unlist(strsplit(x = dta[dta$ctryCode == ctryCode, "nlStats"],
split = ","
)
)
)
})
if (length(xStats) == 1)
unique(unlist(xStats))
else
Reduce(intersect, xStats)
})
################### reactive ctryNlDataStats ######################
ctryNlDataStats <- shiny::reactive({
print(paste0("reactive: ctryNlDataStats"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$nlStats
})
############### renderUI configName ##################
observe({
print("output: configName")
nlType <- input$nlType
if (is.null(nlType))
nlType <- "VIIRS.M"
allConfigNames <- Rnightlights::getAllNlConfigNames()
allConfigNames <-
toupper(allConfigNames[allConfigNames$nlType == nlType, "configName"])
existingConfigNames <- unique(ctryNlDataListConfigName())
#keep only existing for this nlType
existingConfigNames <-
existingConfigNames[existingConfigNames %in% allConfigNames]
allConfigNames <-
allConfigNames[!(allConfigNames %in% existingConfigNames)]
if (length(existingConfigNames) == 1)
existingConfigNames <- list(existingConfigNames)
if (length(allConfigNames) == 1)
allConfigNames <- list(allConfigNames)
configNames <-
list("Existing" = existingConfigNames, "Process" = allConfigNames)
if (length(existingConfigNames) == 0)
selectedConfigName <-
toupper(Rnightlights::pkgOptions(paste0("configName_", nlType)))
else
selectedConfigName <- existingConfigNames[1]
shiny::updateSelectInput(
session = session,
inputId = "configName",
label = "configName",
choices = configNames,
selected = selectedConfigName
)
})
################### renderUI multiTileMergeStrategy #####################
observe({
print("output: multiTileStrategy")
allMultiTileMergeStrategys <- c("ALL", "FIRST", "LAST")
existingMultiTileMergeStrategys <- ctryNlDataList()
countries <- getInputCountries()
if (!is.null(countries) && nrow(existingMultiTileMergeStrategys) > 0)
existingMultiTileMergeStrategys <-
existingMultiTileMergeStrategys[
existingMultiTileMergeStrategys$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel) && nrow(existingMultiTileMergeStrategys) > 0)
{
existingMultiTileMergeStrategys <-
existingMultiTileMergeStrategys[
existingMultiTileMergeStrategys$admLevel == admLevel,
"multiTileMergeStrategy"]
} else if(nrow(existingMultiTileMergeStrategys) > 0){
existingMultiTileMergeStrategys <-
unique(existingMultiTileMergeStrategys[, "multiTileMergeStrategy"])
} else
{
existingMultiTileMergeStrategys <- NULL
}
multiTileMergeStrategys <-
allMultiTileMergeStrategys[!(allMultiTileMergeStrategys %in%
existingMultiTileMergeStrategys)]
if (length(existingMultiTileMergeStrategys) == 1)
existingMultiTileMergeStrategys <-
list(existingMultiTileMergeStrategys)
if (length(multiTileMergeStrategys) == 1)
multiTileMergeStrategys <- list(multiTileMergeStrategys)
multiTileMergeStrategys <-
list("Existing" = existingMultiTileMergeStrategys, "Process" = multiTileMergeStrategys)
if (length(existingMultiTileMergeStrategys) == 0)
selectedMultiTileMergeStrategy <-
toupper(Rnightlights::pkgOptions("multiTileStrategy"))
else
selectedMultiTileMergeStrategy <-
toupper(existingMultiTileMergeStrategys[1])
shiny::updateSelectInput(
session = session,
inputId = "multiTileMergeStrategy",
label = "multiTileStrategy",
choices = multiTileMergeStrategys,
selected = selectedMultiTileMergeStrategy
)
})
######################## renderUI multiTileMergeFun ###################################
observe({
print("output: multiTileMergeFun")
allMultiTileMergeFuns <- c("MEAN", "MEDIAN")
existingMultiTileMergeFuns <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries) && nrow(existingMultiTileMergeFuns) > 0)
existingMultiTileMergeFuns <-
existingMultiTileMergeFuns[existingMultiTileMergeFuns$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel) && nrow(existingMultiTileMergeFuns) > 0)
{
existingMultiTileMergeFuns <-
existingMultiTileMergeFuns[existingMultiTileMergeFuns$admLevel == admLevel, "multiTileMergeFun"]
} else if(nrow(existingMultiTileMergeFuns) > 0)
{
existingMultiTileMergeFuns <-
unique(existingMultiTileMergeFuns[, "multiTileMergeFun"])
} else
{
existingMultiTileMergeFuns <- NULL
}
multiTileMergeFuns <-
allMultiTileMergeFuns[!(allMultiTileMergeFuns %in% existingMultiTileMergeFuns)]
if (length(existingMultiTileMergeFuns) == 1)
existingMultiTileMergeFuns <- list(existingMultiTileMergeFuns)
if (length(multiTileMergeFuns) == 1)
multiTileMergeFuns <- list(multiTileMergeFuns)
multiTileMergeFuns <-
list("Existing" = existingMultiTileMergeFuns, "Process" = multiTileMergeFuns)
if (length(existingMultiTileMergeFuns) == 0)
selectedMultiTileMergeFun <-
toupper(Rnightlights::pkgOptions("multiTileMergeFun"))
else
selectedMultiTileMergeFun <- existingMultiTileMergeFuns[[1]]
shiny::updateSelectInput(
session = session,
inputId = "multiTileMergeFun",
label = "multiTileMergeFun",
choices = multiTileMergeFuns,
selected = selectedMultiTileMergeFun
)
})
######################## renderUI removeGasFlares ###################################
observe({
print("output: removeGasFlares")
allRemoveGasFlares <- c(TRUE, FALSE)
existingRemoveGasFlares <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries))
existingRemoveGasFlares <-
existingRemoveGasFlares[existingRemoveGasFlares$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingRemoveGasFlares <-
existingRemoveGasFlares[existingRemoveGasFlares$admLevel == admLevel, "removeGasFlares"]
else
existingRemoveGasFlares <-
unique(existingRemoveGasFlares[, "removeGasFlares"])
removeGasFlares <-
allRemoveGasFlares[!(allRemoveGasFlares %in% existingRemoveGasFlares)]
existingRemoveGasFlares <- as.logical(existingRemoveGasFlares)
removeGasFlares <- as.logical(removeGasFlares)
if (length(existingRemoveGasFlares) == 1)
existingRemoveGasFlares <- list(existingRemoveGasFlares)
if (length(removeGasFlares) == 1)
removeGasFlares <- list(removeGasFlares)
removeGasFlares <-
list("Existing" = existingRemoveGasFlares, "Process" = removeGasFlares)
if (length(existingRemoveGasFlares) == 0)
selectedRemoveGasFlare <-
Rnightlights::pkgOptions("removeGasFlares")
else
selectedRemoveGasFlare <- existingRemoveGasFlares[1]
shiny::updateSelectInput(
session = session,
inputId = "removeGasFlares",
label = "removeGasFlares",
choices = removeGasFlares,
selected = selectedRemoveGasFlare
)
})
######################## reactiveValues values ###################################
values <- shiny::reactiveValues(
lastUpdated = NULL,
needsDataUpdate = FALSE,
needsDataProcessing = FALSE,
newStatFuncName = NULL,
newStatFuncBody = NULL,
updatePlot = 0,
updateMap = 0
)
######################## observe lastUpdated ###################################
observe({
lapply(names(input), function(x) {
shiny::observe({
input[[x]]
#print(paste0("lastUpdated: ", x))
values$lastUpdated <- x
})
})
})
observe({
print(paste0("observe: newStat"))
countries <- getInputCountries()
admLevel <- selectedAdmLevel3()
nlType <- input$nlType
nlStat <- input$ctryStat
if (!is.null(nlStat) && nlStat == "Add New")
{
nlStat <- values$newStatFuncName
}
nlPeriod <- input$nlPeriodRange
if (!is.null(nlPeriod))
{
nlPeriod <-
Rnightlights::dateToNlPeriod(dt = nlPeriod, nlType = nlType)
if (all(Rnightlights::validNlPeriods(nlPeriods = nlPeriod, nlTypes = nlType)))
nlPeriod <-
Rnightlights::nlRange(
startNlPeriod = nlPeriod[1],
endNlPeriod = nlPeriod[2],
nlType = nlType
)
else
return()
}
else
{
nlPeriod <- input$nlPeriod
if (!is.null(nlPeriod))
nlPeriod <- as.character(nlPeriod)
}
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
custPolyPath <-
if (!is.null(polySrc) && polySrc == "CUST")
polyVer
else
NULL
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
if (length(countries) == 0)
return()
if ((length(countries) == 1 &&
is.null(admLevel)) || is.null(nlType) || is.null(nlStat) ||
length(nlStat) == 0 || nlStat == "" || is.null(polySrc) ||
is.null(polyVer) ||
is.null(polyType) ||
is.null(configName) || is.null(multiTileMergeStrategy) ||
is.null(multiTileMergeFun) || is.null(removeGasFlares))
return()
existsData <- sapply(countries, function(x) {
nlStatList <- Rnightlights:::nlSignatureStat(nlStat = nlStat)
Rnightlights:::existsCtryNlData(
ctryCode = x,
admLevel = admLevel,
nlTypes = nlType,
configNames = configName,
multiTileStrategy = multiTileMergeStrategy,
multiTileMergeFun = multiTileMergeFun,
removeGasFlares = removeGasFlares,
nlPeriods = nlPeriod,
nlStats = nlStatList,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath
)
})
if (any(!existsData))
{
print("existsData: Some data does not exist")
values$needsDataProcessing <- TRUE
}
else
values$needsDataProcessing <- FALSE
})
observeEvent(input$countries, {
print(paste0("observeEvent: input$countries"))
if (length(input$countries) > 1)
updateRadioButtons(session = session,
inputId = "admLevel",
selected = "country")
})
observe({
print(paste0("observe: needsDataProcessing"))
if ((length(input$countries) > 0) &&
!is.null(input$radioAdmLevel) && is.null(ctryNlDataList()))
{
values$needsDataProcessing
}
})
observeEvent(input$newStat, {
print(paste0("observeEvent: input$newstat"))
if (is.null(newStat <- input$newStat))
return()
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function Name/Definition")
})
observeEvent(input$btnNewStat, {
print(paste0("observeEvent: input$btnNewStat"))
if (is.null(newStat <- input$newStat))
return()
if (grepl("[a-zA-Z0-9_]\\s*(<-)|(=)\\s*function\\s*\\(.*\\).+",
newStat))
{
#if it is a function definition
#split into function name and body based on assignment operator
statParts <- unlist(strsplit(x = newStat, split = "<-"))
newStatName <- trimws(statParts[1])
newStatBody <- trimws(statParts[2])
#add the function into the global environment so we can access it later
assign(x = newStatName,
value = eval(parse(text = newStatBody)),
envir = .GlobalEnv)
newStat <- newStatName
} else if (grepl("^list\\s*\\(", newStat))
{
statList <- eval(parse(text = newStat))
if (is.list(statList))
{
newStatName <- statList[[1]]
}
} else
{
newStatName <- newStat
}
validStat <- Rnightlights:::validNlStats(nlStats = newStatName)
if (validStat)
{
ctryNlDataList <- ctryNlDataList()
if (!is.null(ctryNlDataList))
{
existingStats <- unique(ctryNlDataList$nlStats)
if (newStat %in% existingStats)
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function name exists")
else
{
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function OK")
if (!is.null(input$countries))
{
values$newStatFuncName <- newStat
if (exists("newStatBody"))
values$newStatFuncBody <-
eval(parse(text = newStatBody))
else
values$newStatFuncBody <- NULL
}
}
return()
} else
{
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function OK")
return()
}
} else
{
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Invalid Function")
return()
}
})
observeEvent(input$countries, {
print(paste0("observeEvent: input$countries"))
if (!is.null(input$countries) && !values$needsDataUpdate)
values$needsDataUpdate <- TRUE
})
observeEvent(input$radioAdmLevel, {
print(paste0("observeEvent: input$radioAdmLevel"))
if (!is.null(input$countries) && !values$needsDataUpdate)
values$needsDataUpdate <- TRUE
})
observeEvent(input$btnGo, {
print(paste0("observeEvent: input$btnGo"))
values$needsDataUpdate <- FALSE
values$needsDataProcessing <- FALSE
values$updatePlot <- values$updatePlot + 1
values$updateMap <- values$updateMap + 1
})
######################## renderUI radioAdmLevel ###################################
output$radioAdmLevel <- shiny::renderUI({
print("output: radioAdmLevel")
countries <- getInputCountries()
if (is.null(countries))
return()
# strict <- shiny::isolate(input$strict)
if (length(countries) != 1)
return()
admLevels <- unlist(ctryAdmLevels())
if (is.null(admLevels))
return()
availData <- reactListCtryNlData()
# if(strict)
admLevels <-
unlist(sapply(seq_along(admLevels), function(admLevel)
{
ctryNlDataFile <-
Rnightlights:::getCtryNlDataFnamePath(
ctryCode = countries,
admLevel = Rnightlights:::getCtryShpLyrNames(ctryCode = countries,
lyrNums = admLevel - 1,)
)
if (!is.null(availData))
admLevelHasData <-
nrow(availData[availData$ctryCode == countries &
availData$admLevel == paste0("ADM", admLevel -
1), ]) > 0
else
admLevelHasData <- FALSE
if (admLevelHasData)
return(admLevels[admLevel])
else
return(paste0(admLevels[admLevel], " (NA)"))
}))
selectedRadioAdmLevel <- if (!is.null(input$radioAdmLevel) && length(countries) == 1)
input$radioAdmLevel
else if(length(nonNARadioAdmLevel <- grep(pattern = "NA", x = admLevels, value = TRUE, invert = TRUE))>0)
nonNARadioAdmLevel[1]
else
admLevels[1]
shiny::radioButtons(
inputId = "radioAdmLevel",
label = "Admin Level",
choiceNames = admLevels,
choiceValues = gsub("\\s*\\(NA\\)", "", admLevels),
selected = gsub("\\s*\\(NA\\)", "", selectedRadioAdmLevel)
)
})
######################## render UI: selectAdmLevel ###################################
tags$head(tags$style(
HTML(
"div.form-group.shiny-input-container {margin-top: -20px; margin-bottom: -20px;}"
)
))
output$selectAdmLevel <- shiny::renderUI({
print("output: selectAdmLevel")
countries <- getInputCountries()
#strict <- shiny::isolate(input$strict)
if (length(countries) != 1 ||
identical(countries, character(0)))
return()
if ((
length(countries) != 1 ||
identical(countries, character(0)) || grepl("^\\s*$", countries)
))
return()
ctryAdmLevels <- unlist(ctryAdmLevels())
if (is.null(ctryAdmLevels))
return()
ctryAdmLevelNames <- ctryAdmLevelNames()
if (ncol(ctryAdmLevelNames) > 2)
elems <- lapply(2:length(ctryAdmLevels), function(lvlIdx) {
lvl <- ctryAdmLevels[lvlIdx]
# if(strict)
# lvlEnabled <- file.exists(Rnightlights:::getCtryNlDataFnamePath(countries, paste(getInputCountries(), "_adm", lvlIdx-1, sep = "")))
# else
# lvlEnabled <- TRUE
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNames, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
# if(!lvlEnabled)
# lvlSelect <- NULL
#if(lvlEnabled)
#{
b <-
shiny::selectizeInput(
inputId = paste0("selectAdm", lvlIdx),
label = ctryAdmLevels[lvlIdx],
#choices = NULL,
choices = lvlSelect,
multiple = TRUE
)
# }else
# {
# b <- shiny::textInput(inputId = "dummy",
# label = ctryAdmLevels[lvlIdx],
# value = "Strict: Data Not Available",
# placeholder = "Disable Strict to aggregate data")
# }
b
})
})
######################## selectedAdmLevelInput ###################################
selectedAdmLevelInput <- shiny::reactive({
print("reactive: selectedAdmLevelInput")
admLvlCtrlNames <- names(input)
x <- admLvlCtrlNames[grep("selectAdm\\d+$", admLvlCtrlNames)]
shiny::isolate({
admLvlNums <- NULL
for (i in x)
if (length(input[[i]]) > 0)
admLvlNums <- c(admLvlNums, i)
#print(paste0("x", x))
#print(paste0("admlvlnums:", admLvlNums))
#if (admLvlNum=="" && length(countries)>0)
# return()
admLvlNums <-
as.numeric(gsub("[^[:digit:]]", "", admLvlNums))
if (length(admLvlNums) == 0)
admLvlNums <- 1
})
selectedAdmLevel()[admLvlNums]
})
######################## selectedAdmLevel ###################################
selectedAdmLevel <- shiny::reactive({
print("reactive: selectedAdmLevel")
if (length(getInputCountries()) == 0)
return()
admLevel <- input$radioAdmLevel
admLevel
})
######################## selectedAdmLevel3 ###################################
selectedAdmLevel3 <- shiny::reactive({
print("reactive: selectedAdmLevel3")
if (length(getInputCountries()) > 1)
return("ADM0")
x <- selectedAdmLevel()
if (length(x) == 0)
return(NULL)
x <-
Rnightlights::searchAdmLevel(ctryCodes = input$countries,
admLevelNames = x)
admLevel <-
paste0("ADM", substr(
x = x,
start = nchar(x),
stop = nchar(x)
))
admLevel
})
######################## observe selectAdms (selectAdmLevel) ###################################
shiny::observe({
print(paste0("observe: selectAdms"))
countries <- input$countries
if (length(countries) == 0)
return()
#strict <- shiny::isolate(input$strict)
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
custPolyPath <-
if (!is.null(polySrc) && polySrc == "CUST")
polyVer
else
NULL
admLvlCtrlsNames <- names(input)
x <-
admLvlCtrlsNames[grep("selectAdm\\d+$", admLvlCtrlsNames)]
if (length(x) == 0)
return()
admSelected <- FALSE
lowestSelected <- ""
for (i in x)
{
if (length(input[[i]]) > 0)
{
admSelected <- TRUE
lowestSelected <- gsub("[^[:digit:]]", "", i)
}
}
ctryAdmLevelNames <- ctryAdmLevelNames()
ctryAdmLevelNamesFilter <- ctryAdmLevelNames
ctryAdmLevels <- unlist(ctryAdmLevels())
lvlNum <-
gsub("[^[:digit:]]", "", values$lastUpdated) #gsub("[^[:digit:]]", "", x)
#message("lvlnum:", lvlNum, ":", str(lvlNum))
if (lvlNum == "" || length(countries) == 0)
return()
#trigger Go button
values$needsDataUpdate <- TRUE
if (!admSelected)
{
for (lvlIdx in 2:length(ctryAdmLevels)) {
lvl <- ctryAdmLevels[lvlIdx]
# if(strict)
# lvlEnabled <- file.exists(Rnightlights:::getCtryNlDataFnamePath(countries, paste(getInputCountries(), "_adm", lvlIdx-1, sep = "")))
# else
# lvlEnabled <- TRUE
#lvlSelect <- unique(ctryAdmLevelNames[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNames, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
# if(!lvlEnabled)
# lvlSelect <- NULL
# if(lvlEnabled)
# {
shiny::updateSelectizeInput(
session = session,
inputId = paste0("selectAdm", lvlIdx),
label = ctryAdmLevels[lvlIdx],
#choices = NULL,
choices = lvlSelect,
)
# }else
# {
# shiny::updateTextInput(session = session,
# inputId = "dummy",
# label = ctryAdmLevels[lvlIdx],
# value = "Strict: Data Not Available",
# placeholder = "Disable Strict to aggregate data")
# }
}
return()
}
#print(paste0("lastupdated:", values$lastUpdated))
#print(paste0("x:", x))
print(paste0("lvlnum:", lvlNum))
#set admLevel to match the selectizeInput level
#if (length(input[[paste0("selectAdm", lvlNum)]]) > 0)
updateRadioButtons(session = session,
inputId = "radioAdmLevel",
selected = ctryAdmLevels[as.numeric(lowestSelected)])
multipleSelected <- FALSE
#loop through all selectAdms and effect changes relative to the one that has last changed
for (lvlIdx in 2:length(ctryAdmLevels))
{
lvlSelect <- ""
top10 <- ""
# if(strict)
# lvlEnabled <- file.exists(
# Rnightlights:::getCtryNlDataFnamePath(ctryCode = getInputCountries(),
# admLevel = Rnightlights:::getCtryShpLyrNames(ctryCodes = getInputCountries(),
# lyrNums = lvlIdx-1,
# gadmVersion = polyVer,
# gadmPolyType = polyType,
# custPolyPath = custPolyPath),
# gadmVersion = polyVer,
# gadmPolyType = polyType,
# custPolyPath = custPolyPath))
# else
# lvlEnabled <- TRUE
if (length(input[[paste0("selectAdm", lvlIdx)]]) > 1)
multipleSelected <- TRUE
if (lvlIdx < lvlNum)
{
#print(paste0("lvlIdx:",lvlIdx,"lvlNum:",lvlNum))
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 1)
{
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] == input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
}
else
{
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
}
#print(paste0("lvlSelect:",lvlSelect))
#print(paste0("lvlselect: ", lvlSelect))
#print(paste0("top10: ", top10))
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = TRUE)
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]]
)
}
else if (lvlIdx == lvlNum)
{
#print(paste0("lvlIdx:",lvlIdx,"lvlNum:",lvlNum))
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 1)
{
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] == input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
#top10 <- if(length(lvlSelect) > 1) lvlSelect[1] else no = lvlSelect
#print(paste0("lvlselect: ", lvlSelect))
#print(paste0("top10: ", top10))
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = TRUE)
# if(!lvlEnabled)
# lvlSelect <- NULL
# if (length(input[[paste0("radioAdm", lvlIdx)]])==0)
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]]
)
} else
{
shiny::updateSelectizeInput(session, paste0("selectAdm", lvlIdx), choices = NULL)
}
}
else
{
#print(paste0("lvlIdx:",lvlIdx,"lvlNum:",lvlNum))
# if (multipleSelected)
# {
# shiny::updateSelectizeInput(session, paste0("selectAdm", lvlIdx), choices = "")
# next()
# }
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 1)
{
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] == input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = FALSE)
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]][input[[paste0("selectAdm", lvlIdx)]] %in% unlist(lvlSelect)]
)
}
else if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 0 &&
length(input[[paste0("selectAdm", lvlNum)]]) == 1)
{
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]][input[[paste0("selectAdm", lvlIdx)]] %in% unlist(lvlSelect)]
)
}
else
{
##lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
#lvlSelect <- unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx-1,lvlIdx))
#lvlSelect <- group_by(lvlSelect, ctryAdmLevels[lvlIdx-1])
#lvlSelect <- split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx-1]]])
#shiny::updateSelectizeInput(session, paste0("selectAdm", lvlIdx), choices = lvlSelect, selected = NULL)
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) > 0)
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] %in% input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = FALSE)
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]][input[[paste0("selectAdm", lvlIdx)]] %in% unlist(lvlSelect)]
)
}
}
# if(!lvlEnabled)
# {
# shinyjs::disable(selector = paste0("[type=radio][value=selectAdm", lvlIdx,"]"))
#
# shinyjs::disable(paste0("selectAdm", lvlIdx))
#
# shinyjs::runjs(paste0("$('selectAdm", lvlIdx, "').parent().parent().addClass('disabled').css('opacity', 0.4)"))
# }
}
#})
})
#})
######################## sliderNlPeriodRange ###################################
output$sliderNlPeriodRange <- shiny::renderUI({
print(paste0("output: sliderNlPeriodRange"))
#ctryData <- ctryNlDataMelted()
nlType <- input$nlType
if (is.null(nlType))
return()
shiny::isolate({
nlPeriodRange <- input$nlPeriodRange
if (!is.null(values$lastUpdated) &&
values$lastUpdated == "nlPeriodRange")
{
startDate <- nlPeriodRange[1]
endDate <- nlPeriodRange[2]
} else
#if (is.null(ctryData))
{
if (!is.null(nlType))
nlP <- input$nlPeriodRange
else
nlP <- NULL
if (!is.null(nlP))
nlP <-
Rnightlights::dateToNlPeriod(dt = nlP, nlType = nlType)
if (!is.null(nlP) &&
!all(Rnightlights::validNlPeriods(nlPeriods = nlP, nlTypes = nlType)))
nlPeriodRange <- NULL
if (!is.null(dta <- ctryNlDataList()))
{
dta <- dta[dta$nlType == nlType,]
if (!is.null(admLevel <- selectedAdmLevel3()))
dta <- dta[dta$admLevel == admLevel,]
startDate <- min(dta$nlPeriod)
endDate <- max(dta$nlPeriod)
} else if (!is.null(nlPeriodRange))
{
startDate <- Rnightlights::dateToNlPeriod(nlPeriodRange[1], nlType)
endDate <-
Rnightlights::dateToNlPeriod(nlPeriodRange[2], nlType)
} else {
if (is.null(nlType))
nlType <- "VIIRS.M"
dta <- unlist(Rnightlights::getAllNlPeriods(nlType))
startDate <- dta[1]
endDate <- dta[length(dta)]
}
startDate <-
gsub("-*$", "", paste(
substr(startDate, 1, 4),
substr(startDate, 5, 6),
substr(startDate, 7, 8),
sep = "-"
))
endDate <-
gsub("-*$", "", paste(
substr(endDate, 1, 4),
substr(endDate, 5, 6),
substr(endDate, 7, 8),
sep = "-"
))
if (stringr::str_detect(nlType, "D"))
{
startDate <- paste0(startDate)
endDate <- paste0(endDate)
} else if (stringr::str_detect(nlType, "M"))
{
startDate <- paste0(startDate, "-01")
endDate <- paste0(endDate, "-01")
} else if (stringr::str_detect(nlType, "Y"))
{
startDate <- paste0(startDate, "-01-01")
endDate <- paste0(endDate, "-01-01")
}
tmFmt <- "%Y-%m-%d"
startDate <- as.Date(as.character(startDate), tmFmt)
endDate <- as.Date(as.character(endDate), tmFmt)
#minDate <- startDate
#maxDate <- endDate
# shiny::sliderInput(inputId = "nlPeriodRange",
# label = "Time",
# min = as.Date("2012-04-01", "%Y-%m-%d"),
# max = as.Date("2017-10-31", "%Y-%m-%d"),
# timeFormat = "%Y-%m",
# step = 31,
# value = c(as.Date("2012-04-01","%Y-%m-%d"),as.Date("2017-10-31","%Y-%m-%d"))
# )
}
# else
# {
# if(!is.null(nlPeriodRange))
# nlPeriodRange <- NULL
#
# #startDate <- min(ctryData$variable)
# #endDate <- max(ctryData$variable)
# #minDate <- startDate
# #maxDate <- endDate
# }
if (stringr::str_detect(nlType, "D"))
{
tmFmt <- "%Y-%m-%d"
if (!is.null(nlPeriodRange))
{
nlRangeStart <- nlPeriodRange[1]
nlRangeEnd <- nlPeriodRange[2]
}
step <- 1
} else if (stringr::str_detect(nlType, "M"))
{
tmFmt <- "%Y-%m"
if (!is.null(nlPeriodRange))
{
nlRangeStart <- nlPeriodRange[1]
nlRangeEnd <- nlPeriodRange[2]
}
step <- 31
} else if (stringr::str_detect(nlType, "Y"))
{
tmFmt <- "%Y"
if (!is.null(nlPeriodRange))
{
nlRangeStart <- nlPeriodRange[1]
nlRangeEnd <- nlPeriodRange[2]
}
step <- 1
}
if (!is.null(nlPeriodRange))
{
if (is.na(nlRangeStart))
{
nlRangeStart <- startDate
nlRangeEnd <- endDate
}
# if(nlRangeStart > startDate)
# startDate <- nlRangeStart
#
# if(nlRangeEnd < endDate)
# endDate <- nlRangeEnd
}
allNlPeriods <-
unlist(Rnightlights::getAllNlPeriods(nlTypes = nlType))
minDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[1], nlType = nlType)
maxDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[length(allNlPeriods)], nlType = nlType)
shiny::absolutePanel(
draggable = T,
top = "65vh",
left = "7%",
shiny::sliderInput(
inputId = "nlPeriodRange",
label = "Time",
min = minDate,
max = maxDate,
timeFormat = tmFmt,
step = step,
value = c(startDate, endDate),
animate = animationOptions(
interval = 1000,
loop = FALSE,
playButton = NULL,
pauseButton = NULL
)
)
)
})
})
######################## sliderNlPeriod ###################################
output$sliderNlPeriod <- shiny::renderUI({
print(paste0("output: sliderNlPeriod"))
#ctryData <- ctryNlDataMelted()
#shiny::isolate({
nlType <- input$nlType
nlPeriod <- input$nlPeriod
if (!is.null(values$lastUpdated) &&
values$lastUpdated == "nlPeriod")
{
value <- nlPeriod
} else
#if (is.null(ctryData))
{
if (!is.null(nlType))
nlP <- input$nlPeriod
else
nlP <- NULL
if (!is.null(nlP))
nlP <-
Rnightlights::dateToNlPeriod(dt = nlP, nlType = nlType)
if (!is.null(nlP) &&
!all(Rnightlights::validNlPeriods(nlPeriods = nlP, nlTypes = nlType)))
nlPeriod <- NULL
if (!is.null(dta <- ctryNlDataList()))
{
dta <- dta[dta$nlType == nlType,]
if (!is.null(admLevel <- selectedAdmLevel3()))
dta <- dta[dta$admLevel == admLevel,]
value <- min(dta$nlPeriod)
} else if (!is.null(nlPeriod))
{
value <- Rnightlights::dateToNlPeriod(nlPeriod, nlType)
} else {
if (is.null(nlType))
nlType <- "VIIRS.M"
dta <- unlist(Rnightlights::getAllNlPeriods(nlType))
value <- dta[1]
}
value <-
gsub("-*$", "", paste(
substr(value, 1, 4),
substr(value, 5, 6),
substr(value, 7, 8),
sep = "-"
))
if (stringr::str_detect(nlType, "D"))
{
} else if (stringr::str_detect(nlType, "M"))
{
value <- paste0(value, "-01")
} else if (stringr::str_detect(nlType, "Y"))
{
value <- paste0(value, "-01-01")
}
tmFmt <- "%Y-%m-%d"
value <- as.Date(as.character(value), tmFmt)
}
# else
# {
# #value <- min(ctryData$variable)
# }
if (stringr::str_detect(nlType, "D"))
{
tmFmt <- "%Y-%m-%d"
if (!is.null(nlPeriod))
{
value <- nlPeriod
}
step <- 1
}
else if (stringr::str_detect(nlType, "M"))
{
tmFmt <- "%Y-%m"
if (!is.null(nlPeriod))
{
value <- nlPeriod
}
step <- 31
}
else if (stringr::str_detect(nlType, "Y"))
{
tmFmt <- "%Y"
if (!is.null(nlPeriod))
{
value <- nlPeriod
}
step <- 366
}
# if(!is.null(input$nlPeriod))
# value <- as.Date(as.character(input$nlPeriod), tmFmt)
allNlPeriods <-
unlist(Rnightlights::getAllNlPeriods(nlTypes = nlType))
minDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[1], nlType = nlType)
maxDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[length(allNlPeriods)], nlType = nlType)
shiny::sliderInput(
inputId = "nlPeriod",
label = "Time",
min = minDate,
max = maxDate,
timeFormat = tmFmt,
step = step,
value = value,
animate = animationOptions(
interval = 1000,
loop = FALSE,
playButton = "Play",
pauseButton = NULL
)
)
#})
})
######################## textDate ###################################
# output$textDate <- shiny::renderUI({
# print(paste0("output: textDate"))
#
# nlPeriod <-
#
# dateInput(inputId = textDate, )
#
# })
######################## hCluster ###################################
hCluster <- shiny::reactive({
print(paste0("reactive: hCluster"))
input$btnGo
if (values$needsDataProcessing || values$needsDataUpdate)
return()
countries <- getInputCountries()
admLevel <- input$radioAdmLevel #unlist(ctryAdmLevels())[2]
if (is.null(countries) ||
(length(countries) == 1 && admLevel == "country"))
return()
if (length(countries) > 1)
admLevel <- "country"
scale <- input$scale
normArea <- input$norm_area
shiny::isolate({
nlPeriodRange <- input$nlPeriodRange
graphType <- input$graphType
#return if the country doesn't have adm levels below country
if (is.null(admLevel) || is.na(admLevel))
return()
#meltCtryData <- ctryNlDataMelted()
meltCtryData <- ctryNlDataMelted()
if (is.null(countries) ||
is.null(meltCtryData) || nrow(meltCtryData) < 3)
return()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
#aggMeltCtryData <- stats::aggregate(mean(value), by=list(eval(admLevel)+variable), data=meltCtryData, mean)
aggMeltCtryData <-
stats::setNames(meltCtryData[, list(mean(value, na.rm = TRUE)), by = list(meltCtryData[[admLevel]], variable)], c(admLevel, "variable", "value"))
dcastFormula <-
paste(paste0("`", admLevel, "`", collapse = " + "),
"~",
paste("variable", collapse = " + "))
unmeltCtryData <-
data.table::dcast(aggMeltCtryData,
dcastFormula,
value.var = 'value',
aggregate = 'mean')
d <- stats::dist(unmeltCtryData)
h <- stats::hclust(d)
h$labels <- unmeltCtryData[[admLevel]]
h
})
})
######################## plotHCluster ###################################
output$plotHCluster <- shiny::renderPlot({
print(paste0("output: plotHCluster"))
clusts <- hCluster()
numClusters <- input$kClusters
if (is.null(clusts))
return("Country has no adm levels")
countries <- shiny::isolate(getInputCountries())
if (length(countries) > 1)
admLevel <- "country"
shiny::isolate({
cutClusts <- stats::cutree(clusts, k = numClusters)
dendro <- stats::as.dendrogram(clusts)
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
dendro %>%
dendextend::color_branches(k = numClusters,
col = rev(cbPalette[1:numClusters]),
groupLabels = T) %>%
dendextend::color_labels(k = numClusters, col = rev(cbPalette[1:numClusters])) %>%
graphics::plot(horiz = FALSE, main = "")
dendro %>% dendextend::rect.dendrogram(k = numClusters,
horiz = FALSE,
border = rev(cbPalette[1:numClusters]))
})
})
######################## plotPointsCluster ###################################
output$plotPointsCluster <- plotly::renderPlotly({
print(paste0("output: plotPointsCluster"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
if (length(countries) < 1)
return()
clusts <- hCluster()
if (is.null(clusts))
return()
normArea <- input$norm_area
admLevel <- input$radioAdmLevel #unlist(ctryAdmLevels())[2]
#return if the country doesn't have adm levels below country
if (is.null(admLevel))
return()
if (length(countries) > 1)
admLevel <- "country"
numClusters <- input$kClusters
scale <- input$scale
isolate({
meltCtryData <- ctryNlDataMelted()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
cutClusts <- stats::cutree(clusts, k = numClusters)
#ctryAvg <- aggregate(value ~ admLevel, data=meltCtryData, mean)
ctryAvg <-
stats::setNames(meltCtryData[, mean(value, na.rm = TRUE), by = list(meltCtryData[[admLevel]])], c(admLevel, "value"))
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
clusters <- as.factor(cutClusts)
g <- ggplot2::ggplot(data = ctryAvg,
aes(x = ctryAvg[[admLevel]],
y = value, col = clusters)) +
geom_point(size = 2) +
theme(axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
)) +
ggplot2::scale_colour_manual(values = cbPalette) +
xlab(admLevel) +
ylab("Radiance")
p <- plotly::ggplotly(g)
p$elementId <- NULL
p
})
})
######################## mapHCluster ###################################
output$mapHCluster <- leaflet::renderLeaflet({
print(paste0("output: mapHCluster"))
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
input$btnGo
if (values$needsDataUpdate || values$needsDataProcessing)
return()
countries <- shiny::isolate(getInputCountries())
scale <- input$scale
numClusters <- input$kClusters
normArea <- input$norm_area
shiny::isolate({
if (is.null(countries))
return()
if (length(countries) > 1)
admLevel <- "country"
# if (length(countries) != 1)
# {
# renderText("Please select only one country/region")
# return()
# }
#print("drawing leaflet cluster")
clusts <- hCluster()
if (is.null(clusts))
return()
cutClusts <- stats::cutree(clusts, k = numClusters)
admLevel <- input$radioAdmLevel #unlist(ctryAdmLevels())[2]
meltCtryData <- ctryNlDataMelted()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
#map <- leaflet::leaflet(data=ctryPoly0) %>%
map <- leaflet::leaflet() %>%
leaflet::addTiles("http://a.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png")
#leaflet::addTiles() %>%
# leaflet::addWMSTiles(layerId="nlRaster",
# baseUrl = "http://localhost/cgi-bin/mapserv?map=test.map",
# layers = "NL_CTRYCODE_VIIRS.M_NLPERIOD_VCMCFG-MTSALL-MEAN-RGFT_GADM-3.6-SHPZIP",
# options = leaflet::WMSTileOptions(format = "image/png",
# transparent = TRUE,
# opacity=0.8))
ctryPoly0 <-
Rnightlights::readCtryPolyAdmLayer(
ctryCode = countries[1],
admLevel = unlist(Rnightlights::getCtryShpLyrNames(countries[1], 0))
)
if (length(countries) > 1) {
for (country in countries[2:length(countries)])
{
ctryPoly0 <- sp::rbind.SpatialPolygonsDataFrame(
ctryPoly0,
Rnightlights::readCtryPolyAdmLayer(
ctryCode = country,
admLevel = unlist(Rnightlights::getCtryShpLyrNames(country, 0))
),
makeUniqueIDs = T
)
}
lvlCtryData <-
stats::setNames(meltCtryData[, mean(value, na.rm = TRUE), by = list(meltCtryData[[admLevel]])], c(admLevel, "value"))
lvlCtryData[["rank"]] <-
with(lvlCtryData, rank(value, ties.method = 'first'))
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
pal <- cbPalette
ctryPoly0 <- sp::spTransform(ctryPoly0, wgs84)
mapLabels <- sprintf(
paste0(
"%s:%s",
"<br/>Cluster: %s",
"<br/>Rad:%s",
"<br/>Rank: %s/%s"
),
admLevel,
lvlCtryData[[1]],
cutClusts,
format(
lvlCtryData[[2]],
scientific = T,
digits = 2
),
lvlCtryData[["rank"]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
map <- map %>% leaflet::addPolygons(
data = ctryPoly0,
#layerId = "country",
fill = TRUE,
fillColor = pal[cutClusts],
fillOpacity = 0.9,
stroke = TRUE,
weight = 1,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = admLevel,
highlight = leaflet::highlightOptions(
weight = 5,
#color = "#666",
#dashArray = "",
fillOpacity = 0,
bringToFront = TRUE
),
label = mapLabels,
labelOptions = leaflet::labelOptions(
style = list("font-weight" = "normal",
padding = "3px 8px"),
textsize = "15px",
direction = "auto"
)
)
} else
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly0,
layerId = countries,
fill = FALSE,
fillColor = "#fefe40",
stroke = TRUE,
weight = 4,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = "country"
)
lvlCtryData <-
stats::setNames(meltCtryData[, mean(value, na.rm = TRUE), by = list(meltCtryData[[admLevel]])], c(admLevel, "value"))
lvlCtryData[["rank"]] <-
with(lvlCtryData, rank(value, ties.method = 'first'))
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
pal <- cbPalette
#turn off previous layer? No point keeping it if it is hidden. Also we want to turn the current layer to transparent so that one can see through to the raster layer on hover
ctryPoly <- Rnightlights::readCtryPolyAdmLayer(countries,
unlist(Rnightlights::getCtryShpLyrNames(countries, 1)))
ctryPoly <- sp::spTransform(ctryPoly, wgs84)
mapLabels <- sprintf(
paste0(
"%s:%s",
"<br/>Cluster: %s",
"<br/>Rad:%s",
"<br/>Rank: %s/%s"
),
admLevel,
lvlCtryData[[1]],
cutClusts,
format(
lvlCtryData[[2]],
scientific = T,
digits = 2
),
lvlCtryData[["rank"]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
map <- map %>% leaflet::addPolygons(
data = ctryPoly,
layerId = as.character(ctryPoly@data[, 'NAME_1']),
fill = TRUE,
fillColor = pal[cutClusts],
fillOpacity = 0.9,
stroke = TRUE,
weight = 1,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = admLevel,
highlight = leaflet::highlightOptions(
weight = 5,
#color = "#666",
#dashArray = "",
fillOpacity = 0,
bringToFront = TRUE
),
label = mapLabels,
labelOptions = leaflet::labelOptions(
style = list("font-weight" = "normal",
padding = "3px 8px"),
textsize = "15px",
direction = "auto"
)
)
}
map <-
map %>% leaflet::addLayersControl(overlayGroups = admLevel)
map <- map %>% leaflet::addLegend(
position = "bottomright",
colors = pal[unique(cutClusts)],
labels = unique(cutClusts),
#title = "Nightlight percentiles",
title = "clusters",
opacity = 1
)
map
})
})
######################## renderPlot plotTSDecomposed ###################################
output$plotTSDecomposed <- shiny::renderPlot({
#print(paste0("output: plotTSDecomposed"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
if (length(countries) < 1)
return()
normArea <- input$norm_area
admLevel <- unlist(ctryAdmLevels())[2]
#return if the country doesn't have adm levels below country
if (is.null(admLevel) || admLevel == "")
return()
if (length(countries) > 1)
admLevel <- "country"
scale <- input$scale
shiny::isolate({
nlType <- input$nlType
#meltCtryData <- ctryNlDataMeltedLvl2()
meltCtryData <- ctryNlDataMelted()
if (nrow(meltCtryData) < 2)
return()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
ctryAvg <- meltCtryData
#ctryAvg <- aggregate(value ~ country, data=meltCtryData, mean)
#ctryAvg <- stats::setNames(meltCtryData[,mean(value, na.rm = TRUE), by = list(meltCtryData[[make.names(admLevel)]], variable)], c(admLevel, "variable", "value"))
if (stringr::str_detect(nlType, "\\.D"))
fmt <- "%Y-%M-%d"
else if (stringr::str_detect(nlType, "\\.M"))
fmt <- "%Y-%M-%d"
else if (stringr::str_detect(nlType, "\\.Y"))
fmt <- "%Y"
minDate <- as.character(min(ctryAvg$variable))
maxDate <- as.character(max(ctryAvg$variable))
if (stringr::str_detect(nlType, "\\.Y") &&
stringr::str_detect(minDate, "\\d+$"))
{
minDate <- paste0(minDate, "-01-01")
maxDate <- paste0(maxDate, "-01-01")
freq <- 2
}
startYear <- lubridate::year(as.Date(minDate, fmt))
endYear <- lubridate::year(as.Date(maxDate, fmt))
if (startYear == endYear)
stop(Sys.time(), ": Only 1 data point (year) in the dataset")
tsStart <- c(startYear)
tsEnd <- c(endYear)
if (stringr::str_detect(nlType, "\\.D|\\.M"))
{
startMonth <-
lubridate::month(lubridate::ymd(min(ctryAvg$variable)))
endMonth <-
lubridate::month(lubridate::ymd(max(ctryAvg$variable)))
tsStart <- c(tsStart, startMonth)
tsEnd <- c(tsEnd, endMonth)
freq <- 12
}
if (stringr::str_detect(nlType, "\\.D"))
{
startDay <- lubridate::day(lubridate::ymd(max(ctryAvg$variable)))
endDay <-
lubridate::month(lubridate::ymd(max(ctryAvg$variable)))
tsStart <- c(tsStart, startDay)
tsEnd <- c(tsEnd, endDay)
freq <- 7
}
ctryDataTS <-
stats::ts(
ctryAvg$value,
start = tsStart,
end = tsEnd,
frequency = freq
)
ctryDataTScomponents <- stats::decompose(ctryDataTS)
#g <- ggplot2::autoplot(ctryDataTScomponents)
graphics::plot(ctryDataTScomponents)
})
})
######################## plotYearly ###################################
output$plotYearly <- shiny::renderPlot({
#print(paste0("output: renderPlotYearly"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
if (is.null(countries))
return(NULL)
scale <- input$scale
nlPeriodRange <- input$nlPeriodRange
graphType <- input$graphType
normArea <- input$norm_area
shiny::isolate({
nlType <- input$nlType
ctryData <- ctryNlDataMelted()
if (is.null(countries) || is.null(ctryData))
return()
admLevel <- unlist(ctryAdmLevels())[1]
#print(paste0("admLevel:", admLevel))
if (!exists("admLevel") ||
is.null(admLevel) || length(admLevel) == 0)
admLevel <- "country"
ctryData$year <-
lubridate::year(as.Date(as.character(ctryData$variable), "%Y"))
lstAggBy <- paste0("list(", admLevel, ", variable")
lstAggBy <- paste0(lstAggBy, ", as.factor(year)")
aggNames <- "year"
if (stringr::str_detect(nlType, "\\.M"))
{
ctryData$month <-
lubridate::month(as.Date(as.character(ctryData$variable)))
lstAggBy <- paste0(lstAggBy, ", as.factor(month)")
aggNames <- c(aggNames, "month")
}
lstAggBy <- paste0(lstAggBy, ")")
if (stringr::str_detect(nlType, "\\.D"))
{
ctryData$day <-
lubridate::day(as.Date(as.character(ctryData$variable)))
lstAggBy <- paste0(lstAggBy, ", as.factor(day)")
aggNames <- c(aggNames, "day")
}
#print(paste0("ctrydata nrow:", nrow(ctryData)))
if (normArea)
ctryData$value <- (ctryData$value) / ctryData$area_sq_km
if (length(countries) == 1)
{
#switched to data.table aggregation
#ctryData <- stats::setNames(aggregate(ctryData$value, by=list(ctryData[,admLevel], ctryData[,"variable"]), mean, na.rm=T), c(admLevel, "variable", "value"))
ctryData <- stats::setNames(ctryData[, list(mean(value, na.rm = TRUE)),
by = eval(parse(text = lstAggBy))],
c(admLevel, "variable", aggNames, "value"))
g <- ggplot2::ggplot(ctryData,
aes(
x = eval(parse(text = aggNames[length(aggNames)])),
y = value,
col = year,
group = year
)) +
ggplot2::geom_line(alpha = 0.3) + ggplot2::geom_point() +
ggplot2::geom_smooth(
aes(group = 1),
method = "loess",
weight = 1,
alpha = 0.2,
lty = 'twodash'
) #+ theme(axis.text.x=element_text(angle=90,hjust=1,vjust=0.5)) #+ labs(col=year)
}
else
{
#ctryData <- aggregate(value ~ country+variable, data=ctryData, mean)
#switched to data.table aggregation
ctryData <-
stats::setNames(ctryData[, mean(value, na.rm = TRUE), by = eval(parse(text =
lstAggBy))],
c(admLevel, "variable", aggNames, "value"))
#g <- ggplot2::ggplot(data=ctryData, aes(x=variable, y=value, col=country, group=year))
g <-
ggplot2::ggplot(
ctryData,
aes(
x = eval(parse(text = aggNames[length(aggNames)])),
y = value,
col = country,
shape = year,
group = interaction(country, year)
)
) +
ggplot2::geom_line(lwd = .5, alpha = 0.3) +
ggplot2::geom_point() +
ggplot2::geom_smooth(
aes(group = country),
method = "loess",
weight = 1,
alpha = 0.2,
lty = 'twodash'
)
}
if ("scale_y_log" %in% scale)
g <- g + ggplot2::scale_y_log10()
if ("scale_x_log" %in% scale)
g <- g + ggplot2::scale_x_log10()
if (normArea)
g <-
g + ggplot2::labs(title = "Radiance", x = "Time", y = "Rad (W.Sr^⁻¹.cm^⁻²/Km²)") #y=expression(paste("Avg Rad W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, "per Km" ^{2})))
else
g <-
g + ggplot2::labs(title = "Radiance", x = "Time", y = "Rad (W.Sr^⁻¹.cm^⁻²") #y=expression(~Total~Rad~W %.% Sr^{-1}%.%cm^{-2}))
#plotly::ggplotly(g)
g
})
})
######################## plotNightLights ###################################
output$plotNightLights <- plotly::renderPlotly({
print(paste0("output: renderPlot"))
#input$btnGo
values$updatePlot
shiny::isolate({
countries <- shiny::isolate(getInputCountries())
radioAdmLevel <- shiny::isolate(input$radioAdmLevel)
nlPeriodRange <- shiny::isolate(input$nlPeriodRange)
if (is.null(nlPeriodRange))
return()
#not isolated since they act on loaded data
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
ctryStat <- input$ctryStat
scale <- input$scale
graphType <- input$graphType
nlType <- shiny::isolate(input$nlType)
normArea <- input$norm_area
admLvlCtrlNames <- names(input)
x <- admLvlCtrlNames[grep("selectAdm\\d+$", admLvlCtrlNames)]
admLvlNums <- NULL
for (i in x)
if (length(input[[i]]) > 0)
admLvlNums <- c(admLvlNums, i)
#print(paste0("x", x))
#print(paste0("admlvlnums:", admLvlNums))
#if (admLvlNum=="" && length(countries)>0)
# return()
#not isolated to allow graph change by selecting admLevel radio input (radioAdmLevels)
ctryAdmLevels <- unlist(ctryAdmLevels())
admLvlNums <-
as.numeric(gsub(
pattern = "[^[:digit:]]",
replacement = "",
x = admLvlNums
))
if (length(admLvlNums) != 0)
{
admLevel <- ctryAdmLevels[as.numeric(data.table::last(admLvlNums))]
} else {
admLevel <- radioAdmLevel
}
#print(paste0("admLevel:", admLevel))
if (!exists("admLevel") ||
is.null(admLevel) || length(admLevel) == 0 ||
length(countries) > 1)
admLevel <- "country"
xLabel <- if (stringr::str_detect(nlType, "\\.D"))
"Day"
else if (stringr::str_detect(nlType, "\\.M"))
"Month"
else if (stringr::str_detect(nlType, "\\.Y"))
"Year"
ctryData <- ctryNlDataMelted()
if (is.null(ctryData))
{
if (is.null(nlType))
nlType <- "VIIRS.M"
g <- ggplot2::ggplot(data = data.frame()) +
geom_point()
if (grepl("\\.D", nlType))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m-%d")
else if (grepl("\\.M", nlType))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m")
else if (grepl("\\.Y", nlType))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 year", date_labels = "%Y")
# if(!exists("nlPeriodRange") || is.null(nlPeriodRange))
# {
# nlPeriodRange <- Rnightlights::getAllNlPeriods(nlTypes = nlType)
# nlPeriodRange <- c(nlPeriodRange[1], nlPeriodRange[length(nlPeriodRange)])
# nlPeriodRange <- Rnightlights::nlPeriodToDate(nlPeriod = nlPeriodRange, nlType = nlType)
# }
g <-
g + ggplot2::xlim(nlPeriodRange[1], nlPeriodRange[2]) +
ggplot2::ylim(0, 100) +
ggplot2::labs(title = "Nightlight Radiance",
x = xLabel,
y = "Radiance (W.Sr^⁻¹.cm^⁻²)"
) #bquote(paste("Radiance (W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, ")")))
return(plotly::ggplotly(g))
}
ctryData <-
subset(ctryData,
variable >= nlPeriodRange[1] & variable <= nlPeriodRange[2])
#filter by subsequent levels till lowest level
for (lvl in admLvlNums)
{
if (lvl == 1)
next()
#print(paste0("lvl:",lvl))
if (length(input[[grep(lvl, x, value = T)]]) > 0)
{
ctryData <-
subset(ctryData, ctryData[[ctryAdmLevels[lvl]]] %in% input[[grep(lvl, x, value =
T)]])
}
}
#if all selectAdmLevels are empty use radioAdmLevel
# if (length(admLvlNums) == 0)
# {
# ctryData <- subset(ctryData, ctryData[[ctryAdmLevels[lvl]]] == radioAdmLevel)
# }
#print(paste0("ctrydata nrow:", nrow(ctryData)))
if (normArea)
ctryData$value <- ctryData$value / ctryData$area_sq_km
if (graphType == "boxplot")
{
if (length(countries) == 1)
{
g <-
ggplot2::ggplot(data = ctryData,
ggplot2::aes(
x = ctryData[[admLevel]],
y = value,
col = ctryData[[admLevel]]
)) +
ggplot2::theme(axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
)) + ggplot2::labs(col = admLevel) + facet_grid(
lubridate::year(variable) ~ lubridate::month(
x = variable,
label = T,
abbr = T
)
)
}
else
{
g <-
ggplot2::ggplot(data = ctryData,
ggplot2::aes(
x = country,
y = value,
col = country
)) + ggplot2::theme(
axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
),
panel.spacing.x = unit(0.1, "lines")
) + ggplot2::labs(col = admLevel) + facet_grid(
lubridate::year(variable) ~ lubridate::month(
x = variable,
label = T,
abbr = T
)
)
}
#ggplot2::ggplot(data = ctryData, ggplot2::aes(x = factor(variable), y = value, col = country)) + ggplot2::theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5)) + ggplot2::labs(col = admLevel) + geom_boxplot() + facet_grid(country ~ .)
g <- g + ggplot2::geom_boxplot()# +facet_grid(.~variable)
}
else if (graphType == "line")
{
if (length(countries) == 1)
{
#switched to data.table aggregation
#ctryData <- stats::setNames(aggregate(ctryData$value, by=list(ctryData[,admLevel], ctryData[,"variable"]), mean, na.rm=T), c(admLevel, "variable", "value"))
ctryData <-
stats::setNames(ctryData[, value, by = list(ctryData[[admLevel]], variable)], c(admLevel, "variable", "value"))
g <-
ggplot2::ggplot(data = ctryData, aes(
x = variable,
y = value,
col = ctryData[[admLevel]]
))
if (stringr::str_detect(nlType, "\\.D"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 day", date_labels = "%Y-%m-%d")
else if (stringr::str_detect(nlType, "\\.M"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m")
else if (stringr::str_detect(nlType, "\\.Y"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 year", date_labels = "%Y")
}
else
{
#ctryData <- aggregate(value ~ country+variable, data=ctryData, mean)
#switched to data.table aggregation
ctryData <-
stats::setNames(ctryData[, value, by = list(country, variable)], c("country", "variable", "value"))
g <-
ggplot2::ggplot(data = ctryData, aes(
x = variable,
y = value,
col = country
))
if (stringr::str_detect(nlType, "VIIRS"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m")
}
g <- g + ggplot2::geom_line() + ggplot2::geom_point() +
ggplot2::theme(axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
)) +
ggplot2::labs(col = admLevel)
}
else if (graphType == "histogram")
{
#ctryData <- aggregate(value ~ country+variable, data=ctryData, mean)
g <- ggplot2::ggplot(data = ctryData, aes(x = value))
g <- g + ggplot2::geom_histogram(
aes(y = ..density..),
bins = 30,
colour = "black",
fill = "white"
) +
# Overlay with transparent density plot
ggplot2::geom_density(alpha = .2, fill = "#FF6666") +
ggplot2::facet_grid(ctryData[[admLevel]] ~ lubridate::year(variable))
}
else
return(NULL)
if ("scale_y_log" %in% scale)
g <- g + ggplot2::scale_y_log10()
if ("scale_x_log" %in% scale)
g <- g + ggplot2::scale_x_log10()
plotTitle <-
paste0(
"Nightlight Radiance (",
Rnightlights:::nlSignatureStatName(statSig = ctryStat),
ifelse(grepl(pattern = "na.rm", x = ctryStat), "*", ""),
")"
)
if (normArea)
g <- g + ggplot2::labs(
title = plotTitle,
x = xLabel,
y = "Avg Rad (W.Sr^⁻¹.cm^⁻²/Km²)",
#bquote(paste("Avg Rad W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, " / Km" ^{2}))
caption = ifelse(
grepl(pattern = "na.rm", x = ctryStat),
paste0(ctryStat, " NAs removed"),
paste0(ctryStat, " NAs not removed")
)
) #y=expression(paste("Avg Rad W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, "per Km" ^{2})))
else
g <- g + ggplot2::labs(title = plotTitle,
x = xLabel,
y = "Total Rad (W.Sr^⁻¹.cm^⁻²)") #bquote(~Total~Rad~W %.% Sr^{-1}%.%cm^{-2})) #y=expression(~Total~Rad~W %.% Sr^{-1}%.%cm^{-2}))
#g
p <- plotly::ggplotly(g)
p$elementId <- NULL
p
})
})
######################## renderDataTable dataset ###################################
output$dataset <- DT::renderDataTable({
if (is.null(ctryNlData()))
return()
ctryStat <- shiny::isolate(input$ctryStat)
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
startDate <-
Rnightlights::dateToNlPeriod(input$nlPeriodRange[1], input$nlType)
endDate <-
Rnightlights::dateToNlPeriod(input$nlPeriodRange[2], input$nlType)
ctryData <- ctryNlData()
allCols <- names(ctryData)
admCols <- grep("NL_", allCols, invert = TRUE, value = TRUE)
#the cols with the stats we want
dataCols <-
grep(
pattern = ctryStat,
x = allCols,
value = TRUE,
fixed = T
)
dataCols <-
grep(pattern = configName,
x = dataCols,
value = TRUE)
dataCols <-
grep(pattern = paste0("GF", substr(removeGasFlares, 1, 1)),
x = dataCols,
value = TRUE)
dataCols <-
grep(
pattern = paste0("MTS", multiTileMergeStrategy),
x = dataCols,
value = TRUE
)
dataCols <-
grep(pattern = multiTileMergeFun,
x = dataCols,
value = TRUE)
dataColDates <- gsub(".*_(\\d{4,8})_.*", "\\1", dataCols)
dataCols <-
dataCols[dataColDates >= startDate & dataColDates <= endDate]
ctryData <- ctryData[, c(admCols, dataCols), with = F]
},
options = list(scrollX = TRUE, scrolly = TRUE))
######################## renderDataTable dataset ###################################
output$availableData <- DT::renderDataTable({
dt <- ctryNlDataList()
if (is.null(dt))
return()
names(dt) <-
c(
"DT",
"CCode",
"ADM",
"NlType",
"CfgName",
"MTS",
"MTF",
"RGF",
"NlPeriod",
"PolySrc",
"PolyVer",
"PolyType",
"NlStats"
)
dt
},
options = list(
scrollX = TRUE,
scrollY = FALSE,
autoWidth = TRUE,
columnDefs = list(list(width = "100px"))
))
######################## observe map ###################################
observe({
print(paste0("observe: map"))
#input$btnGo
values$updateMap
shiny::isolate({
countries <- getInputCountries()
if (is.null(countries) ||
is.null(input$nlPeriod) || is.null(input$nlType))
return()
nlPeriod <- input$nlPeriod
scale <- input$scale
nlType <- shiny::isolate(input$nlType)
normArea <- input$norm_area
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
custPolyPath <- if (polySrc == "CUST") polyVer else NULL
ctryStat <- shiny::isolate(input$ctryStat)
if (is.null(polySrc) ||
is.null(polyVer) || polySrc == "" || polyVer == "")
return()
admLevel <- shiny::isolate(input$radioAdmLevel)
if (is.null(admLevel))
admLevel <- "country"
shiny::isolate({
# if (is.null(countries) || is.null(nlPeriod) || is.null(admLevel))
# return()
mapExtent <- NULL
selected <- NULL
map <- leaflet::leafletProxy("map") %>%
leaflet::clearShapes() %>%
leaflet::clearControls()
if (length(countries) > 1) {
admLevel <- "country"
ctryPoly0 <-
Rnightlights::readCtryPolyAdmLayer(
ctryCode = countries[1],
admLevel = unlist(
Rnightlights::getCtryShpLyrNames(ctryCodes = countries[1],
lyrNums = 0)
)
)
for (country in countries[2:length(countries)])
{
ctryPoly0 <- sp::rbind.SpatialPolygonsDataFrame(
ctryPoly0,
Rnightlights::readCtryPolyAdmLayer(
ctryCode = country,
admLevel = unlist(Rnightlights::getCtryShpLyrNames(country, 0))
),
makeUniqueIDs = T
)
}
ctryPoly0 <- sp::spTransform(ctryPoly0, wgs84)
mapExtent <- raster::extent(ctryPoly0)
ctryData <- ctryNlDataMelted()
if (is.null(ctryData))
return()
#data already in data.table form
lvlCtryData <-
stats::setNames(ctryData[, list(mean(value, na.rm = T),
sum(area_sq_km, na.rm =T)),
by = list(ctryData[["country"]], ctryData[["variable"]])],
c("country", "variable", "value", "area_sq_km"))
#rank the data
varname <- paste0('rankcountry')
lvlCtryData[[varname]] <-
with(lvlCtryData, rank(-value, ties.method = 'first'))
#palette deciles for the layer
bins <-
rev(stats::quantile(lvlCtryData$value, seq(0, 1, 0.1), na.rm = T))
brewerPal <-
rev(RColorBrewer::brewer.pal(n = 10, name = "YlOrRd"))
pal <-
leaflet::colorBin(
palette = brewerPal,
domain = lvlCtryData$value,
na.color = "grey",
bins = bins
)
mapLabels <- sprintf(
paste0(
"<strong>%s:%s</strong>",
"<br/>Area: %s km<superscript>2</superscript>",
"<br/>Date: %s",
ifelse(
normArea,
paste0("<br/>Rad (", ctryStat, "): %s /sq.km"),
paste0("<br/>Rad (", ctryStat, "): %s")
),
"<br/>Rank: %s/%s"
),
"country",
lvlCtryData[["country"]],
format(lvlCtryData[["area_sq_km"]], scientific = F, digits = 2),
lvlCtryData[["variable"]],
format(lvlCtryData[["value"]], scientific = F, digits = 2),
lvlCtryData[[paste0("rankcountry")]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
map <- map %>% leaflet::addPolygons(
data = ctryPoly0,
#layerId = "country",
fill = TRUE,
fillColor = ~ pal(lvlCtryData[["value"]]),
fillOpacity = 0.9,
stroke = TRUE,
weight = 1,
#color=lineCol[iterAdmLevel],
color = "white",
smoothFactor = 0.7,
opacity = 1,
#dashArray = "5",
group = "country",
popup = mapLabels,
popupOptions = leaflet::popupOptions(
keepInView = T,
closeOnClick = T,
closeButton = T
),
highlightOptions = leaflet::highlightOptions(
weight = 5,
#color = "yellow",
#dashArray = "4",
fillOpacity = 0,
bringToFront = FALSE
)
)
} else {
#if 1 country
for (country in countries)
{
admLvlCtrlNames <- names(input)
x <-
admLvlCtrlNames[grep("selectAdm\\d+$", admLvlCtrlNames)]
admLvlNums <- NULL
for (i in x)
if (length(input[[i]]) > 0)
admLvlNums <- c(admLvlNums, i)
#print(paste0("x", x))
#print(paste0("admlvlnums:", admLvlNums))
admLvlNums <-
as.numeric(gsub("[^[:digit:]]", "", admLvlNums))
#print(paste0("admlvlNums:", admLvlNums))
#get the selected admLevel and convert to lyrnum
ctryAdmLevels <-
Rnightlights:::getCtryStructAdmLevelNames(
ctryCode = country,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = NULL
)
#ctryAdmLevels <- unlist(ctryAdmLevels[which(countries == country)])
if (!is.null(admLevel) || admLevel == "country")
lyrNum <- which(ctryAdmLevels == admLevel)
else
lyrNum <- 0
#line weight increases. max=4 min=1
deltaLineWt <- (4 - 1) / as.numeric(lyrNum)
#line color darkens
if (stringr::str_detect(nlType, "OLS"))
nlYm <- nlPeriod
else if (stringr::str_detect(nlType, "VIIRS"))
nlYm <- as.Date(nlPeriod, "%Y%m%d")
ctryData <- ctryNlDataMelted()
if (is.null(ctryData))
return()
#get our data ready to match with polygons
#subset data based on level selections
if (stringr::str_detect(nlType, "OLS"))
ctryData <- subset(x = ctryData, variable == nlYm)
else if (stringr::str_detect(string = nlType, pattern = "VIIRS"))
ctryData <-
subset(x = ctryData,
subset = lubridate::year(variable) == lubridate::year(nlYm) &
lubridate::month(variable) == lubridate::month(nlYm)
)
if (normArea)
ctryData$value <- ctryData$value / ctryData$area_sq_km
ctryPoly0 <-
Rnightlights::readCtryPolyAdmLayer(
ctryCode = country,
admLevel = unlist(Rnightlights::getCtryShpLyrNames(country, 0))
)
ctryPoly0 <- sp::spTransform(ctryPoly0, wgs84)
e <- raster::extent(ctryPoly0)
if (exists("mapExtent") && !is.null(mapExtent))
{
mapExtent@xmin <- min(mapExtent@xmin, e@xmin)
mapExtent@ymin <- min(mapExtent@ymin, e@ymin)
mapExtent@xmax <- max(mapExtent@xmax, e@xmax)
mapExtent@ymax <- max(mapExtent@ymax, e@ymax)
}
else
{
mapExtent <- e
}
if (stringr::str_detect(nlType, "OLS"))
nlPeriod <- substr(gsub("-", "", nlYm), 1, 4)
else if (stringr::str_detect(nlType, "VIIRS"))
nlPeriod <- substr(gsub("-", "", nlYm), 1, 6)
map <- map %>%
leaflet::clearShapes() %>%
leaflet::clearControls() %>%
leaflet::addPolygons(
layerId = country,
fill = FALSE,
fillColor = "#fefe40",
stroke = TRUE,
weight = 4,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = "country",
data = ctryPoly0
)
selected <- NULL
lineCol <- rev(hexbin::BTC(lyrNum + 1, 200, 250))
if (lyrNum > 1)
#skip drawing the country level. avoid reverse seq (2:1)
for (iterAdmLevel in 2:lyrNum)
{
#aggregate the data to the current level
iterAdmLevelName <- ctryAdmLevels[iterAdmLevel]
#data already in data.table form
lvlCtryData <-
stats::setNames(ctryData[, list(mean(value, na.rm = T),
sum(area_sq_km, na.rm =T)),
by = list(ctryData[[iterAdmLevelName]],
ctryData[["variable"]])],
c(iterAdmLevelName, "variable", "value", "area_sq_km"))
#rank the data
varname <- paste0('rank', iterAdmLevel)
lvlCtryData[[varname]] <-
with(lvlCtryData, rank(-value, ties.method = 'first'))
#palette deciles for the layer
bins <-
rev(stats::quantile(lvlCtryData$value, seq(0, 1, 0.1), na.rm = T))
brewerPal <-
rev(RColorBrewer::brewer.pal(n = 10, name = "YlOrRd"))
pal <-
leaflet::colorBin(
palette = brewerPal,
domain = lvlCtryData$value,
na.color = "grey",
bins = bins
)
#turn off previous layer? No point keeping it if it is hidden. Also we want to turn the current layer to transparent so that one can see through to the raster layer on hover
ctryPoly <-
Rnightlights::readCtryPolyAdmLayer(country,
unlist(
Rnightlights::getCtryShpLyrNames(country, iterAdmLevel - 1)
))
ctryPoly <- sp::spTransform(ctryPoly, wgs84)
e <- raster::extent(ctryPoly)
if (exists("mapExtent") && !is.null(mapExtent))
{
mapExtent@xmin <- min(mapExtent@xmin, e@xmin)
mapExtent@ymin <- min(mapExtent@ymin, e@ymin)
mapExtent@xmax <- max(mapExtent@xmax, e@xmax)
mapExtent@ymax <- max(mapExtent@ymax, e@ymax)
}
else
{
mapExtent <- e
}
if (length(admLvlNums) > 0)
if ((iterAdmLevel) == data.table::last(admLvlNums))
#iterAdmLevel+1 %in% admLvlNums)
selected <-
which(ctryPoly@data[[paste0("NAME_", iterAdmLevel - 1)]] %in% input[[paste0("selectAdm", iterAdmLevel)]])
else
selected <- c()
mapLabels <- sprintf(
paste0(
"<strong>%s:%s</strong>",
"<br/>Area: %s km<superscript>2</superscript>",
"<br/>Date: %s",
ifelse(
normArea,
paste0("<br/>Rad (", ctryStat, "): %s /sq.km"),
paste0("<br/>Rad (", ctryStat, "): %s")
),
"<br/>Rank: %s/%s"
),
ctryAdmLevels[iterAdmLevel],
lvlCtryData[[ctryAdmLevels[iterAdmLevel]]],
format(
lvlCtryData[["area_sq_km"]],
scientific = F,
digits = 2
),
lvlCtryData[["variable"]],
format(
lvlCtryData[["value"]],
scientific = F,
digits = 2
),
lvlCtryData[[paste0("rank", iterAdmLevel)]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
#only the lowest layer will have fill, label, etc
if (iterAdmLevel == lyrNum)
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly,
layerId = as.character(ctryPoly@data[, paste0('NAME_', iterAdmLevel -
1)]),
fill = TRUE,
fillColor = ~ pal(lvlCtryData[["value"]]),
fillOpacity = 0.9,
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt,
#color=lineCol[iterAdmLevel],
color = "white",
smoothFactor = 0.7,
opacity = 1,
#dashArray = "5",
group = ctryAdmLevels[iterAdmLevel],
popup = mapLabels,
popupOptions = leaflet::popupOptions(
keepInView = T,
closeOnClick = T,
closeButton = T
),
highlightOptions = leaflet::highlightOptions(
weight = 5,
#color = "yellow",
#dashArray = "4",
fillOpacity = 0,
bringToFront = FALSE
)
)
} else
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly,
layerId = as.character(ctryPoly@data[, paste0('NAME_', iterAdmLevel -
1)]),
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt,
smoothFactor = 0.7,
opacity = 1,
#color=lineCol[iterAdmLevel],
color = "white",
#dashArray = "5",
group = ctryAdmLevels[iterAdmLevel]
)
}
if (length(selected) > 0)
mapExtent <- NULL
for (iterPoly in selected)
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly[iterPoly, ],
layerId = paste0(as.character(ctryPoly@data[iterPoly, paste0('NAME_', iterAdmLevel -
1)]), "_selected"),
fill = FALSE,
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt + 0.5,
opacity = 1,
color = "blue",
# dashArray = "5",
group = "selected",
highlightOptions = leaflet::highlightOptions(
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt + 0.5,
opacity = 1,
color = "blue",
bringToFront = TRUE
)
)
e <- raster::extent(ctryPoly[iterPoly, ])
if (exists("mapExtent") && !is.null(mapExtent))
{
mapExtent@xmin <- min(mapExtent@xmin, e@xmin)
mapExtent@ymin <- min(mapExtent@ymin, e@ymin)
mapExtent@xmax <- max(mapExtent@xmax, e@xmax)
mapExtent@ymax <- max(mapExtent@ymax, e@ymax)
}
else
{
mapExtent <- e
}
}
}
}
if (length(selected) > 0)
{
map <-
map %>% leaflet::addLayersControl(overlayGroups = c("ctryRaster",
ctryAdmLevels[2:lyrNum],
"selected"))
map <-
leaflet::flyToBounds(
map = map,
lng1 = mapExtent@xmin,
lat1 = mapExtent@ymin,
lng2 = mapExtent@xmax,
lat2 = mapExtent@ymax
)
}
else
map <-
map %>% leaflet::addLayersControl(overlayGroups = c("ctryRaster",
ctryAdmLevels[2:lyrNum]))
if (admLevel != "country")
map <- map %>%
leaflet::addLegend(
position = "bottomright",
pal = pal,
values = format(ctryData$value, scientific = T),
labels = stats::quantile(ctryData$value, seq(1, 0, -0.1), na.rm =
T),
#title = "Nightlight percentiles",
title = ifelse(normArea, "Rad/sq. Km.", "Rad"),
opacity = 1
)
}
#Zoom
if (exists("mapExtent"))
map <- map %>%
leaflet::flyToBounds(mapExtent@xmin,
mapExtent@ymin,
mapExtent@xmax,
mapExtent@ymax)
map
})
})
})
######################## map ###################################
output$map <- leaflet::renderLeaflet({
print(paste0("output: map"))
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
#input$btnGo
#values$updateMap
shiny::isolate({
#if (is.null(input$nlType) || is.null(input$nlPeriod))
# return()
map <- leaflet::leaflet() %>%
leaflet::addTiles("http://a.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png") %>%
leaflet::addWMSTiles(
layerId = "nlRaster",
baseUrl = paste0(
"http://localhost/cgi-bin/mapserv?map=",
file.path(path.expand(
Rnightlights::getNlDir("dirRasterOutput")
),
"nightlights.map")
),
layers = "NL_CTRYCODE_VIIRS.M_NLPERIOD_VCMCFG-MTSALL-MEAN-RGFT_GADM-3.6-SHPZIP",
group = "ctryRaster",
options = leaflet::WMSTileOptions(
format = "image/png",
transparent = TRUE,
opacity = 0.8,
TIME = Rnightlights::dateToNlPeriod(input$nlPeriod, input$nlType)
)
)
return(map)
})
})
})
chrisvwn/Rnightlights documentation built on Sept. 7, 2021, 1:44 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
missingPkgs <- NULL
#wgs84 <- "+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"
wgs84 <- Rnightlights:::getCRS()
if (!requireNamespace("Rnightlights", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "Rnightlights")
}
if (!requireNamespace("shiny", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "shiny")
}
if (!requireNamespace("shinyjs", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "shinyjs")
}
if (!requireNamespace("dendextend", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "dendextend")
}
if (!requireNamespace("ggdendro", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "ggdendro")
}
if (!requireNamespace("leaflet", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "rstudio/leaflet")
}
if (!requireNamespace("plotly", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "plotly")
}
if (!requireNamespace("RColorBrewer", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "RColorBrewer")
}
if (!requireNamespace("reshape2", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "reshape2")
}
if (!requireNamespace("rgdal", quietly = TRUE))
{
missingPkgs <- c(missingPkgs, "rgdal")
}
if (!is.null(missingPkgs))
stop(
Sys.time(),
": Missing packages needed for this function to work.
Please install missing packages: '",
paste0(missingPkgs, collapse = ", "),
"'",
call. = FALSE
)
#stats to be
defaultStats <- c("mean()", "sum()", "var()", "sd()")
#options(shiny.trace=T)
options(shiny.reactlog = TRUE)
shiny::shinyServer(function(input, output, session) {
#Since renderUI does not like selectAdmLevel returning NULL we init with an
# empty renderUI, set suspendWhenHidden = FALSE to force it to recheck
# selectAdmLevel even if null
output$selectAdmLevel <- shiny::renderUI({
})
shiny::outputOptions(output, "selectAdmLevel", suspendWhenHidden = FALSE)
#shinyjs::useShinyjs()
################## reactive ctryCodesWithData #######################
ctryCodesWithData <- shiny::reactive({
Rnightlights:::getCtryCodesWithData()
})
######################## update countries ###################################
observe({
print(paste0("observe: countries"))
#c("Ashm", "CYN", "Gaza", "IDN", "IOA", "KAS", "KOS"))
allCtryCodes <- Rnightlights::getAllNlCtryCodes()
allCtryNames <- Rnightlights::ctryCodeToName(allCtryCodes)
allCtryCodes <- setNames(allCtryCodes, allCtryNames)
ctryCodesWithData <- ctryCodesWithData()
diffCtryCodes <-
allCtryCodes[!(allCtryCodes %in% ctryCodesWithData)]
ctryCodes <- if(is.null(ctryCodesWithData))
list("Without Data" = as.list(diffCtryCodes))
else
list("Have Data" = as.list(ctryCodesWithData), "Without Data" = as.list(diffCtryCodes))
shiny::updateSelectizeInput(
session = session,
inputId = "countries",
label = "Select Country(ies)",
choices = ctryCodes,
server = TRUE
)
})
######################## actionButton btnGo ###########################
output$btnGo <- shiny::renderUI({
print("output: btnGo")
if (values$needsDataUpdate || values$needsDataProcessing)
{
if (values$needsDataUpdate)
btn <-
shiny::actionButton(inputId = "btnGo", label = "LOAD",
style = "background-color:orange")
#give precedence to process. if both set let process override load
if (values$needsDataProcessing)
btn <-
shiny::actionButton(inputId = "btnGo", label = "PROCESS",
style = "background-color:orange")
} else
{
btn <-
shiny::actionButton(inputId = "btnGo", label = "LOAD",
style = "background-color:lightblue")
}
btn
})
######################## observe btnGo ###########################
# observe({
# print("update: btnGo")
#
# if (values$needsDataUpdate || values$needsDataProcessing)
# {
# if (values$needsDataUpdate)
# shiny::updateActionButton(session = session, inputId = "btnGo", label = "LOAD",
# icon = shiny::icon("play"))
#
# #give precedence to process. if both set let process override load
# if (values$needsDataProcessing)
# btn <-
# shiny::updateActionButton(session = session, inputId = "btnGo", label = "PROCESS",
# icon = shiny::icon("play"))
# } else
# btn <-
# shiny::updateActionButton(session = session, inputId = "btnGo", label = "LOAD",
# icon = character(0))
# })
######################## reactive getInputCountries ###########################
getInputCountries <- reactive({
print("reactive: getInputCountries")
countries <- input$countries
if (length(countries) == 0)
return(NULL)
countries[countries == "---" | countries == " "] <- ""
countries
})
######################## reactive ctryAdmLevels ######################
ctryAdmLevels <- shiny::reactive({
print(paste0("reactive:ctryAdmLevels"))
countries <- getInputCountries()
if (length(countries) == 0 || length(countries) > 1)
return()
admLevelNames <-
Rnightlights:::getCtryStructAdmLevelNames(ctryCode = countries)
admLevelNames
})
######################## reactive ctryAdmLevelNames #########################
ctryAdmLevelNames <- shiny::reactive({
print(paste0("reactive:ctryAdmLevelNames"))
countries <- getInputCountries()
if (length(countries) != 1)
return()
Rnightlights:::readCtryStruct(ctryCode = countries)
})
######################## reactive ctryNlTypes ###############################
ctryNlTypes <- shiny::reactive({
print(paste0("reactive: ctryNlTypes"))
countries <- getInputCountries()
if (length(countries) == 0)
return()
admLevel <- selectedAdmLevel3()
if (is.null(admLevel))
return()
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
getCtryNlTypes(countries = countries, admLevel = admLevel, polySrc = polySrc, polyVer = polyVer, polyType = polyType)
})
######################## reactive ctryNlDataLvl2 ############################
ctryNlDataLvl2 <- shiny::reactive({
print(paste0("reactive: ctryNlDataLvl2"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
nlType <- shiny::isolate(input$nlType)
#strict <- shiny::isolate(input$strict)
if (is.null(polySrc) ||
polySrc == "" ||
is.null(polyVer) ||
polyVer == "" || is.null(polyType) || polyType == "")
return(NULL)
if (is.null(nlType))
return(NULL)
ctryData <- NULL
custPolyPath <- if (polySrc == "CUST")
polyVer
else
NULL
getCtrysDataDirect(countries = countries, polySrc = polySrc, polyVer = polyVer, polyType = polyType, nlType = nlType)
})
######################## reactive ctryNlData ################################
ctryNlData <- shiny::reactive({
print(paste0("reactive: ctryNlData"))
input$btnGo
countries <- shiny::isolate(input$countries)
if (is.null(countries) ||
length(countries) == 0 || countries == "")
return()
nlType <- shiny::isolate(input$nlType)
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
#strict <- shiny::isolate(input$strict)
if (input$tabs == "Map" &&
is.null(nlPeriod <- shiny::isolate(input$nlPeriod)))
nlPeriod <- shiny::isolate(input$nlPeriodRange)
if (input$tabs != "Map" &&
is.null(nlPeriod <- shiny::isolate(input$nlPeriodRange)))
nlPeriod <- shiny::isolate(input$nlPeriod)
if (is.null(nlPeriod))
return()
nlPeriod <-
Rnightlights::dateToNlPeriod(dt = nlPeriod, nlType = nlType)
if (length(nlPeriod) == 2)
nlPeriod <-
Rnightlights::nlRange(
startNlPeriod = nlPeriod[1],
endNlPeriod = nlPeriod[2],
nlType = nlType
)
nlStats <- shiny::isolate(input$ctryStat)
if (!is.null(nlStats))
{
if (nlStats == "Add New")
{
nlStats <- values$newStatFuncName
}
nlStats <-
Rnightlights:::nlSignatureAddArg(nlStatSigs = nlStats,
addArg = "na.rm=T")
nlStats <-
Rnightlights:::nlSignatureStat(nlStatSignature = nlStats)
} else
{
return()
}
configName <- shiny::isolate(input$configName)
multiTileStrategy <-
shiny::isolate(input$multiTileMergeStrategy)
multiTileMergeFun <- shiny::isolate(input$multiTileMergeFun)
removeGasFlares <- shiny::isolate(input$removeGasFlares)
if (is.null(polySrc) ||
polySrc == "" ||
is.null(polyVer) ||
polyVer == "" || is.null(polyType) || polyType == "")
return(NULL)
if (is.null(nlType))
return(NULL)
ctryData <- NULL
custPolyPath <- if (polySrc == "CUST")
polyVer
else
NULL
cropMaskMethod <- shiny::isolate(input$cropMaskMethod)
extractMethod <- shiny::isolate(input$extractMethod)
# shiny::showModal(ui = modalDialog(title = "PROCESSING",
# "Retrieving data. Please wait ...",
# size = "s"),
# session = session)
dt <- if (length(countries) == 1)
{
if (is.null(admLevel <- shiny::isolate(input$radioAdmLevel)))
return()
lyrNum <-
which(unlist(ctryAdmLevels()) == shiny::isolate(admLevel)) - 1
admLevel <-
unlist(
Rnightlights:::getCtryShpLyrNames(
ctryCodes = countries,
lyrNums = lyrNum,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath
)
)
data.table::data.table(
Rnightlights::getCtryNlData(
ctryCode = countries,
admLevel = admLevel,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath,
nlTypes = nlType,
nlPeriods = nlPeriod,
nlStats = nlStats,
extractMethod = "gdal",
configNames = configName,
multiTileStrategy = multiTileStrategy,
multiTileMergeFun = multiTileMergeFun,
removeGasFlares = removeGasFlares
)
)
} else if (length(countries) > 1) #remove subcountry admin levels
{
for (ctryCode in countries)
{
admLevel <- paste0(ctryCode, "_adm0")
#print(ctryCode)
temp <- Rnightlights:::getCtryNlData(
ctryCode = ctryCode,
admLevel = admLevel,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath,
nlTypes = nlType,
nlPeriods = nlPeriod,
nlStats = nlStats,
cropMaskMethod = cropMaskMethod,
extractMethod = extractMethod,
configNames = configName,
multiTileStrategy = multiTileStrategy,
multiTileMergeFun = multiTileMergeFun,
removeGasFlares = removeGasFlares
)
temp <- data.table::as.data.table(temp)
ctryCols <-
grep(paste0("country|area|NL_", nlType), names(temp))
temp <- temp[, ctryCols, with = F]
if (is.null(ctryData))
{
ctryData <- temp
} else
{
ctryData <- merge(ctryData, temp, all = TRUE)
}
}
ctryData
}
#removeModal()
dt
})
######################## reactive ctryNlDataMelted ##########################
ctryNlDataMelted <- shiny::reactive({
print(paste0("reactive: ctryNlDataMelted"))
input$btnGo
ctryData <- ctryNlData()
if (is.null(ctryData))
return()
ctryStat <- input$ctryStat
if (is.null(ctryStat))
return()
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
if (is.null(configName) ||
is.null(multiTileMergeStrategy) ||
is.null(multiTileMergeFun) || is.null(removeGasFlares))
return()
shiny::isolate({
#the nightlight cols
nlCols <- names(ctryData)[grep("NL_", names(ctryData))]
#the cols with the stats we want
statCols <-
grep(
pattern = gsub("(", "\\(", paste0("NL_.*_", ctryStat), fixed = T),
x = names(ctryData),
value = TRUE
)
statCols <-
grep(pattern = configName,
x = statCols,
value = TRUE)
statCols <-
grep(pattern = paste0("GF", substr(removeGasFlares, 1, 1)),
x = statCols,
value = TRUE)
statCols <-
grep(
pattern = paste0("MTS", multiTileMergeStrategy),
x = statCols,
value = TRUE
)
statCols <-
grep(pattern = multiTileMergeFun,
x = statCols,
value = TRUE)
#the non nightlight cols
ctryDataCols <- setdiff(names(ctryData), nlCols)
#the cols to melt by
meltMeasureVars <- statCols
nlType <- shiny::isolate(input$nlType)
#combine the non-nightlight cols and the cols with the stats we want
#ctryData <- subset(ctryData, select=c(ctryDataCols, meltMeasureVars))
#remove non-digits to get only stat cols
#meltVarNames <- gsub("[^[:digit:]]", "", meltMeasureVars)
ctryData <-
data.table::data.table(
reshape2::melt(ctryData, measure.vars = meltMeasureVars)
)
ctryData$variable <-
Rnightlights::nlPeriodToDate(gsub(pattern = "[^[:digit:]]",
replacement = "",
x = ctryData$variable),
nlType)
return(ctryData)
})
})
######################## reactive ctryNlDataMeltedLvl2 ######################
ctryNlDataMeltedLvl2 <- shiny::reactive({
print(paste0("reactive: ctryNlDataMeltedLvl2"))
countries <- input$countries
if (is.null(countries) || length(countries) == 0)
return()
admLevel <- input$radioAdmLevel
if (is.null(admLevel))
return()
ctryData <- ctryNlDataLvl2()
if (is.null(ctryData))
return()
ctryStat <- input$ctryStat
if (is.null(ctryStat))
return()
shiny::isolate({
#the nightlight cols
nlCols <- names(ctryData)[grep("NL_", names(ctryData))]
#the cols with the stats we want
statCols <-
names(ctryData)[grep(paste0("NL_.*", ctryStat), names(ctryData))]
#the non nightlight cols
ctryDataCols <- setdiff(names(ctryData), nlCols)
#the cols to melt by
meltMeasureVars <- statCols
#combine the non-nightlight cols and the cols with the stats we want
ctryData <-
subset(ctryData, select = c(ctryDataCols, meltMeasureVars))
#remove non-digits to get only stat cols
meltVarNames <- gsub("[^[:digit:]]", "", meltMeasureVars)
ctryData <-
data.table::data.table(
reshape2::melt(ctryData, measure.vars = meltMeasureVars)
)
if (stringr::str_detect(input$nlType, "OLS"))
{
ctryData$variable <-
paste0(gsub("[^[:digit:]]", "", ctryData$variable))
ctryData$variable <- as.numeric(ctryData$variable)
}
else if (stringr::str_detect(input$nlType, "VIIRS"))
{
if (stringr::str_detect(input$nlType, "M"))
ctryData$variable <-
paste0(gsub("[^[:digit:]]", "", ctryData$variable), "01")
else if (stringr::str_detect(input$nlType, "Y"))
ctryData$variable <-
paste0(gsub("[^[:digit:]]", "", ctryData$variable), "0101")
ctryData$variable <-
as.Date(ctryData$variable, format = "%Y%m%d")
}
return(ctryData)
})
})
######################## renderUI polySrc ###################################
observe({
print(paste0("output: polySrc"))
countries <- getInputCountries()
allPolySrcs <- c("GADM", "CUST")
existingPolySrcs <- unique(ctryNlDataList())
if (!is.null(countries))
existingPolySrcs <-
existingPolySrcs[existingPolySrcs$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingPolySrcs <-
existingPolySrcs[existingPolySrcs$admLevel == admLevel, "polySrc"]
else
existingPolySrcs <- unique(existingPolySrcs[, "polySrc"])
polySrcs <- allPolySrcs[!(allPolySrcs %in% existingPolySrcs)]
if (length(existingPolySrcs) == 1)
existingPolySrcs <- list(existingPolySrcs)
if (length(polySrcs) == 1)
polySrcs <- list(polySrcs)
polySrcs <-
list("Existing" = existingPolySrcs, "Process" = polySrcs)
if (length(existingPolySrcs) == 0)
selectedPolySrc <- "GADM"
else
selectedPolySrc <- existingPolySrcs[1]
shiny::updateSelectInput(
session = session,
inputId = "polySrc",
label = "polySrc",
choices = polySrcs,
selected = selectedPolySrc
)
})
######################## renderUI polyVer ###################################
observe({
print(paste0("output: polyVer"))
allPolyVers <- Rnightlights::getAllGadmVersions()
existingPolyVers <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries))
existingPolyVers <-
existingPolyVers[existingPolyVers$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingPolyVers <-
existingPolyVers[existingPolyVers$admLevel == admLevel, "polyVer"]
else
existingPolyVers <- unique(existingPolyVers[, "polyVer"])
polyVers <- allPolyVers[!(allPolyVers %in% existingPolyVers)]
if (length(existingPolyVers) == 1)
existingPolyVers <- list(existingPolyVers)
if (length(polyVers) == 1)
polyVers <- list(polyVers)
polyVers <-
list("Existing" = existingPolyVers, "Process" = polyVers)
if (length(existingPolyVers) == 0)
selectedPolyVer <- Rnightlights::pkgOptions("gadmVersion")
else
selectedPolyVer <- existingPolyVers[1]
shiny::updateSelectInput(
session = session,
inputId = "polyVer",
label = "polyVer",
choices = polyVers,
selected = selectedPolyVer
)
})
######################## renderUI polySrc ############################
observe({
print(paste0("output: polyType"))
allPolyTypes <- Rnightlights::getAllGadmPolyTypes()
existingPolyTypes <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries))
existingPolyTypes <-
existingPolyTypes[existingPolyTypes$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingPolyTypes <-
unique(existingPolyTypes[existingPolyTypes$admLevel == admLevel,
"polyType"])
else
existingPolyTypes <- unique(existingPolyTypes[, "polyType"])
polyTypes <-
allPolyTypes[!(allPolyTypes %in% existingPolyTypes)]
if (length(existingPolyTypes) == 1)
existingPolyTypes <- list(existingPolyTypes)
if (length(polyTypes) == 1)
polyTypes <- list(polyTypes)
polyTypes <-
list("Existing" = existingPolyTypes, "Process" = polyTypes)
if (length(existingPolyTypes) == 0)
selectedPolyType <- Rnightlights::pkgOptions("gadmPolyType")
else
selectedPolyType <- "shpZip" #default
shiny::updateSelectInput(
session = session,
inputId = "polyType",
label = "polyType",
choices = polyTypes,
selected = selectedPolyType
)
})
######################## renderUI ctryStats #########################
observe({
print(paste0("output: ctryStats"))
# if(is.null(getInputCountries()))
# return()
ctryStat <- input$ctryStat
optionNaRm <- input$optionNaRm
ctryDtStats <- ctryNlDataListStats()
#if(length(ctryDtStats) == 0)
# return()
existingStats <- trimws(ctryDtStats)
existingStats <-
unname(unlist(lapply(existingStats, function(x) {
xStat <- Rnightlights:::nlSignatureStat(nlStatSignature = x)
xHash <- Rnightlights:::hashNlStat(nlStatName = xStat)
isFun <-
suppressMessages(Rnightlights:::validNlStats(xStat)) ||
Rnightlights:::existsSavedNlStat(nlStatSig = x, nlStatHash = )
if (isFun)
{
if (optionNaRm)
Rnightlights:::nlSignatureAddArg(nlStatSigs = x,
addArg = "na.rm=T")
else
x
}
})))
existingStats <- sort(unique(existingStats))
savedStats <- Rnightlights:::listSavedNlStats()
for (savedStat in savedStats)
{
if (!exists(Rnightlights:::nlSignatureStatName(savedStat),
envir = .GlobalEnv))
Rnightlights:::loadSavedNlStat(savedStat)
}
defaultStats <-
unname(unlist(lapply(defaultStats, function(x) {
isValidNlStat <-
Rnightlights:::validNlStats(Rnightlights:::nlSignatureStat(x))
xStat <- Rnightlights:::nlSignatureStat(nlStatSignature = x)
xHash <- Rnightlights:::hashNlStat(nlStatName = xStat)
existsSavedNlStatName <-
Rnightlights:::existsSavedNlStat(nlStatSig = x, nlStatHash = xHash)
isFun <-
suppressMessages(isValidNlStat || existsSavedNlStatName)
if (isFun && optionNaRm)
Rnightlights:::nlSignatureAddArg(nlStatSigs = x, addArg = "na.rm=T")
else
x
})))
#defaultStats from global environment coz ctryNlData refs it
otherStats <- unique(c(savedStats, defaultStats))
otherStats <- sort(unique(setdiff(otherStats, existingStats)))
if (length(existingStats) == 1)
existingStats <- list(existingStats)
if (length(otherStats) == 1)
otherStats <- list(otherStats)
statChoices <-
list(
"Add New" = list("Add New"),
"With Data" = existingStats,
"Without Data" = otherStats
)
#memory
if (!is.null(ctryStat) && ctryStat != "")
{
selectedStat <- input$ctryStat
} else
{
if (length(existingStats) > 0)
selectedStat <- existingStats[1]
else if (length(otherStats) > 0)
selectedStat <- otherStats[1]
else
selectedStat <- "Add new"
}
# shiny::radioButtons(inputId = "ctryStat",
# label = "Stats",
# choices = statChoices,
# inline = TRUE,
# selected = selectedStat
# )
shiny::updateSelectInput(
session = session,
inputId = "ctryStat",
label = "Stats",
choices = statChoices,
selected = selectedStat
)
})
######################## renderUI newStatStatus #######################
output$newStatStatus <- shiny::renderUI({
print(paste0("output: newStatStatus"))
ctryStat <- input$ctryStat
if (is.null(ctryStat) ||
(!is.null(ctryStat) && ctryStat != "Add New"))
return()
shiny::textInput(inputId = "newStatStatus", label = NULL)
})
######################## renderUI newStat ############################
output$newStat <- shiny::renderUI({
print(paste0("output: newStat"))
ctryStat <- input$ctryStat
if (is.null(ctryStat) ||
(!is.null(ctryStat) && ctryStat != "Add New"))
return()
shiny::textAreaInput(inputId = "newStat",
label = "Function Name/Def",
placeholder =
"mySum <- function(x)\n sum(x, na.rm=TRUE)")
})
######################## renderUI btnNewStat ##########################
output$btnNewStat <- shiny::renderUI({
print(paste0("output: btnNewStat"))
ctryStat <- input$ctryStat
if (is.null(ctryStat) ||
(!is.null(ctryStat) && ctryStat != "Add New"))
return()
shiny::actionButton(inputId = "btnNewStat", label = "Add Function")
})
######################## renderUI nlType #############################
observe({
print(paste0("output: nlType"))
existingNlTypes <- unique(ctryNlTypes())
allNlTypes <- Rnightlights::getAllNlTypes()
if (length(existingNlTypes) == 0)
selectedNlType <- allNlTypes[1]
else
selectedNlType <- existingNlTypes[1]
#for memory
if (!is.null(input$nlType))
selectedNlType <- input$nlType
else
selectedNlType <- "VIIRS.M"
shiny::updateRadioButtons(
session = session,
inputId = "nlType",
label = "NL Type",
choices = allNlTypes,
selected = selectedNlType,
inline = TRUE
)
})
######################## reactive ctryNlDataList ############################
reactListCtryNlData <- shiny::reactive({
print(paste0("reactive: reactListCtryNlData"))
ctryCodes <- getInputCountries()
#if(is.null(ctryCodes))
# return()
if (is.null(ctryCodes))
return(Rnightlights::listCtryNlData())
dummy <- values$needsDataProcessing
Rnightlights::listCtryNlData(ctryCodes = ctryCodes)
})
######################## reactive ctryNlDataList ##########################
ctryNlDataList <- shiny::reactive({
print(paste0("reactive: ctryNlDataList"))
ctryCodes <- getInputCountries()
admLevel <- selectedAdmLevel3()
#if no country selected or one country selected but admLevel is NULL exit
# if(is.null(ctryCodes) ||
# (!is.null(ctryCodes) && length(ctryCodes)==1 && is.null(admLevel)))
# return()
availData <- reactListCtryNlData()
#always return a data.frame even zero row
availData[availData$ctryCode %in% ctryCodes &
availData$admLevel == admLevel,]
availData
})
######################## reactive ctryNlDataList ##########################
ctryNlDataListConfigName <- shiny::reactive({
print(paste0("reactive: ctryNlDataListConfigName"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
if (!is.null(input$nlType))
dat <- dta[dta$nlType == input$nlType,]
dta$configName
})
############### reactive ctryNlDataMultiTileMergeStrategy ################
ctryNlDataMultiTileMergeStrategy <- shiny::reactive({
print(paste0("reactive: ctryNlDataMultiTileMergeStrategy"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$multiTileMergeStrategy
})
############## reactive ctryNlDataMultiTileMergeFun ################
ctryNlDataMultiTileMergeFun <- shiny::reactive({
print(paste0("reactive: ctryNlDataMultiTileMergeFun"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$multiTileMergeFun
})
############# reactive ctryNlDataRemoveGasFlares #################
ctryNlDataRemoveGasFlares <- shiny::reactive({
print(paste0("reactive: ctryNlDataRemoveGasFlares"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$removeGasFlares
})
#################### reactive ctryNlDataListStats ##################
ctryNlDataListStats <- shiny::reactive({
print(paste0("reactive: ctryNlDataListStats"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
xStats <- lapply(unique(dta$ctryCode), function(ctryCode) {
trimws(unlist(strsplit(x = dta[dta$ctryCode == ctryCode, "nlStats"],
split = ","
)
)
)
})
if (length(xStats) == 1)
unique(unlist(xStats))
else
Reduce(intersect, xStats)
})
################### reactive ctryNlDataStats ######################
ctryNlDataStats <- shiny::reactive({
print(paste0("reactive: ctryNlDataStats"))
if (is.null(dta <- ctryNlDataList()))
return(NULL)
dta$nlStats
})
############### renderUI configName ##################
observe({
print("output: configName")
nlType <- input$nlType
if (is.null(nlType))
nlType <- "VIIRS.M"
allConfigNames <- Rnightlights::getAllNlConfigNames()
allConfigNames <-
toupper(allConfigNames[allConfigNames$nlType == nlType, "configName"])
existingConfigNames <- unique(ctryNlDataListConfigName())
#keep only existing for this nlType
existingConfigNames <-
existingConfigNames[existingConfigNames %in% allConfigNames]
allConfigNames <-
allConfigNames[!(allConfigNames %in% existingConfigNames)]
if (length(existingConfigNames) == 1)
existingConfigNames <- list(existingConfigNames)
if (length(allConfigNames) == 1)
allConfigNames <- list(allConfigNames)
configNames <-
list("Existing" = existingConfigNames, "Process" = allConfigNames)
if (length(existingConfigNames) == 0)
selectedConfigName <-
toupper(Rnightlights::pkgOptions(paste0("configName_", nlType)))
else
selectedConfigName <- existingConfigNames[1]
shiny::updateSelectInput(
session = session,
inputId = "configName",
label = "configName",
choices = configNames,
selected = selectedConfigName
)
})
################### renderUI multiTileMergeStrategy #####################
observe({
print("output: multiTileStrategy")
allMultiTileMergeStrategys <- c("ALL", "FIRST", "LAST")
existingMultiTileMergeStrategys <- ctryNlDataList()
countries <- getInputCountries()
if (!is.null(countries) && nrow(existingMultiTileMergeStrategys) > 0)
existingMultiTileMergeStrategys <-
existingMultiTileMergeStrategys[
existingMultiTileMergeStrategys$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel) && nrow(existingMultiTileMergeStrategys) > 0)
{
existingMultiTileMergeStrategys <-
existingMultiTileMergeStrategys[
existingMultiTileMergeStrategys$admLevel == admLevel,
"multiTileMergeStrategy"]
} else if(nrow(existingMultiTileMergeStrategys) > 0){
existingMultiTileMergeStrategys <-
unique(existingMultiTileMergeStrategys[, "multiTileMergeStrategy"])
} else
{
existingMultiTileMergeStrategys <- NULL
}
multiTileMergeStrategys <-
allMultiTileMergeStrategys[!(allMultiTileMergeStrategys %in%
existingMultiTileMergeStrategys)]
if (length(existingMultiTileMergeStrategys) == 1)
existingMultiTileMergeStrategys <-
list(existingMultiTileMergeStrategys)
if (length(multiTileMergeStrategys) == 1)
multiTileMergeStrategys <- list(multiTileMergeStrategys)
multiTileMergeStrategys <-
list("Existing" = existingMultiTileMergeStrategys, "Process" = multiTileMergeStrategys)
if (length(existingMultiTileMergeStrategys) == 0)
selectedMultiTileMergeStrategy <-
toupper(Rnightlights::pkgOptions("multiTileStrategy"))
else
selectedMultiTileMergeStrategy <-
toupper(existingMultiTileMergeStrategys[1])
shiny::updateSelectInput(
session = session,
inputId = "multiTileMergeStrategy",
label = "multiTileStrategy",
choices = multiTileMergeStrategys,
selected = selectedMultiTileMergeStrategy
)
})
######################## renderUI multiTileMergeFun ###################################
observe({
print("output: multiTileMergeFun")
allMultiTileMergeFuns <- c("MEAN", "MEDIAN")
existingMultiTileMergeFuns <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries) && nrow(existingMultiTileMergeFuns) > 0)
existingMultiTileMergeFuns <-
existingMultiTileMergeFuns[existingMultiTileMergeFuns$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel) && nrow(existingMultiTileMergeFuns) > 0)
{
existingMultiTileMergeFuns <-
existingMultiTileMergeFuns[existingMultiTileMergeFuns$admLevel == admLevel, "multiTileMergeFun"]
} else if(nrow(existingMultiTileMergeFuns) > 0)
{
existingMultiTileMergeFuns <-
unique(existingMultiTileMergeFuns[, "multiTileMergeFun"])
} else
{
existingMultiTileMergeFuns <- NULL
}
multiTileMergeFuns <-
allMultiTileMergeFuns[!(allMultiTileMergeFuns %in% existingMultiTileMergeFuns)]
if (length(existingMultiTileMergeFuns) == 1)
existingMultiTileMergeFuns <- list(existingMultiTileMergeFuns)
if (length(multiTileMergeFuns) == 1)
multiTileMergeFuns <- list(multiTileMergeFuns)
multiTileMergeFuns <-
list("Existing" = existingMultiTileMergeFuns, "Process" = multiTileMergeFuns)
if (length(existingMultiTileMergeFuns) == 0)
selectedMultiTileMergeFun <-
toupper(Rnightlights::pkgOptions("multiTileMergeFun"))
else
selectedMultiTileMergeFun <- existingMultiTileMergeFuns[[1]]
shiny::updateSelectInput(
session = session,
inputId = "multiTileMergeFun",
label = "multiTileMergeFun",
choices = multiTileMergeFuns,
selected = selectedMultiTileMergeFun
)
})
######################## renderUI removeGasFlares ###################################
observe({
print("output: removeGasFlares")
allRemoveGasFlares <- c(TRUE, FALSE)
existingRemoveGasFlares <- unique(ctryNlDataList())
countries <- getInputCountries()
if (!is.null(countries))
existingRemoveGasFlares <-
existingRemoveGasFlares[existingRemoveGasFlares$ctryCode %in% countries,]
admLevel <- input$radioAdmLevel
if (!is.null(admLevel))
existingRemoveGasFlares <-
existingRemoveGasFlares[existingRemoveGasFlares$admLevel == admLevel, "removeGasFlares"]
else
existingRemoveGasFlares <-
unique(existingRemoveGasFlares[, "removeGasFlares"])
removeGasFlares <-
allRemoveGasFlares[!(allRemoveGasFlares %in% existingRemoveGasFlares)]
existingRemoveGasFlares <- as.logical(existingRemoveGasFlares)
removeGasFlares <- as.logical(removeGasFlares)
if (length(existingRemoveGasFlares) == 1)
existingRemoveGasFlares <- list(existingRemoveGasFlares)
if (length(removeGasFlares) == 1)
removeGasFlares <- list(removeGasFlares)
removeGasFlares <-
list("Existing" = existingRemoveGasFlares, "Process" = removeGasFlares)
if (length(existingRemoveGasFlares) == 0)
selectedRemoveGasFlare <-
Rnightlights::pkgOptions("removeGasFlares")
else
selectedRemoveGasFlare <- existingRemoveGasFlares[1]
shiny::updateSelectInput(
session = session,
inputId = "removeGasFlares",
label = "removeGasFlares",
choices = removeGasFlares,
selected = selectedRemoveGasFlare
)
})
######################## reactiveValues values ###################################
values <- shiny::reactiveValues(
lastUpdated = NULL,
needsDataUpdate = FALSE,
needsDataProcessing = FALSE,
newStatFuncName = NULL,
newStatFuncBody = NULL,
updatePlot = 0,
updateMap = 0
)
######################## observe lastUpdated ###################################
observe({
lapply(names(input), function(x) {
shiny::observe({
input[[x]]
#print(paste0("lastUpdated: ", x))
values$lastUpdated <- x
})
})
})
observe({
print(paste0("observe: newStat"))
countries <- getInputCountries()
admLevel <- selectedAdmLevel3()
nlType <- input$nlType
nlStat <- input$ctryStat
if (!is.null(nlStat) && nlStat == "Add New")
{
nlStat <- values$newStatFuncName
}
nlPeriod <- input$nlPeriodRange
if (!is.null(nlPeriod))
{
nlPeriod <-
Rnightlights::dateToNlPeriod(dt = nlPeriod, nlType = nlType)
if (all(Rnightlights::validNlPeriods(nlPeriods = nlPeriod, nlTypes = nlType)))
nlPeriod <-
Rnightlights::nlRange(
startNlPeriod = nlPeriod[1],
endNlPeriod = nlPeriod[2],
nlType = nlType
)
else
return()
}
else
{
nlPeriod <- input$nlPeriod
if (!is.null(nlPeriod))
nlPeriod <- as.character(nlPeriod)
}
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
custPolyPath <-
if (!is.null(polySrc) && polySrc == "CUST")
polyVer
else
NULL
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
if (length(countries) == 0)
return()
if ((length(countries) == 1 &&
is.null(admLevel)) || is.null(nlType) || is.null(nlStat) ||
length(nlStat) == 0 || nlStat == "" || is.null(polySrc) ||
is.null(polyVer) ||
is.null(polyType) ||
is.null(configName) || is.null(multiTileMergeStrategy) ||
is.null(multiTileMergeFun) || is.null(removeGasFlares))
return()
existsData <- sapply(countries, function(x) {
nlStatList <- Rnightlights:::nlSignatureStat(nlStat = nlStat)
Rnightlights:::existsCtryNlData(
ctryCode = x,
admLevel = admLevel,
nlTypes = nlType,
configNames = configName,
multiTileStrategy = multiTileMergeStrategy,
multiTileMergeFun = multiTileMergeFun,
removeGasFlares = removeGasFlares,
nlPeriods = nlPeriod,
nlStats = nlStatList,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = custPolyPath
)
})
if (any(!existsData))
{
print("existsData: Some data does not exist")
values$needsDataProcessing <- TRUE
}
else
values$needsDataProcessing <- FALSE
})
observeEvent(input$countries, {
print(paste0("observeEvent: input$countries"))
if (length(input$countries) > 1)
updateRadioButtons(session = session,
inputId = "admLevel",
selected = "country")
})
observe({
print(paste0("observe: needsDataProcessing"))
if ((length(input$countries) > 0) &&
!is.null(input$radioAdmLevel) && is.null(ctryNlDataList()))
{
values$needsDataProcessing
}
})
observeEvent(input$newStat, {
print(paste0("observeEvent: input$newstat"))
if (is.null(newStat <- input$newStat))
return()
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function Name/Definition")
})
observeEvent(input$btnNewStat, {
print(paste0("observeEvent: input$btnNewStat"))
if (is.null(newStat <- input$newStat))
return()
if (grepl("[a-zA-Z0-9_]\\s*(<-)|(=)\\s*function\\s*\\(.*\\).+",
newStat))
{
#if it is a function definition
#split into function name and body based on assignment operator
statParts <- unlist(strsplit(x = newStat, split = "<-"))
newStatName <- trimws(statParts[1])
newStatBody <- trimws(statParts[2])
#add the function into the global environment so we can access it later
assign(x = newStatName,
value = eval(parse(text = newStatBody)),
envir = .GlobalEnv)
newStat <- newStatName
} else if (grepl("^list\\s*\\(", newStat))
{
statList <- eval(parse(text = newStat))
if (is.list(statList))
{
newStatName <- statList[[1]]
}
} else
{
newStatName <- newStat
}
validStat <- Rnightlights:::validNlStats(nlStats = newStatName)
if (validStat)
{
ctryNlDataList <- ctryNlDataList()
if (!is.null(ctryNlDataList))
{
existingStats <- unique(ctryNlDataList$nlStats)
if (newStat %in% existingStats)
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function name exists")
else
{
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function OK")
if (!is.null(input$countries))
{
values$newStatFuncName <- newStat
if (exists("newStatBody"))
values$newStatFuncBody <-
eval(parse(text = newStatBody))
else
values$newStatFuncBody <- NULL
}
}
return()
} else
{
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Function OK")
return()
}
} else
{
updateTextAreaInput(session = session,
inputId = "newStat",
label = "Invalid Function")
return()
}
})
observeEvent(input$countries, {
print(paste0("observeEvent: input$countries"))
if (!is.null(input$countries) && !values$needsDataUpdate)
values$needsDataUpdate <- TRUE
})
observeEvent(input$radioAdmLevel, {
print(paste0("observeEvent: input$radioAdmLevel"))
if (!is.null(input$countries) && !values$needsDataUpdate)
values$needsDataUpdate <- TRUE
})
observeEvent(input$btnGo, {
print(paste0("observeEvent: input$btnGo"))
values$needsDataUpdate <- FALSE
values$needsDataProcessing <- FALSE
values$updatePlot <- values$updatePlot + 1
values$updateMap <- values$updateMap + 1
})
######################## renderUI radioAdmLevel ###################################
output$radioAdmLevel <- shiny::renderUI({
print("output: radioAdmLevel")
countries <- getInputCountries()
if (is.null(countries))
return()
# strict <- shiny::isolate(input$strict)
if (length(countries) != 1)
return()
admLevels <- unlist(ctryAdmLevels())
if (is.null(admLevels))
return()
availData <- reactListCtryNlData()
# if(strict)
admLevels <-
unlist(sapply(seq_along(admLevels), function(admLevel)
{
ctryNlDataFile <-
Rnightlights:::getCtryNlDataFnamePath(
ctryCode = countries,
admLevel = Rnightlights:::getCtryShpLyrNames(ctryCode = countries,
lyrNums = admLevel - 1,)
)
if (!is.null(availData))
admLevelHasData <-
nrow(availData[availData$ctryCode == countries &
availData$admLevel == paste0("ADM", admLevel -
1), ]) > 0
else
admLevelHasData <- FALSE
if (admLevelHasData)
return(admLevels[admLevel])
else
return(paste0(admLevels[admLevel], " (NA)"))
}))
selectedRadioAdmLevel <- if (!is.null(input$radioAdmLevel) && length(countries) == 1)
input$radioAdmLevel
else if(length(nonNARadioAdmLevel <- grep(pattern = "NA", x = admLevels, value = TRUE, invert = TRUE))>0)
nonNARadioAdmLevel[1]
else
admLevels[1]
shiny::radioButtons(
inputId = "radioAdmLevel",
label = "Admin Level",
choiceNames = admLevels,
choiceValues = gsub("\\s*\\(NA\\)", "", admLevels),
selected = gsub("\\s*\\(NA\\)", "", selectedRadioAdmLevel)
)
})
######################## render UI: selectAdmLevel ###################################
tags$head(tags$style(
HTML(
"div.form-group.shiny-input-container {margin-top: -20px; margin-bottom: -20px;}"
)
))
output$selectAdmLevel <- shiny::renderUI({
print("output: selectAdmLevel")
countries <- getInputCountries()
#strict <- shiny::isolate(input$strict)
if (length(countries) != 1 ||
identical(countries, character(0)))
return()
if ((
length(countries) != 1 ||
identical(countries, character(0)) || grepl("^\\s*$", countries)
))
return()
ctryAdmLevels <- unlist(ctryAdmLevels())
if (is.null(ctryAdmLevels))
return()
ctryAdmLevelNames <- ctryAdmLevelNames()
if (ncol(ctryAdmLevelNames) > 2)
elems <- lapply(2:length(ctryAdmLevels), function(lvlIdx) {
lvl <- ctryAdmLevels[lvlIdx]
# if(strict)
# lvlEnabled <- file.exists(Rnightlights:::getCtryNlDataFnamePath(countries, paste(getInputCountries(), "_adm", lvlIdx-1, sep = "")))
# else
# lvlEnabled <- TRUE
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNames, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
# if(!lvlEnabled)
# lvlSelect <- NULL
#if(lvlEnabled)
#{
b <-
shiny::selectizeInput(
inputId = paste0("selectAdm", lvlIdx),
label = ctryAdmLevels[lvlIdx],
#choices = NULL,
choices = lvlSelect,
multiple = TRUE
)
# }else
# {
# b <- shiny::textInput(inputId = "dummy",
# label = ctryAdmLevels[lvlIdx],
# value = "Strict: Data Not Available",
# placeholder = "Disable Strict to aggregate data")
# }
b
})
})
######################## selectedAdmLevelInput ###################################
selectedAdmLevelInput <- shiny::reactive({
print("reactive: selectedAdmLevelInput")
admLvlCtrlNames <- names(input)
x <- admLvlCtrlNames[grep("selectAdm\\d+$", admLvlCtrlNames)]
shiny::isolate({
admLvlNums <- NULL
for (i in x)
if (length(input[[i]]) > 0)
admLvlNums <- c(admLvlNums, i)
#print(paste0("x", x))
#print(paste0("admlvlnums:", admLvlNums))
#if (admLvlNum=="" && length(countries)>0)
# return()
admLvlNums <-
as.numeric(gsub("[^[:digit:]]", "", admLvlNums))
if (length(admLvlNums) == 0)
admLvlNums <- 1
})
selectedAdmLevel()[admLvlNums]
})
######################## selectedAdmLevel ###################################
selectedAdmLevel <- shiny::reactive({
print("reactive: selectedAdmLevel")
if (length(getInputCountries()) == 0)
return()
admLevel <- input$radioAdmLevel
admLevel
})
######################## selectedAdmLevel3 ###################################
selectedAdmLevel3 <- shiny::reactive({
print("reactive: selectedAdmLevel3")
if (length(getInputCountries()) > 1)
return("ADM0")
x <- selectedAdmLevel()
if (length(x) == 0)
return(NULL)
x <-
Rnightlights::searchAdmLevel(ctryCodes = input$countries,
admLevelNames = x)
admLevel <-
paste0("ADM", substr(
x = x,
start = nchar(x),
stop = nchar(x)
))
admLevel
})
######################## observe selectAdms (selectAdmLevel) ###################################
shiny::observe({
print(paste0("observe: selectAdms"))
countries <- input$countries
if (length(countries) == 0)
return()
#strict <- shiny::isolate(input$strict)
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
custPolyPath <-
if (!is.null(polySrc) && polySrc == "CUST")
polyVer
else
NULL
admLvlCtrlsNames <- names(input)
x <-
admLvlCtrlsNames[grep("selectAdm\\d+$", admLvlCtrlsNames)]
if (length(x) == 0)
return()
admSelected <- FALSE
lowestSelected <- ""
for (i in x)
{
if (length(input[[i]]) > 0)
{
admSelected <- TRUE
lowestSelected <- gsub("[^[:digit:]]", "", i)
}
}
ctryAdmLevelNames <- ctryAdmLevelNames()
ctryAdmLevelNamesFilter <- ctryAdmLevelNames
ctryAdmLevels <- unlist(ctryAdmLevels())
lvlNum <-
gsub("[^[:digit:]]", "", values$lastUpdated) #gsub("[^[:digit:]]", "", x)
#message("lvlnum:", lvlNum, ":", str(lvlNum))
if (lvlNum == "" || length(countries) == 0)
return()
#trigger Go button
values$needsDataUpdate <- TRUE
if (!admSelected)
{
for (lvlIdx in 2:length(ctryAdmLevels)) {
lvl <- ctryAdmLevels[lvlIdx]
# if(strict)
# lvlEnabled <- file.exists(Rnightlights:::getCtryNlDataFnamePath(countries, paste(getInputCountries(), "_adm", lvlIdx-1, sep = "")))
# else
# lvlEnabled <- TRUE
#lvlSelect <- unique(ctryAdmLevelNames[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNames, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
# if(!lvlEnabled)
# lvlSelect <- NULL
# if(lvlEnabled)
# {
shiny::updateSelectizeInput(
session = session,
inputId = paste0("selectAdm", lvlIdx),
label = ctryAdmLevels[lvlIdx],
#choices = NULL,
choices = lvlSelect,
)
# }else
# {
# shiny::updateTextInput(session = session,
# inputId = "dummy",
# label = ctryAdmLevels[lvlIdx],
# value = "Strict: Data Not Available",
# placeholder = "Disable Strict to aggregate data")
# }
}
return()
}
#print(paste0("lastupdated:", values$lastUpdated))
#print(paste0("x:", x))
print(paste0("lvlnum:", lvlNum))
#set admLevel to match the selectizeInput level
#if (length(input[[paste0("selectAdm", lvlNum)]]) > 0)
updateRadioButtons(session = session,
inputId = "radioAdmLevel",
selected = ctryAdmLevels[as.numeric(lowestSelected)])
multipleSelected <- FALSE
#loop through all selectAdms and effect changes relative to the one that has last changed
for (lvlIdx in 2:length(ctryAdmLevels))
{
lvlSelect <- ""
top10 <- ""
# if(strict)
# lvlEnabled <- file.exists(
# Rnightlights:::getCtryNlDataFnamePath(ctryCode = getInputCountries(),
# admLevel = Rnightlights:::getCtryShpLyrNames(ctryCodes = getInputCountries(),
# lyrNums = lvlIdx-1,
# gadmVersion = polyVer,
# gadmPolyType = polyType,
# custPolyPath = custPolyPath),
# gadmVersion = polyVer,
# gadmPolyType = polyType,
# custPolyPath = custPolyPath))
# else
# lvlEnabled <- TRUE
if (length(input[[paste0("selectAdm", lvlIdx)]]) > 1)
multipleSelected <- TRUE
if (lvlIdx < lvlNum)
{
#print(paste0("lvlIdx:",lvlIdx,"lvlNum:",lvlNum))
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 1)
{
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] == input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
}
else
{
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
}
#print(paste0("lvlSelect:",lvlSelect))
#print(paste0("lvlselect: ", lvlSelect))
#print(paste0("top10: ", top10))
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = TRUE)
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]]
)
}
else if (lvlIdx == lvlNum)
{
#print(paste0("lvlIdx:",lvlIdx,"lvlNum:",lvlNum))
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 1)
{
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] == input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
#top10 <- if(length(lvlSelect) > 1) lvlSelect[1] else no = lvlSelect
#print(paste0("lvlselect: ", lvlSelect))
#print(paste0("top10: ", top10))
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = TRUE)
# if(!lvlEnabled)
# lvlSelect <- NULL
# if (length(input[[paste0("radioAdm", lvlIdx)]])==0)
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]]
)
} else
{
shiny::updateSelectizeInput(session, paste0("selectAdm", lvlIdx), choices = NULL)
}
}
else
{
#print(paste0("lvlIdx:",lvlIdx,"lvlNum:",lvlNum))
# if (multipleSelected)
# {
# shiny::updateSelectizeInput(session, paste0("selectAdm", lvlIdx), choices = "")
# next()
# }
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 1)
{
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] == input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = FALSE)
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]][input[[paste0("selectAdm", lvlIdx)]] %in% unlist(lvlSelect)]
)
}
else if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) == 0 &&
length(input[[paste0("selectAdm", lvlNum)]]) == 1)
{
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]][input[[paste0("selectAdm", lvlIdx)]] %in% unlist(lvlSelect)]
)
}
else
{
##lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
#lvlSelect <- unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx-1,lvlIdx))
#lvlSelect <- group_by(lvlSelect, ctryAdmLevels[lvlIdx-1])
#lvlSelect <- split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx-1]]])
#shiny::updateSelectizeInput(session, paste0("selectAdm", lvlIdx), choices = lvlSelect, selected = NULL)
if (length(input[[paste0("selectAdm", lvlIdx - 1)]]) > 0)
ctryAdmLevelNamesFilter <-
subset(ctryAdmLevelNamesFilter,
ctryAdmLevelNamesFilter[[ctryAdmLevels[[lvlIdx - 1]]]] %in% input[[paste0("selectAdm", lvlIdx -
1)]])
#lvlSelect <- unique(ctryAdmLevelNamesFilter[[ctryAdmLevels[lvlIdx]]])
lvlSelect <-
unique(dplyr::select(ctryAdmLevelNamesFilter, lvlIdx - 1, lvlIdx))
lvlSelect <-
dplyr::group_by(lvlSelect, ctryAdmLevels[lvlIdx - 1])
lvlSelect <-
split(lvlSelect[[ctryAdmLevels[lvlIdx]]], lvlSelect[[ctryAdmLevels[lvlIdx -
1]]])
names(lvlSelect) <-
paste(ctryAdmLevels[lvlIdx - 1], names(lvlSelect), sep = ":")
#updateCheckboxInput(session, paste0("radioAdm", lvlIdx),value = FALSE)
# if(!lvlEnabled)
# lvlSelect <- NULL
shiny::updateSelectizeInput(
session,
paste0("selectAdm", lvlIdx),
choices = lvlSelect,
selected = input[[paste0("selectAdm", lvlIdx)]][input[[paste0("selectAdm", lvlIdx)]] %in% unlist(lvlSelect)]
)
}
}
# if(!lvlEnabled)
# {
# shinyjs::disable(selector = paste0("[type=radio][value=selectAdm", lvlIdx,"]"))
#
# shinyjs::disable(paste0("selectAdm", lvlIdx))
#
# shinyjs::runjs(paste0("$('selectAdm", lvlIdx, "').parent().parent().addClass('disabled').css('opacity', 0.4)"))
# }
}
#})
})
#})
######################## sliderNlPeriodRange ###################################
output$sliderNlPeriodRange <- shiny::renderUI({
print(paste0("output: sliderNlPeriodRange"))
#ctryData <- ctryNlDataMelted()
nlType <- input$nlType
if (is.null(nlType))
return()
shiny::isolate({
nlPeriodRange <- input$nlPeriodRange
if (!is.null(values$lastUpdated) &&
values$lastUpdated == "nlPeriodRange")
{
startDate <- nlPeriodRange[1]
endDate <- nlPeriodRange[2]
} else
#if (is.null(ctryData))
{
if (!is.null(nlType))
nlP <- input$nlPeriodRange
else
nlP <- NULL
if (!is.null(nlP))
nlP <-
Rnightlights::dateToNlPeriod(dt = nlP, nlType = nlType)
if (!is.null(nlP) &&
!all(Rnightlights::validNlPeriods(nlPeriods = nlP, nlTypes = nlType)))
nlPeriodRange <- NULL
if (!is.null(dta <- ctryNlDataList()))
{
dta <- dta[dta$nlType == nlType,]
if (!is.null(admLevel <- selectedAdmLevel3()))
dta <- dta[dta$admLevel == admLevel,]
startDate <- min(dta$nlPeriod)
endDate <- max(dta$nlPeriod)
} else if (!is.null(nlPeriodRange))
{
startDate <- Rnightlights::dateToNlPeriod(nlPeriodRange[1], nlType)
endDate <-
Rnightlights::dateToNlPeriod(nlPeriodRange[2], nlType)
} else {
if (is.null(nlType))
nlType <- "VIIRS.M"
dta <- unlist(Rnightlights::getAllNlPeriods(nlType))
startDate <- dta[1]
endDate <- dta[length(dta)]
}
startDate <-
gsub("-*$", "", paste(
substr(startDate, 1, 4),
substr(startDate, 5, 6),
substr(startDate, 7, 8),
sep = "-"
))
endDate <-
gsub("-*$", "", paste(
substr(endDate, 1, 4),
substr(endDate, 5, 6),
substr(endDate, 7, 8),
sep = "-"
))
if (stringr::str_detect(nlType, "D"))
{
startDate <- paste0(startDate)
endDate <- paste0(endDate)
} else if (stringr::str_detect(nlType, "M"))
{
startDate <- paste0(startDate, "-01")
endDate <- paste0(endDate, "-01")
} else if (stringr::str_detect(nlType, "Y"))
{
startDate <- paste0(startDate, "-01-01")
endDate <- paste0(endDate, "-01-01")
}
tmFmt <- "%Y-%m-%d"
startDate <- as.Date(as.character(startDate), tmFmt)
endDate <- as.Date(as.character(endDate), tmFmt)
#minDate <- startDate
#maxDate <- endDate
# shiny::sliderInput(inputId = "nlPeriodRange",
# label = "Time",
# min = as.Date("2012-04-01", "%Y-%m-%d"),
# max = as.Date("2017-10-31", "%Y-%m-%d"),
# timeFormat = "%Y-%m",
# step = 31,
# value = c(as.Date("2012-04-01","%Y-%m-%d"),as.Date("2017-10-31","%Y-%m-%d"))
# )
}
# else
# {
# if(!is.null(nlPeriodRange))
# nlPeriodRange <- NULL
#
# #startDate <- min(ctryData$variable)
# #endDate <- max(ctryData$variable)
# #minDate <- startDate
# #maxDate <- endDate
# }
if (stringr::str_detect(nlType, "D"))
{
tmFmt <- "%Y-%m-%d"
if (!is.null(nlPeriodRange))
{
nlRangeStart <- nlPeriodRange[1]
nlRangeEnd <- nlPeriodRange[2]
}
step <- 1
} else if (stringr::str_detect(nlType, "M"))
{
tmFmt <- "%Y-%m"
if (!is.null(nlPeriodRange))
{
nlRangeStart <- nlPeriodRange[1]
nlRangeEnd <- nlPeriodRange[2]
}
step <- 31
} else if (stringr::str_detect(nlType, "Y"))
{
tmFmt <- "%Y"
if (!is.null(nlPeriodRange))
{
nlRangeStart <- nlPeriodRange[1]
nlRangeEnd <- nlPeriodRange[2]
}
step <- 1
}
if (!is.null(nlPeriodRange))
{
if (is.na(nlRangeStart))
{
nlRangeStart <- startDate
nlRangeEnd <- endDate
}
# if(nlRangeStart > startDate)
# startDate <- nlRangeStart
#
# if(nlRangeEnd < endDate)
# endDate <- nlRangeEnd
}
allNlPeriods <-
unlist(Rnightlights::getAllNlPeriods(nlTypes = nlType))
minDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[1], nlType = nlType)
maxDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[length(allNlPeriods)], nlType = nlType)
shiny::absolutePanel(
draggable = T,
top = "65vh",
left = "7%",
shiny::sliderInput(
inputId = "nlPeriodRange",
label = "Time",
min = minDate,
max = maxDate,
timeFormat = tmFmt,
step = step,
value = c(startDate, endDate),
animate = animationOptions(
interval = 1000,
loop = FALSE,
playButton = NULL,
pauseButton = NULL
)
)
)
})
})
######################## sliderNlPeriod ###################################
output$sliderNlPeriod <- shiny::renderUI({
print(paste0("output: sliderNlPeriod"))
#ctryData <- ctryNlDataMelted()
#shiny::isolate({
nlType <- input$nlType
nlPeriod <- input$nlPeriod
if (!is.null(values$lastUpdated) &&
values$lastUpdated == "nlPeriod")
{
value <- nlPeriod
} else
#if (is.null(ctryData))
{
if (!is.null(nlType))
nlP <- input$nlPeriod
else
nlP <- NULL
if (!is.null(nlP))
nlP <-
Rnightlights::dateToNlPeriod(dt = nlP, nlType = nlType)
if (!is.null(nlP) &&
!all(Rnightlights::validNlPeriods(nlPeriods = nlP, nlTypes = nlType)))
nlPeriod <- NULL
if (!is.null(dta <- ctryNlDataList()))
{
dta <- dta[dta$nlType == nlType,]
if (!is.null(admLevel <- selectedAdmLevel3()))
dta <- dta[dta$admLevel == admLevel,]
value <- min(dta$nlPeriod)
} else if (!is.null(nlPeriod))
{
value <- Rnightlights::dateToNlPeriod(nlPeriod, nlType)
} else {
if (is.null(nlType))
nlType <- "VIIRS.M"
dta <- unlist(Rnightlights::getAllNlPeriods(nlType))
value <- dta[1]
}
value <-
gsub("-*$", "", paste(
substr(value, 1, 4),
substr(value, 5, 6),
substr(value, 7, 8),
sep = "-"
))
if (stringr::str_detect(nlType, "D"))
{
} else if (stringr::str_detect(nlType, "M"))
{
value <- paste0(value, "-01")
} else if (stringr::str_detect(nlType, "Y"))
{
value <- paste0(value, "-01-01")
}
tmFmt <- "%Y-%m-%d"
value <- as.Date(as.character(value), tmFmt)
}
# else
# {
# #value <- min(ctryData$variable)
# }
if (stringr::str_detect(nlType, "D"))
{
tmFmt <- "%Y-%m-%d"
if (!is.null(nlPeriod))
{
value <- nlPeriod
}
step <- 1
}
else if (stringr::str_detect(nlType, "M"))
{
tmFmt <- "%Y-%m"
if (!is.null(nlPeriod))
{
value <- nlPeriod
}
step <- 31
}
else if (stringr::str_detect(nlType, "Y"))
{
tmFmt <- "%Y"
if (!is.null(nlPeriod))
{
value <- nlPeriod
}
step <- 366
}
# if(!is.null(input$nlPeriod))
# value <- as.Date(as.character(input$nlPeriod), tmFmt)
allNlPeriods <-
unlist(Rnightlights::getAllNlPeriods(nlTypes = nlType))
minDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[1], nlType = nlType)
maxDate <-
Rnightlights::nlPeriodToDate(nlPeriod = allNlPeriods[length(allNlPeriods)], nlType = nlType)
shiny::sliderInput(
inputId = "nlPeriod",
label = "Time",
min = minDate,
max = maxDate,
timeFormat = tmFmt,
step = step,
value = value,
animate = animationOptions(
interval = 1000,
loop = FALSE,
playButton = "Play",
pauseButton = NULL
)
)
#})
})
######################## textDate ###################################
# output$textDate <- shiny::renderUI({
# print(paste0("output: textDate"))
#
# nlPeriod <-
#
# dateInput(inputId = textDate, )
#
# })
######################## hCluster ###################################
hCluster <- shiny::reactive({
print(paste0("reactive: hCluster"))
input$btnGo
if (values$needsDataProcessing || values$needsDataUpdate)
return()
countries <- getInputCountries()
admLevel <- input$radioAdmLevel #unlist(ctryAdmLevels())[2]
if (is.null(countries) ||
(length(countries) == 1 && admLevel == "country"))
return()
if (length(countries) > 1)
admLevel <- "country"
scale <- input$scale
normArea <- input$norm_area
shiny::isolate({
nlPeriodRange <- input$nlPeriodRange
graphType <- input$graphType
#return if the country doesn't have adm levels below country
if (is.null(admLevel) || is.na(admLevel))
return()
#meltCtryData <- ctryNlDataMelted()
meltCtryData <- ctryNlDataMelted()
if (is.null(countries) ||
is.null(meltCtryData) || nrow(meltCtryData) < 3)
return()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
#aggMeltCtryData <- stats::aggregate(mean(value), by=list(eval(admLevel)+variable), data=meltCtryData, mean)
aggMeltCtryData <-
stats::setNames(meltCtryData[, list(mean(value, na.rm = TRUE)), by = list(meltCtryData[[admLevel]], variable)], c(admLevel, "variable", "value"))
dcastFormula <-
paste(paste0("`", admLevel, "`", collapse = " + "),
"~",
paste("variable", collapse = " + "))
unmeltCtryData <-
data.table::dcast(aggMeltCtryData,
dcastFormula,
value.var = 'value',
aggregate = 'mean')
d <- stats::dist(unmeltCtryData)
h <- stats::hclust(d)
h$labels <- unmeltCtryData[[admLevel]]
h
})
})
######################## plotHCluster ###################################
output$plotHCluster <- shiny::renderPlot({
print(paste0("output: plotHCluster"))
clusts <- hCluster()
numClusters <- input$kClusters
if (is.null(clusts))
return("Country has no adm levels")
countries <- shiny::isolate(getInputCountries())
if (length(countries) > 1)
admLevel <- "country"
shiny::isolate({
cutClusts <- stats::cutree(clusts, k = numClusters)
dendro <- stats::as.dendrogram(clusts)
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
dendro %>%
dendextend::color_branches(k = numClusters,
col = rev(cbPalette[1:numClusters]),
groupLabels = T) %>%
dendextend::color_labels(k = numClusters, col = rev(cbPalette[1:numClusters])) %>%
graphics::plot(horiz = FALSE, main = "")
dendro %>% dendextend::rect.dendrogram(k = numClusters,
horiz = FALSE,
border = rev(cbPalette[1:numClusters]))
})
})
######################## plotPointsCluster ###################################
output$plotPointsCluster <- plotly::renderPlotly({
print(paste0("output: plotPointsCluster"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
if (length(countries) < 1)
return()
clusts <- hCluster()
if (is.null(clusts))
return()
normArea <- input$norm_area
admLevel <- input$radioAdmLevel #unlist(ctryAdmLevels())[2]
#return if the country doesn't have adm levels below country
if (is.null(admLevel))
return()
if (length(countries) > 1)
admLevel <- "country"
numClusters <- input$kClusters
scale <- input$scale
isolate({
meltCtryData <- ctryNlDataMelted()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
cutClusts <- stats::cutree(clusts, k = numClusters)
#ctryAvg <- aggregate(value ~ admLevel, data=meltCtryData, mean)
ctryAvg <-
stats::setNames(meltCtryData[, mean(value, na.rm = TRUE), by = list(meltCtryData[[admLevel]])], c(admLevel, "value"))
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
clusters <- as.factor(cutClusts)
g <- ggplot2::ggplot(data = ctryAvg,
aes(x = ctryAvg[[admLevel]],
y = value, col = clusters)) +
geom_point(size = 2) +
theme(axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
)) +
ggplot2::scale_colour_manual(values = cbPalette) +
xlab(admLevel) +
ylab("Radiance")
p <- plotly::ggplotly(g)
p$elementId <- NULL
p
})
})
######################## mapHCluster ###################################
output$mapHCluster <- leaflet::renderLeaflet({
print(paste0("output: mapHCluster"))
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
input$btnGo
if (values$needsDataUpdate || values$needsDataProcessing)
return()
countries <- shiny::isolate(getInputCountries())
scale <- input$scale
numClusters <- input$kClusters
normArea <- input$norm_area
shiny::isolate({
if (is.null(countries))
return()
if (length(countries) > 1)
admLevel <- "country"
# if (length(countries) != 1)
# {
# renderText("Please select only one country/region")
# return()
# }
#print("drawing leaflet cluster")
clusts <- hCluster()
if (is.null(clusts))
return()
cutClusts <- stats::cutree(clusts, k = numClusters)
admLevel <- input$radioAdmLevel #unlist(ctryAdmLevels())[2]
meltCtryData <- ctryNlDataMelted()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
#map <- leaflet::leaflet(data=ctryPoly0) %>%
map <- leaflet::leaflet() %>%
leaflet::addTiles("http://a.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png")
#leaflet::addTiles() %>%
# leaflet::addWMSTiles(layerId="nlRaster",
# baseUrl = "http://localhost/cgi-bin/mapserv?map=test.map",
# layers = "NL_CTRYCODE_VIIRS.M_NLPERIOD_VCMCFG-MTSALL-MEAN-RGFT_GADM-3.6-SHPZIP",
# options = leaflet::WMSTileOptions(format = "image/png",
# transparent = TRUE,
# opacity=0.8))
ctryPoly0 <-
Rnightlights::readCtryPolyAdmLayer(
ctryCode = countries[1],
admLevel = unlist(Rnightlights::getCtryShpLyrNames(countries[1], 0))
)
if (length(countries) > 1) {
for (country in countries[2:length(countries)])
{
ctryPoly0 <- sp::rbind.SpatialPolygonsDataFrame(
ctryPoly0,
Rnightlights::readCtryPolyAdmLayer(
ctryCode = country,
admLevel = unlist(Rnightlights::getCtryShpLyrNames(country, 0))
),
makeUniqueIDs = T
)
}
lvlCtryData <-
stats::setNames(meltCtryData[, mean(value, na.rm = TRUE), by = list(meltCtryData[[admLevel]])], c(admLevel, "value"))
lvlCtryData[["rank"]] <-
with(lvlCtryData, rank(value, ties.method = 'first'))
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
pal <- cbPalette
ctryPoly0 <- sp::spTransform(ctryPoly0, wgs84)
mapLabels <- sprintf(
paste0(
"%s:%s",
"<br/>Cluster: %s",
"<br/>Rad:%s",
"<br/>Rank: %s/%s"
),
admLevel,
lvlCtryData[[1]],
cutClusts,
format(
lvlCtryData[[2]],
scientific = T,
digits = 2
),
lvlCtryData[["rank"]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
map <- map %>% leaflet::addPolygons(
data = ctryPoly0,
#layerId = "country",
fill = TRUE,
fillColor = pal[cutClusts],
fillOpacity = 0.9,
stroke = TRUE,
weight = 1,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = admLevel,
highlight = leaflet::highlightOptions(
weight = 5,
#color = "#666",
#dashArray = "",
fillOpacity = 0,
bringToFront = TRUE
),
label = mapLabels,
labelOptions = leaflet::labelOptions(
style = list("font-weight" = "normal",
padding = "3px 8px"),
textsize = "15px",
direction = "auto"
)
)
} else
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly0,
layerId = countries,
fill = FALSE,
fillColor = "#fefe40",
stroke = TRUE,
weight = 4,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = "country"
)
lvlCtryData <-
stats::setNames(meltCtryData[, mean(value, na.rm = TRUE), by = list(meltCtryData[[admLevel]])], c(admLevel, "value"))
lvlCtryData[["rank"]] <-
with(lvlCtryData, rank(value, ties.method = 'first'))
cbPalette <-
c(
"#999999",
"#E69F00",
"#56B4E9",
"#009E73",
"#F0E442",
"#0072B2",
"#D55E00",
"#CC79A7"
)
pal <- cbPalette
#turn off previous layer? No point keeping it if it is hidden. Also we want to turn the current layer to transparent so that one can see through to the raster layer on hover
ctryPoly <- Rnightlights::readCtryPolyAdmLayer(countries,
unlist(Rnightlights::getCtryShpLyrNames(countries, 1)))
ctryPoly <- sp::spTransform(ctryPoly, wgs84)
mapLabels <- sprintf(
paste0(
"%s:%s",
"<br/>Cluster: %s",
"<br/>Rad:%s",
"<br/>Rank: %s/%s"
),
admLevel,
lvlCtryData[[1]],
cutClusts,
format(
lvlCtryData[[2]],
scientific = T,
digits = 2
),
lvlCtryData[["rank"]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
map <- map %>% leaflet::addPolygons(
data = ctryPoly,
layerId = as.character(ctryPoly@data[, 'NAME_1']),
fill = TRUE,
fillColor = pal[cutClusts],
fillOpacity = 0.9,
stroke = TRUE,
weight = 1,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = admLevel,
highlight = leaflet::highlightOptions(
weight = 5,
#color = "#666",
#dashArray = "",
fillOpacity = 0,
bringToFront = TRUE
),
label = mapLabels,
labelOptions = leaflet::labelOptions(
style = list("font-weight" = "normal",
padding = "3px 8px"),
textsize = "15px",
direction = "auto"
)
)
}
map <-
map %>% leaflet::addLayersControl(overlayGroups = admLevel)
map <- map %>% leaflet::addLegend(
position = "bottomright",
colors = pal[unique(cutClusts)],
labels = unique(cutClusts),
#title = "Nightlight percentiles",
title = "clusters",
opacity = 1
)
map
})
})
######################## renderPlot plotTSDecomposed ###################################
output$plotTSDecomposed <- shiny::renderPlot({
#print(paste0("output: plotTSDecomposed"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
if (length(countries) < 1)
return()
normArea <- input$norm_area
admLevel <- unlist(ctryAdmLevels())[2]
#return if the country doesn't have adm levels below country
if (is.null(admLevel) || admLevel == "")
return()
if (length(countries) > 1)
admLevel <- "country"
scale <- input$scale
shiny::isolate({
nlType <- input$nlType
#meltCtryData <- ctryNlDataMeltedLvl2()
meltCtryData <- ctryNlDataMelted()
if (nrow(meltCtryData) < 2)
return()
if (normArea)
meltCtryData$value <-
meltCtryData$value / meltCtryData$area_sq_km
ctryAvg <- meltCtryData
#ctryAvg <- aggregate(value ~ country, data=meltCtryData, mean)
#ctryAvg <- stats::setNames(meltCtryData[,mean(value, na.rm = TRUE), by = list(meltCtryData[[make.names(admLevel)]], variable)], c(admLevel, "variable", "value"))
if (stringr::str_detect(nlType, "\\.D"))
fmt <- "%Y-%M-%d"
else if (stringr::str_detect(nlType, "\\.M"))
fmt <- "%Y-%M-%d"
else if (stringr::str_detect(nlType, "\\.Y"))
fmt <- "%Y"
minDate <- as.character(min(ctryAvg$variable))
maxDate <- as.character(max(ctryAvg$variable))
if (stringr::str_detect(nlType, "\\.Y") &&
stringr::str_detect(minDate, "\\d+$"))
{
minDate <- paste0(minDate, "-01-01")
maxDate <- paste0(maxDate, "-01-01")
freq <- 2
}
startYear <- lubridate::year(as.Date(minDate, fmt))
endYear <- lubridate::year(as.Date(maxDate, fmt))
if (startYear == endYear)
stop(Sys.time(), ": Only 1 data point (year) in the dataset")
tsStart <- c(startYear)
tsEnd <- c(endYear)
if (stringr::str_detect(nlType, "\\.D|\\.M"))
{
startMonth <-
lubridate::month(lubridate::ymd(min(ctryAvg$variable)))
endMonth <-
lubridate::month(lubridate::ymd(max(ctryAvg$variable)))
tsStart <- c(tsStart, startMonth)
tsEnd <- c(tsEnd, endMonth)
freq <- 12
}
if (stringr::str_detect(nlType, "\\.D"))
{
startDay <- lubridate::day(lubridate::ymd(max(ctryAvg$variable)))
endDay <-
lubridate::month(lubridate::ymd(max(ctryAvg$variable)))
tsStart <- c(tsStart, startDay)
tsEnd <- c(tsEnd, endDay)
freq <- 7
}
ctryDataTS <-
stats::ts(
ctryAvg$value,
start = tsStart,
end = tsEnd,
frequency = freq
)
ctryDataTScomponents <- stats::decompose(ctryDataTS)
#g <- ggplot2::autoplot(ctryDataTScomponents)
graphics::plot(ctryDataTScomponents)
})
})
######################## plotYearly ###################################
output$plotYearly <- shiny::renderPlot({
#print(paste0("output: renderPlotYearly"))
input$btnGo
countries <- shiny::isolate(getInputCountries())
if (is.null(countries))
return(NULL)
scale <- input$scale
nlPeriodRange <- input$nlPeriodRange
graphType <- input$graphType
normArea <- input$norm_area
shiny::isolate({
nlType <- input$nlType
ctryData <- ctryNlDataMelted()
if (is.null(countries) || is.null(ctryData))
return()
admLevel <- unlist(ctryAdmLevels())[1]
#print(paste0("admLevel:", admLevel))
if (!exists("admLevel") ||
is.null(admLevel) || length(admLevel) == 0)
admLevel <- "country"
ctryData$year <-
lubridate::year(as.Date(as.character(ctryData$variable), "%Y"))
lstAggBy <- paste0("list(", admLevel, ", variable")
lstAggBy <- paste0(lstAggBy, ", as.factor(year)")
aggNames <- "year"
if (stringr::str_detect(nlType, "\\.M"))
{
ctryData$month <-
lubridate::month(as.Date(as.character(ctryData$variable)))
lstAggBy <- paste0(lstAggBy, ", as.factor(month)")
aggNames <- c(aggNames, "month")
}
lstAggBy <- paste0(lstAggBy, ")")
if (stringr::str_detect(nlType, "\\.D"))
{
ctryData$day <-
lubridate::day(as.Date(as.character(ctryData$variable)))
lstAggBy <- paste0(lstAggBy, ", as.factor(day)")
aggNames <- c(aggNames, "day")
}
#print(paste0("ctrydata nrow:", nrow(ctryData)))
if (normArea)
ctryData$value <- (ctryData$value) / ctryData$area_sq_km
if (length(countries) == 1)
{
#switched to data.table aggregation
#ctryData <- stats::setNames(aggregate(ctryData$value, by=list(ctryData[,admLevel], ctryData[,"variable"]), mean, na.rm=T), c(admLevel, "variable", "value"))
ctryData <- stats::setNames(ctryData[, list(mean(value, na.rm = TRUE)),
by = eval(parse(text = lstAggBy))],
c(admLevel, "variable", aggNames, "value"))
g <- ggplot2::ggplot(ctryData,
aes(
x = eval(parse(text = aggNames[length(aggNames)])),
y = value,
col = year,
group = year
)) +
ggplot2::geom_line(alpha = 0.3) + ggplot2::geom_point() +
ggplot2::geom_smooth(
aes(group = 1),
method = "loess",
weight = 1,
alpha = 0.2,
lty = 'twodash'
) #+ theme(axis.text.x=element_text(angle=90,hjust=1,vjust=0.5)) #+ labs(col=year)
}
else
{
#ctryData <- aggregate(value ~ country+variable, data=ctryData, mean)
#switched to data.table aggregation
ctryData <-
stats::setNames(ctryData[, mean(value, na.rm = TRUE), by = eval(parse(text =
lstAggBy))],
c(admLevel, "variable", aggNames, "value"))
#g <- ggplot2::ggplot(data=ctryData, aes(x=variable, y=value, col=country, group=year))
g <-
ggplot2::ggplot(
ctryData,
aes(
x = eval(parse(text = aggNames[length(aggNames)])),
y = value,
col = country,
shape = year,
group = interaction(country, year)
)
) +
ggplot2::geom_line(lwd = .5, alpha = 0.3) +
ggplot2::geom_point() +
ggplot2::geom_smooth(
aes(group = country),
method = "loess",
weight = 1,
alpha = 0.2,
lty = 'twodash'
)
}
if ("scale_y_log" %in% scale)
g <- g + ggplot2::scale_y_log10()
if ("scale_x_log" %in% scale)
g <- g + ggplot2::scale_x_log10()
if (normArea)
g <-
g + ggplot2::labs(title = "Radiance", x = "Time", y = "Rad (W.Sr^⁻¹.cm^⁻²/Km²)") #y=expression(paste("Avg Rad W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, "per Km" ^{2})))
else
g <-
g + ggplot2::labs(title = "Radiance", x = "Time", y = "Rad (W.Sr^⁻¹.cm^⁻²") #y=expression(~Total~Rad~W %.% Sr^{-1}%.%cm^{-2}))
#plotly::ggplotly(g)
g
})
})
######################## plotNightLights ###################################
output$plotNightLights <- plotly::renderPlotly({
print(paste0("output: renderPlot"))
#input$btnGo
values$updatePlot
shiny::isolate({
countries <- shiny::isolate(getInputCountries())
radioAdmLevel <- shiny::isolate(input$radioAdmLevel)
nlPeriodRange <- shiny::isolate(input$nlPeriodRange)
if (is.null(nlPeriodRange))
return()
#not isolated since they act on loaded data
polySrc <- input$polySrc
polyVer <- input$polyVer
polyType <- input$polyType
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
ctryStat <- input$ctryStat
scale <- input$scale
graphType <- input$graphType
nlType <- shiny::isolate(input$nlType)
normArea <- input$norm_area
admLvlCtrlNames <- names(input)
x <- admLvlCtrlNames[grep("selectAdm\\d+$", admLvlCtrlNames)]
admLvlNums <- NULL
for (i in x)
if (length(input[[i]]) > 0)
admLvlNums <- c(admLvlNums, i)
#print(paste0("x", x))
#print(paste0("admlvlnums:", admLvlNums))
#if (admLvlNum=="" && length(countries)>0)
# return()
#not isolated to allow graph change by selecting admLevel radio input (radioAdmLevels)
ctryAdmLevels <- unlist(ctryAdmLevels())
admLvlNums <-
as.numeric(gsub(
pattern = "[^[:digit:]]",
replacement = "",
x = admLvlNums
))
if (length(admLvlNums) != 0)
{
admLevel <- ctryAdmLevels[as.numeric(data.table::last(admLvlNums))]
} else {
admLevel <- radioAdmLevel
}
#print(paste0("admLevel:", admLevel))
if (!exists("admLevel") ||
is.null(admLevel) || length(admLevel) == 0 ||
length(countries) > 1)
admLevel <- "country"
xLabel <- if (stringr::str_detect(nlType, "\\.D"))
"Day"
else if (stringr::str_detect(nlType, "\\.M"))
"Month"
else if (stringr::str_detect(nlType, "\\.Y"))
"Year"
ctryData <- ctryNlDataMelted()
if (is.null(ctryData))
{
if (is.null(nlType))
nlType <- "VIIRS.M"
g <- ggplot2::ggplot(data = data.frame()) +
geom_point()
if (grepl("\\.D", nlType))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m-%d")
else if (grepl("\\.M", nlType))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m")
else if (grepl("\\.Y", nlType))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 year", date_labels = "%Y")
# if(!exists("nlPeriodRange") || is.null(nlPeriodRange))
# {
# nlPeriodRange <- Rnightlights::getAllNlPeriods(nlTypes = nlType)
# nlPeriodRange <- c(nlPeriodRange[1], nlPeriodRange[length(nlPeriodRange)])
# nlPeriodRange <- Rnightlights::nlPeriodToDate(nlPeriod = nlPeriodRange, nlType = nlType)
# }
g <-
g + ggplot2::xlim(nlPeriodRange[1], nlPeriodRange[2]) +
ggplot2::ylim(0, 100) +
ggplot2::labs(title = "Nightlight Radiance",
x = xLabel,
y = "Radiance (W.Sr^⁻¹.cm^⁻²)"
) #bquote(paste("Radiance (W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, ")")))
return(plotly::ggplotly(g))
}
ctryData <-
subset(ctryData,
variable >= nlPeriodRange[1] & variable <= nlPeriodRange[2])
#filter by subsequent levels till lowest level
for (lvl in admLvlNums)
{
if (lvl == 1)
next()
#print(paste0("lvl:",lvl))
if (length(input[[grep(lvl, x, value = T)]]) > 0)
{
ctryData <-
subset(ctryData, ctryData[[ctryAdmLevels[lvl]]] %in% input[[grep(lvl, x, value =
T)]])
}
}
#if all selectAdmLevels are empty use radioAdmLevel
# if (length(admLvlNums) == 0)
# {
# ctryData <- subset(ctryData, ctryData[[ctryAdmLevels[lvl]]] == radioAdmLevel)
# }
#print(paste0("ctrydata nrow:", nrow(ctryData)))
if (normArea)
ctryData$value <- ctryData$value / ctryData$area_sq_km
if (graphType == "boxplot")
{
if (length(countries) == 1)
{
g <-
ggplot2::ggplot(data = ctryData,
ggplot2::aes(
x = ctryData[[admLevel]],
y = value,
col = ctryData[[admLevel]]
)) +
ggplot2::theme(axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
)) + ggplot2::labs(col = admLevel) + facet_grid(
lubridate::year(variable) ~ lubridate::month(
x = variable,
label = T,
abbr = T
)
)
}
else
{
g <-
ggplot2::ggplot(data = ctryData,
ggplot2::aes(
x = country,
y = value,
col = country
)) + ggplot2::theme(
axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
),
panel.spacing.x = unit(0.1, "lines")
) + ggplot2::labs(col = admLevel) + facet_grid(
lubridate::year(variable) ~ lubridate::month(
x = variable,
label = T,
abbr = T
)
)
}
#ggplot2::ggplot(data = ctryData, ggplot2::aes(x = factor(variable), y = value, col = country)) + ggplot2::theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5)) + ggplot2::labs(col = admLevel) + geom_boxplot() + facet_grid(country ~ .)
g <- g + ggplot2::geom_boxplot()# +facet_grid(.~variable)
}
else if (graphType == "line")
{
if (length(countries) == 1)
{
#switched to data.table aggregation
#ctryData <- stats::setNames(aggregate(ctryData$value, by=list(ctryData[,admLevel], ctryData[,"variable"]), mean, na.rm=T), c(admLevel, "variable", "value"))
ctryData <-
stats::setNames(ctryData[, value, by = list(ctryData[[admLevel]], variable)], c(admLevel, "variable", "value"))
g <-
ggplot2::ggplot(data = ctryData, aes(
x = variable,
y = value,
col = ctryData[[admLevel]]
))
if (stringr::str_detect(nlType, "\\.D"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 day", date_labels = "%Y-%m-%d")
else if (stringr::str_detect(nlType, "\\.M"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m")
else if (stringr::str_detect(nlType, "\\.Y"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 year", date_labels = "%Y")
}
else
{
#ctryData <- aggregate(value ~ country+variable, data=ctryData, mean)
#switched to data.table aggregation
ctryData <-
stats::setNames(ctryData[, value, by = list(country, variable)], c("country", "variable", "value"))
g <-
ggplot2::ggplot(data = ctryData, aes(
x = variable,
y = value,
col = country
))
if (stringr::str_detect(nlType, "VIIRS"))
g <-
g + ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m")
}
g <- g + ggplot2::geom_line() + ggplot2::geom_point() +
ggplot2::theme(axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 0.5
)) +
ggplot2::labs(col = admLevel)
}
else if (graphType == "histogram")
{
#ctryData <- aggregate(value ~ country+variable, data=ctryData, mean)
g <- ggplot2::ggplot(data = ctryData, aes(x = value))
g <- g + ggplot2::geom_histogram(
aes(y = ..density..),
bins = 30,
colour = "black",
fill = "white"
) +
# Overlay with transparent density plot
ggplot2::geom_density(alpha = .2, fill = "#FF6666") +
ggplot2::facet_grid(ctryData[[admLevel]] ~ lubridate::year(variable))
}
else
return(NULL)
if ("scale_y_log" %in% scale)
g <- g + ggplot2::scale_y_log10()
if ("scale_x_log" %in% scale)
g <- g + ggplot2::scale_x_log10()
plotTitle <-
paste0(
"Nightlight Radiance (",
Rnightlights:::nlSignatureStatName(statSig = ctryStat),
ifelse(grepl(pattern = "na.rm", x = ctryStat), "*", ""),
")"
)
if (normArea)
g <- g + ggplot2::labs(
title = plotTitle,
x = xLabel,
y = "Avg Rad (W.Sr^⁻¹.cm^⁻²/Km²)",
#bquote(paste("Avg Rad W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, " / Km" ^{2}))
caption = ifelse(
grepl(pattern = "na.rm", x = ctryStat),
paste0(ctryStat, " NAs removed"),
paste0(ctryStat, " NAs not removed")
)
) #y=expression(paste("Avg Rad W" %.% "Sr" ^{-1} %.% "cm" ^{-2}, "per Km" ^{2})))
else
g <- g + ggplot2::labs(title = plotTitle,
x = xLabel,
y = "Total Rad (W.Sr^⁻¹.cm^⁻²)") #bquote(~Total~Rad~W %.% Sr^{-1}%.%cm^{-2})) #y=expression(~Total~Rad~W %.% Sr^{-1}%.%cm^{-2}))
#g
p <- plotly::ggplotly(g)
p$elementId <- NULL
p
})
})
######################## renderDataTable dataset ###################################
output$dataset <- DT::renderDataTable({
if (is.null(ctryNlData()))
return()
ctryStat <- shiny::isolate(input$ctryStat)
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
configName <- input$configName
multiTileMergeStrategy <- input$multiTileMergeStrategy
multiTileMergeFun <- input$multiTileMergeFun
removeGasFlares <- input$removeGasFlares
startDate <-
Rnightlights::dateToNlPeriod(input$nlPeriodRange[1], input$nlType)
endDate <-
Rnightlights::dateToNlPeriod(input$nlPeriodRange[2], input$nlType)
ctryData <- ctryNlData()
allCols <- names(ctryData)
admCols <- grep("NL_", allCols, invert = TRUE, value = TRUE)
#the cols with the stats we want
dataCols <-
grep(
pattern = ctryStat,
x = allCols,
value = TRUE,
fixed = T
)
dataCols <-
grep(pattern = configName,
x = dataCols,
value = TRUE)
dataCols <-
grep(pattern = paste0("GF", substr(removeGasFlares, 1, 1)),
x = dataCols,
value = TRUE)
dataCols <-
grep(
pattern = paste0("MTS", multiTileMergeStrategy),
x = dataCols,
value = TRUE
)
dataCols <-
grep(pattern = multiTileMergeFun,
x = dataCols,
value = TRUE)
dataColDates <- gsub(".*_(\\d{4,8})_.*", "\\1", dataCols)
dataCols <-
dataCols[dataColDates >= startDate & dataColDates <= endDate]
ctryData <- ctryData[, c(admCols, dataCols), with = F]
},
options = list(scrollX = TRUE, scrolly = TRUE))
######################## renderDataTable dataset ###################################
output$availableData <- DT::renderDataTable({
dt <- ctryNlDataList()
if (is.null(dt))
return()
names(dt) <-
c(
"DT",
"CCode",
"ADM",
"NlType",
"CfgName",
"MTS",
"MTF",
"RGF",
"NlPeriod",
"PolySrc",
"PolyVer",
"PolyType",
"NlStats"
)
dt
},
options = list(
scrollX = TRUE,
scrollY = FALSE,
autoWidth = TRUE,
columnDefs = list(list(width = "100px"))
))
######################## observe map ###################################
observe({
print(paste0("observe: map"))
#input$btnGo
values$updateMap
shiny::isolate({
countries <- getInputCountries()
if (is.null(countries) ||
is.null(input$nlPeriod) || is.null(input$nlType))
return()
nlPeriod <- input$nlPeriod
scale <- input$scale
nlType <- shiny::isolate(input$nlType)
normArea <- input$norm_area
polySrc <- shiny::isolate(input$polySrc)
polyVer <- shiny::isolate(input$polyVer)
polyType <- shiny::isolate(input$polyType)
custPolyPath <- if (polySrc == "CUST") polyVer else NULL
ctryStat <- shiny::isolate(input$ctryStat)
if (is.null(polySrc) ||
is.null(polyVer) || polySrc == "" || polyVer == "")
return()
admLevel <- shiny::isolate(input$radioAdmLevel)
if (is.null(admLevel))
admLevel <- "country"
shiny::isolate({
# if (is.null(countries) || is.null(nlPeriod) || is.null(admLevel))
# return()
mapExtent <- NULL
selected <- NULL
map <- leaflet::leafletProxy("map") %>%
leaflet::clearShapes() %>%
leaflet::clearControls()
if (length(countries) > 1) {
admLevel <- "country"
ctryPoly0 <-
Rnightlights::readCtryPolyAdmLayer(
ctryCode = countries[1],
admLevel = unlist(
Rnightlights::getCtryShpLyrNames(ctryCodes = countries[1],
lyrNums = 0)
)
)
for (country in countries[2:length(countries)])
{
ctryPoly0 <- sp::rbind.SpatialPolygonsDataFrame(
ctryPoly0,
Rnightlights::readCtryPolyAdmLayer(
ctryCode = country,
admLevel = unlist(Rnightlights::getCtryShpLyrNames(country, 0))
),
makeUniqueIDs = T
)
}
ctryPoly0 <- sp::spTransform(ctryPoly0, wgs84)
mapExtent <- raster::extent(ctryPoly0)
ctryData <- ctryNlDataMelted()
if (is.null(ctryData))
return()
#data already in data.table form
lvlCtryData <-
stats::setNames(ctryData[, list(mean(value, na.rm = T),
sum(area_sq_km, na.rm =T)),
by = list(ctryData[["country"]], ctryData[["variable"]])],
c("country", "variable", "value", "area_sq_km"))
#rank the data
varname <- paste0('rankcountry')
lvlCtryData[[varname]] <-
with(lvlCtryData, rank(-value, ties.method = 'first'))
#palette deciles for the layer
bins <-
rev(stats::quantile(lvlCtryData$value, seq(0, 1, 0.1), na.rm = T))
brewerPal <-
rev(RColorBrewer::brewer.pal(n = 10, name = "YlOrRd"))
pal <-
leaflet::colorBin(
palette = brewerPal,
domain = lvlCtryData$value,
na.color = "grey",
bins = bins
)
mapLabels <- sprintf(
paste0(
"<strong>%s:%s</strong>",
"<br/>Area: %s km<superscript>2</superscript>",
"<br/>Date: %s",
ifelse(
normArea,
paste0("<br/>Rad (", ctryStat, "): %s /sq.km"),
paste0("<br/>Rad (", ctryStat, "): %s")
),
"<br/>Rank: %s/%s"
),
"country",
lvlCtryData[["country"]],
format(lvlCtryData[["area_sq_km"]], scientific = F, digits = 2),
lvlCtryData[["variable"]],
format(lvlCtryData[["value"]], scientific = F, digits = 2),
lvlCtryData[[paste0("rankcountry")]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
map <- map %>% leaflet::addPolygons(
data = ctryPoly0,
#layerId = "country",
fill = TRUE,
fillColor = ~ pal(lvlCtryData[["value"]]),
fillOpacity = 0.9,
stroke = TRUE,
weight = 1,
#color=lineCol[iterAdmLevel],
color = "white",
smoothFactor = 0.7,
opacity = 1,
#dashArray = "5",
group = "country",
popup = mapLabels,
popupOptions = leaflet::popupOptions(
keepInView = T,
closeOnClick = T,
closeButton = T
),
highlightOptions = leaflet::highlightOptions(
weight = 5,
#color = "yellow",
#dashArray = "4",
fillOpacity = 0,
bringToFront = FALSE
)
)
} else {
#if 1 country
for (country in countries)
{
admLvlCtrlNames <- names(input)
x <-
admLvlCtrlNames[grep("selectAdm\\d+$", admLvlCtrlNames)]
admLvlNums <- NULL
for (i in x)
if (length(input[[i]]) > 0)
admLvlNums <- c(admLvlNums, i)
#print(paste0("x", x))
#print(paste0("admlvlnums:", admLvlNums))
admLvlNums <-
as.numeric(gsub("[^[:digit:]]", "", admLvlNums))
#print(paste0("admlvlNums:", admLvlNums))
#get the selected admLevel and convert to lyrnum
ctryAdmLevels <-
Rnightlights:::getCtryStructAdmLevelNames(
ctryCode = country,
gadmVersion = polyVer,
gadmPolyType = polyType,
custPolyPath = NULL
)
#ctryAdmLevels <- unlist(ctryAdmLevels[which(countries == country)])
if (!is.null(admLevel) || admLevel == "country")
lyrNum <- which(ctryAdmLevels == admLevel)
else
lyrNum <- 0
#line weight increases. max=4 min=1
deltaLineWt <- (4 - 1) / as.numeric(lyrNum)
#line color darkens
if (stringr::str_detect(nlType, "OLS"))
nlYm <- nlPeriod
else if (stringr::str_detect(nlType, "VIIRS"))
nlYm <- as.Date(nlPeriod, "%Y%m%d")
ctryData <- ctryNlDataMelted()
if (is.null(ctryData))
return()
#get our data ready to match with polygons
#subset data based on level selections
if (stringr::str_detect(nlType, "OLS"))
ctryData <- subset(x = ctryData, variable == nlYm)
else if (stringr::str_detect(string = nlType, pattern = "VIIRS"))
ctryData <-
subset(x = ctryData,
subset = lubridate::year(variable) == lubridate::year(nlYm) &
lubridate::month(variable) == lubridate::month(nlYm)
)
if (normArea)
ctryData$value <- ctryData$value / ctryData$area_sq_km
ctryPoly0 <-
Rnightlights::readCtryPolyAdmLayer(
ctryCode = country,
admLevel = unlist(Rnightlights::getCtryShpLyrNames(country, 0))
)
ctryPoly0 <- sp::spTransform(ctryPoly0, wgs84)
e <- raster::extent(ctryPoly0)
if (exists("mapExtent") && !is.null(mapExtent))
{
mapExtent@xmin <- min(mapExtent@xmin, e@xmin)
mapExtent@ymin <- min(mapExtent@ymin, e@ymin)
mapExtent@xmax <- max(mapExtent@xmax, e@xmax)
mapExtent@ymax <- max(mapExtent@ymax, e@ymax)
}
else
{
mapExtent <- e
}
if (stringr::str_detect(nlType, "OLS"))
nlPeriod <- substr(gsub("-", "", nlYm), 1, 4)
else if (stringr::str_detect(nlType, "VIIRS"))
nlPeriod <- substr(gsub("-", "", nlYm), 1, 6)
map <- map %>%
leaflet::clearShapes() %>%
leaflet::clearControls() %>%
leaflet::addPolygons(
layerId = country,
fill = FALSE,
fillColor = "#fefe40",
stroke = TRUE,
weight = 4,
smoothFactor = 0.7,
opacity = 1,
color = "white",
#dashArray = "5",
group = "country",
data = ctryPoly0
)
selected <- NULL
lineCol <- rev(hexbin::BTC(lyrNum + 1, 200, 250))
if (lyrNum > 1)
#skip drawing the country level. avoid reverse seq (2:1)
for (iterAdmLevel in 2:lyrNum)
{
#aggregate the data to the current level
iterAdmLevelName <- ctryAdmLevels[iterAdmLevel]
#data already in data.table form
lvlCtryData <-
stats::setNames(ctryData[, list(mean(value, na.rm = T),
sum(area_sq_km, na.rm =T)),
by = list(ctryData[[iterAdmLevelName]],
ctryData[["variable"]])],
c(iterAdmLevelName, "variable", "value", "area_sq_km"))
#rank the data
varname <- paste0('rank', iterAdmLevel)
lvlCtryData[[varname]] <-
with(lvlCtryData, rank(-value, ties.method = 'first'))
#palette deciles for the layer
bins <-
rev(stats::quantile(lvlCtryData$value, seq(0, 1, 0.1), na.rm = T))
brewerPal <-
rev(RColorBrewer::brewer.pal(n = 10, name = "YlOrRd"))
pal <-
leaflet::colorBin(
palette = brewerPal,
domain = lvlCtryData$value,
na.color = "grey",
bins = bins
)
#turn off previous layer? No point keeping it if it is hidden. Also we want to turn the current layer to transparent so that one can see through to the raster layer on hover
ctryPoly <-
Rnightlights::readCtryPolyAdmLayer(country,
unlist(
Rnightlights::getCtryShpLyrNames(country, iterAdmLevel - 1)
))
ctryPoly <- sp::spTransform(ctryPoly, wgs84)
e <- raster::extent(ctryPoly)
if (exists("mapExtent") && !is.null(mapExtent))
{
mapExtent@xmin <- min(mapExtent@xmin, e@xmin)
mapExtent@ymin <- min(mapExtent@ymin, e@ymin)
mapExtent@xmax <- max(mapExtent@xmax, e@xmax)
mapExtent@ymax <- max(mapExtent@ymax, e@ymax)
}
else
{
mapExtent <- e
}
if (length(admLvlNums) > 0)
if ((iterAdmLevel) == data.table::last(admLvlNums))
#iterAdmLevel+1 %in% admLvlNums)
selected <-
which(ctryPoly@data[[paste0("NAME_", iterAdmLevel - 1)]] %in% input[[paste0("selectAdm", iterAdmLevel)]])
else
selected <- c()
mapLabels <- sprintf(
paste0(
"<strong>%s:%s</strong>",
"<br/>Area: %s km<superscript>2</superscript>",
"<br/>Date: %s",
ifelse(
normArea,
paste0("<br/>Rad (", ctryStat, "): %s /sq.km"),
paste0("<br/>Rad (", ctryStat, "): %s")
),
"<br/>Rank: %s/%s"
),
ctryAdmLevels[iterAdmLevel],
lvlCtryData[[ctryAdmLevels[iterAdmLevel]]],
format(
lvlCtryData[["area_sq_km"]],
scientific = F,
digits = 2
),
lvlCtryData[["variable"]],
format(
lvlCtryData[["value"]],
scientific = F,
digits = 2
),
lvlCtryData[[paste0("rank", iterAdmLevel)]],
nrow(lvlCtryData)
) %>% lapply(htmltools::HTML)
#only the lowest layer will have fill, label, etc
if (iterAdmLevel == lyrNum)
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly,
layerId = as.character(ctryPoly@data[, paste0('NAME_', iterAdmLevel -
1)]),
fill = TRUE,
fillColor = ~ pal(lvlCtryData[["value"]]),
fillOpacity = 0.9,
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt,
#color=lineCol[iterAdmLevel],
color = "white",
smoothFactor = 0.7,
opacity = 1,
#dashArray = "5",
group = ctryAdmLevels[iterAdmLevel],
popup = mapLabels,
popupOptions = leaflet::popupOptions(
keepInView = T,
closeOnClick = T,
closeButton = T
),
highlightOptions = leaflet::highlightOptions(
weight = 5,
#color = "yellow",
#dashArray = "4",
fillOpacity = 0,
bringToFront = FALSE
)
)
} else
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly,
layerId = as.character(ctryPoly@data[, paste0('NAME_', iterAdmLevel -
1)]),
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt,
smoothFactor = 0.7,
opacity = 1,
#color=lineCol[iterAdmLevel],
color = "white",
#dashArray = "5",
group = ctryAdmLevels[iterAdmLevel]
)
}
if (length(selected) > 0)
mapExtent <- NULL
for (iterPoly in selected)
{
map <- map %>% leaflet::addPolygons(
data = ctryPoly[iterPoly, ],
layerId = paste0(as.character(ctryPoly@data[iterPoly, paste0('NAME_', iterAdmLevel -
1)]), "_selected"),
fill = FALSE,
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt + 0.5,
opacity = 1,
color = "blue",
# dashArray = "5",
group = "selected",
highlightOptions = leaflet::highlightOptions(
stroke = TRUE,
weight = 4 - (iterAdmLevel - 1) * deltaLineWt + 0.5,
opacity = 1,
color = "blue",
bringToFront = TRUE
)
)
e <- raster::extent(ctryPoly[iterPoly, ])
if (exists("mapExtent") && !is.null(mapExtent))
{
mapExtent@xmin <- min(mapExtent@xmin, e@xmin)
mapExtent@ymin <- min(mapExtent@ymin, e@ymin)
mapExtent@xmax <- max(mapExtent@xmax, e@xmax)
mapExtent@ymax <- max(mapExtent@ymax, e@ymax)
}
else
{
mapExtent <- e
}
}
}
}
if (length(selected) > 0)
{
map <-
map %>% leaflet::addLayersControl(overlayGroups = c("ctryRaster",
ctryAdmLevels[2:lyrNum],
"selected"))
map <-
leaflet::flyToBounds(
map = map,
lng1 = mapExtent@xmin,
lat1 = mapExtent@ymin,
lng2 = mapExtent@xmax,
lat2 = mapExtent@ymax
)
}
else
map <-
map %>% leaflet::addLayersControl(overlayGroups = c("ctryRaster",
ctryAdmLevels[2:lyrNum]))
if (admLevel != "country")
map <- map %>%
leaflet::addLegend(
position = "bottomright",
pal = pal,
values = format(ctryData$value, scientific = T),
labels = stats::quantile(ctryData$value, seq(1, 0, -0.1), na.rm =
T),
#title = "Nightlight percentiles",
title = ifelse(normArea, "Rad/sq. Km.", "Rad"),
opacity = 1
)
}
#Zoom
if (exists("mapExtent"))
map <- map %>%
leaflet::flyToBounds(mapExtent@xmin,
mapExtent@ymin,
mapExtent@xmax,
mapExtent@ymax)
map
})
})
})
######################## map ###################################
output$map <- leaflet::renderLeaflet({
print(paste0("output: map"))
# Use leaflet() here, and only include aspects of the map that
# won't need to change dynamically (at least, not unless the
# entire map is being torn down and recreated).
#input$btnGo
#values$updateMap
shiny::isolate({
#if (is.null(input$nlType) || is.null(input$nlPeriod))
# return()
map <- leaflet::leaflet() %>%
leaflet::addTiles("http://a.basemaps.cartocdn.com/dark_all/{z}/{x}/{y}.png") %>%
leaflet::addWMSTiles(
layerId = "nlRaster",
baseUrl = paste0(
"http://localhost/cgi-bin/mapserv?map=",
file.path(path.expand(
Rnightlights::getNlDir("dirRasterOutput")
),
"nightlights.map")
),
layers = "NL_CTRYCODE_VIIRS.M_NLPERIOD_VCMCFG-MTSALL-MEAN-RGFT_GADM-3.6-SHPZIP",
group = "ctryRaster",
options = leaflet::WMSTileOptions(
format = "image/png",
transparent = TRUE,
opacity = 0.8,
TIME = Rnightlights::dateToNlPeriod(input$nlPeriod, input$nlType)
)
)
return(map)
})
})
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.